From 680b8e7e595e59f10c973c6045017de05a19f290 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:13:12 +0700 Subject: [PATCH 01/20] A refusal inside a generic copy names each call that asked for it, a refused generic body is reported once, and a type variable prints with its $ --- TODO.org | 15 ----------- lib/check.ml | 57 ++++++++++++++++++++++++++++++++++------- lib/dev.ml | 8 +++--- lib/types.ml | 2 +- test/test_acceptance.ml | 6 ++--- test/test_flan.ml | 39 +++++++++++++++++++++++++--- 6 files changed, 90 insertions(+), 37 deletions(-) diff --git a/TODO.org b/TODO.org index 899c9b6e..0a5e280d 100644 --- a/TODO.org +++ b/TODO.org @@ -767,12 +767,6 @@ clause here admits nothing but type predicates. Whether it should take value predicates over a length parameter deserves answering deliberately rather than falling out of the implementation. -** TODO "In instantiation of" notes -A refusal inside a copy points at the generic's source with no note naming the -call site that asked for that type. The data is there — =instantiation_origin= -exists and the session already uses it — and wiring it into every failure under an -instantiation is a lane of its own. - ** DONE A program is one compilation, so a generic's body is always visible CLOSED: [2026-09-25] Odin's and Zig's model: packages are never compiled separately. The cost is build @@ -1030,15 +1024,6 @@ ignore order, writable access has to alias the real storage. Flexible field orde waits for classes deliberately, because a class owns its layout and a =Vector2= should not pay for identity and metadata. Not implemented. -** TODO An error in a called generic's body is reported twice -=(defn g [x $t] u64 (nosuch x))= called once from =main= prints "unknown -function nosuch" twice at the same place and counts 2 errors — once from the -abstract pass and once from the instantiation. - -** TODO A type variable is printed without its $ -=Types.to_string= prints =Var t= as =t=, so a refusal reads "selection-sort -expects [t] here, found [3 i32]" where the source wrote =[$t]=. - ** DONE Two refusals suggested something that does not compile CLOSED: [2026-09-25] =vec-new= and =map-new= with no type no longer say "or give the binding a type"; diff --git a/lib/check.ml b/lib/check.ml index ee0c4daf..0c03ca82 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -192,6 +192,12 @@ type env = { chain. Odin has no cap of its own to copy, so there was nothing to borrow. *) mutable chain : (string * Types.t list * Loc.t) list; + (* Generics whose abstract pass was refused and recorded, in a whole-file + check that goes on after a refusal. A call site still gets a copy's + signature, but its body is not checked again: every refusal the abstract + pass made would come back from the copy, at the same line, once per type + it was called at. *) + refused_generics : (string, unit) Hashtbl.t; (* Set while a struct, data-case or union field's type is being resolved, and only then. It exists for one message: an unknown lowercase name in a type slot is told to introduce a type variable with [$name] in the @@ -240,6 +246,7 @@ let new_env () = { subst = []; tvpreds = []; chain = []; + refused_generics = Hashtbl.create 4; in_field = false; classes = Hashtbl.create 8; tracks = Hashtbl.create 16; @@ -2157,7 +2164,7 @@ let unconstrained env loc op ~needs (t : Types.t) = | _ -> Loc.failk "check/unconstrained-type-variable" loc "%s over the type variable %s: nothing declares %s %s. Write \ - {:where (%s $%s)} at the head of the body, or take the operation as \ + {:where (%s %s)} at the head of the body, or take the operation as \ a parameter, a (Fn [%s %s] ...), and call it here" op (Types.to_string t) (Types.to_string t) needs needs (Types.to_string t) (Types.to_string t) (Types.to_string t) @@ -2185,6 +2192,9 @@ let rec mangle_ty (t : Types.t) = | Types.CFn (ps, r) -> Printf.sprintf "cfn-%s-to-%s" (String.concat "-" (List.map mangle_ty ps)) (mangle_ty r) + (* Bare, because [Types.to_string] spells a variable with its [$] for the + reader and a symbol has no room for one. *) + | Types.Var n -> n | t -> Types.to_string t (* ── The runaway instantiation, refused by name rather than by depth ──── @@ -4099,14 +4109,14 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = | Some (Types.Int k) -> not (Types.signed k) | _ -> false) -> let t = Option.get want in - let gname, _, at = List.nth ctx.env.chain (List.length ctx.env.chain - 1) in + (* [instantiate] adds the note naming the call that asked for this copy. *) + let gname, _, _ = List.nth ctx.env.chain (List.length ctx.env.chain - 1) in let var = match List.find_opt (fun (_, u) -> Types.equal u t) ctx.env.subst with | Some (v, _) -> Printf.sprintf "$%s = %s" v (Types.to_string t) | None -> Types.to_string t in Loc.failk literal_at_want loc - ~notes:[ Loc.note at (Printf.sprintf "%s is instantiated at %s here" gname var) ] "%Ld does not fit in %s, which holds no negative number, and %s is called \ at %s — the body has to work at every type it is called at, so write \ it with no negative literal, as in (- x %Ld) in place of (+ x %Ld)" @@ -6548,9 +6558,7 @@ and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a = (Printf.sprintf "this array's first element is %s, so every \ element is" - (match first.Tast.ty with - | Types.Var v -> "$" ^ v - | t -> Types.to_string t)) ] })) + (Types.to_string first.Tast.ty)) ] })) rest; raise (Loc.Error d) @@ -11284,11 +11292,39 @@ and instantiate env loc gname vars subst cparams cret = env.subst <- saved_subst; env.tyvars <- saved_vars; env.tvpreds <- saved_preds; env.chain <- saved_chain in + if Hashtbl.mem env.refused_generics gname then begin + restore (); + sym + end else let tfn = match !check_fn_ref env { fn with Ast.name = sym } with | tfn -> restore (); tfn | exception e -> restore (); + (* The refusal is inside the generic's source, which says nothing about + which call asked for this copy; the note names it. Nested copies + each add their own, so the notes walk the chain back to the call + the programmer wrote. *) + let e = + match e with + | Loc.Error d when d.Loc.dloc <> loc -> + let at = + String.concat ", " + (List.map + (fun v -> Printf.sprintf "$%s = %s" v + (Types.to_string (List.assoc v subst))) + vars) + in + Loc.Error + (Loc.sort_notes + { d with + Loc.notes = + d.Loc.notes + @ [ Loc.note loc + (Printf.sprintf "%s is instantiated at %s here" + gname at) ] }) + | e -> e + in (* A copy whose body did not check is not a copy. Both entries go back out, so a second call at the same types is the same refusal again rather than a cache hit on a function that does not exist. *) @@ -13933,9 +13969,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defn fn when Hashtbl.mem env.gsigs fn.Ast.name -> - ignore - (Loc.caught s (fun () -> - tolerant fn.Ast.name (fun () -> Some (check_generic env fn)))) + (match + Loc.caught s (fun () -> + tolerant fn.Ast.name (fun () -> Some (check_generic env fn))) + with + | None -> Hashtbl.replace env.refused_generics fn.Ast.name () + | Some _ -> ()) | _ -> ()) decls; let globals = diff --git a/lib/dev.ml b/lib/dev.ml index 7f052f25..8c54e3e7 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -669,14 +669,12 @@ let host_loc t name = that was written finds nothing in the program, and these are how it gets from that name to what the program does hold. *) -(* Its signature as written, [$] and all — [Types.to_string] prints a variable - bare, and [[t]] is not how anyone wrote it. *) +(* Its signature as written, [$] and all. *) let generic_signature t name = match Hashtbl.find_opt t.session.Session.env.Check.gsigs name with | None -> None - | Some (vars, params, ret) -> - let dollar = List.map (fun v -> (v, Types.Var ("$" ^ v))) vars in - let show ty = Types.to_string (Check.subst_ty dollar ty) in + | Some (_, params, ret) -> + let show ty = Types.to_string ty in Some (Printf.sprintf "%s [%s] %s" name (String.concat " " (List.map show params)) (show ret)) diff --git a/lib/types.ml b/lib/types.ml index 3513621f..6e2bb57d 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -231,7 +231,7 @@ let rec to_string = function | CFn (ps, r) -> Printf.sprintf "(CFn [%s] %s)" (String.concat " " (List.map to_string ps)) (to_string r) - | Var n -> n + | Var n -> "$" ^ n | Dyn -> "dyn" let is_numeric = function Int _ | Float _ -> true | _ -> false diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index a0fe1a0f..4f08c8bf 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3608,7 +3608,7 @@ let () = chain of instantiations and not a depth it gave up at. *) refuses "an unconstrained operator in a generic body" "programs/generic-reject.flan" - "nothing declares t numeric?"; + "nothing declares $t numeric?"; refuses "an unconstrained operator names the way out" "programs/generic-reject.flan" "{:where (numeric? $t)}"; refuses "a runaway instantiation" "programs/generic-runaway.flan" @@ -4680,10 +4680,10 @@ level "1" the easier of the two to leave open. *) refuses "a nested function type does not widen" "programs/fn-generic-nested.flan" - "hof expects (Fn [(Fn [t] t)] i32) here"; + "hof expects (Fn [(Fn [$t] $t)] i32) here"; refuses "and neither does one in return position" "programs/fn-generic-nested-return.flan" - "call-twice expects (Fn [] (Fn [] t)) here"; + "call-twice expects (Fn [] (Fn [] $t)) here"; outputs ~dev:true "an fn capturing by value, dev" "programs/fn-capture.flan" fn_capture_out; diff --git a/test/test_flan.ml b/test/test_flan.ml index 4d0f57f7..d306b1d1 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1417,7 +1417,7 @@ let () = accepts "all-distinct over a type variable" "(defn three [a $t b $t c $t] bool {:where (equal? $t)} (!= a b c))"; rejects_check "a chain still wants the right predicate" - ~needle:"nothing declares t ordered?" + ~needle:"nothing declares $t ordered?" "(defn between [a $t b $t c $t] bool {:where (equal? $t)} (< a b c))"; (* One operand and none. Both would have to be [true] whatever they were handed, which is a typo carrying a value. *) @@ -5988,6 +5988,37 @@ let () = check "and they are in source order" (List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2; 3 ])); + (* A generic whose abstract pass was refused is not checked again at each + copy: the refusal is one error, however many types call it, and the + caller's own later refusal is still found. *) + (match + Check.program_all + (Parse.program_all + (read "(defn g [x $t] u64 (nosuch x))\n\ + (defn main [] i32 (g 3) (g true) nope 0)\n")) + with + | _ -> check "a refused generic body is refused" false + | exception Loc.Errors ds -> + check "a refused generic body is one error, and its caller's is another" + (List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2 ])); + + (* A refusal inside a copy names the call that asked for it, and each copy + between: the chain walks back to the line the programmer wrote. *) + (match + checked + "(defn show [v $t] () (println v)) \ + (defn outer [v $t] () (show v)) \ + (defn main [] i32 (outer main) 0)" + with + | _ -> check "a copy with no printer is refused" false + | exception Loc.Error d -> + let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in + check "a refusal in a copy names both instantiations" + (contains d.Loc.dmsg "no printer for" + && notes + = [ "show is instantiated at $t = (CFn [] i32) here"; + "outer is instantiated at $t = (CFn [] i32) here" ])); + (* The parser resynchronises on a top-level form, so two bad declarations are two errors rather than one. *) (match Parse.program_all (read "(defn a)\n(defn b)\n") with @@ -6046,7 +6077,7 @@ let () = accepts "numeric? admits +" "(defn add [a $t b $t] $t {:where (numeric? $t)} (+ a b))"; rejects_check "equal? does not admit <" - ~needle:"nothing declares t ordered?" + ~needle:"nothing declares $t ordered?" "(defn less [a $t b $t] bool {:where (equal? $t)} (< a b))"; (* The entailments, which are the reason a signature is one predicate long rather than two. Every type the language orders is a number or an enum, @@ -6074,10 +6105,10 @@ let () = accepts "integer? admits the shifts" "(defn dbl [x $t] $t {:where (integer? $t)} (<< x 1))"; rejects_check "numeric? does not admit bit-and" - ~needle:"nothing declares t integer?" + ~needle:"nothing declares $t integer?" "(defn low? [x $t] bool {:where (numeric? $t)} (= (bit-and x 1) 1))"; rejects_check "nor the shifts" - ~needle:"nothing declares t integer?" + ~needle:"nothing declares $t integer?" "(defn dbl [x $t] $t {:where (numeric? $t)} (<< x 1))"; (* An integer?-bounded caller satisfies a numeric?-bounded callee: the entailment carries across generic calls exactly as ordered?-over-equal? From 4054c4921ba9724ff543f197a46c5dea1bd4f2f0 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:08:14 +0700 Subject: [PATCH 02/20] A defstruct whose fields introduce $t or an array length $n is a generic struct, each application of it an ordinary struct copy that generic functions bind against, and a printed call is evaluated once --- TODO.org | 13 +- lib/ast.ml | 3 + lib/check.ml | 984 +++++++++++++++++++++++++----- lib/cimport.ml | 1 + lib/dev.ml | 21 +- lib/emit.ml | 7 +- lib/js.ml | 2 + lib/load.ml | 8 +- lib/parse.ml | 20 +- lib/session.ml | 11 +- lib/shim.ml | 1 + lib/types.ml | 26 +- lib/x86.ml | 1 + test/programs/generic-struct.flan | 89 +++ test/test_acceptance.ml | 12 + test/test_flan.ml | 83 ++- test/test_session.ml | 20 + 17 files changed, 1111 insertions(+), 191 deletions(-) create mode 100644 test/programs/generic-struct.flan diff --git a/TODO.org b/TODO.org index 0a5e280d..98476f68 100644 --- a/TODO.org +++ b/TODO.org @@ -750,15 +750,10 @@ depth it gave up at. The bare depth number is a backstop that also prints the chain. Before any of it, the compiler hung rather than failed, which wedges =C-c C-c= with nothing to show. -** NEXT Generic types -Decided 2026-09-25: the freeze is lifted for this; build both type and length parameters. -=(defstruct Pair [a $t b $t])= cannot be spelled, and neither can a length -parameter. =Types.Named= is a bare string with no room for parameters; giving it -some changes the type, the layout calculator, both backends, the renderer and the -DWARF path. Same price for one as for both. Decided and unblocked, deliberately -not started — it is a language feature under a freeze, and it was stopped once -already for that reason. The motivating case is Odin's =Small_Array=: a -fixed-capacity array with a count and no allocation. +** DONE Generic types +CLOSED: [2026-09-25] +A struct's parameters are its fields' $-names in first-written order, a length by position; there is no +explicit parameter vector. Each application is an ordinary struct under a key, so no backend sees a parameter. ** WAIT A value predicate over a length parameter Decided 2026-09-25: waits until a program wants one. diff --git a/lib/ast.ml b/lib/ast.ml index bc5f0d67..b87d4abb 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -24,6 +24,9 @@ and texpr_kind = them identically — the difference is a fact about the value, and it is [Check.resolve] that turns it into one. *) | Tfn of bool * texpr list * texpr + (* An integer written as a generic struct's argument, the 8 in + (Small 8 i32). Parsed only there; it is not a type anywhere else. *) + | Tlen of int64 (* An array length is an integer or a compile-time constant's name. *) and len = diff --git a/lib/check.ml b/lib/check.ml index 0c03ca82..59e1ba1b 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -79,6 +79,44 @@ let rec slot_text = function | Sclass c -> c | Sopt s -> "(Option " ^ slot_text s ^ ")" +(* ── Generic structs ───────────────────────────────────────────────── + [(defstruct Small [items [$n $t] count i32])] is a template, not a type. + Its parameters are the sigil names its fields introduce, in the order + first written — [$n] then [$t] here, so the type is spelled + [(Small 8 i32)] — and each is a length or a type by where it stands: in an + array's length slot, or in a generic struct's length argument, it is a + length; anywhere else a type. + + Each application at concrete arguments is a copy: an ordinary struct under + a symbol-safe key, [Small-8-i32], so layout, both backends, the renderer + and DWARF see a struct and nothing else — the same arrangement a generic + function's copy has. [struct_apps] is how the checker still knows what a + copy was applied to, which is what binding [(defn push [s (Ptr (Small $n + $t))] ...)] against an argument needs. An application at variables is a + copy too, under a key with the variables in it, whose array lengths are + [abstract_len]; it exists for the abstract pass over a generic body and is + left out of the program. *) +type gstruct = { + gparams : (string * bool) list; (* name, and whether it is a length *) + gfields : Ast.field list; + gloc : Loc.t; +} + +(* Key -> the generic struct and the arguments it was applied to; a length + argument is [Types.Len], a variable one [Types.Var]. Global for the reason + [Types.display] is: [bind_ty] and [subst_ty] are called from places with no + env in hand. The key is made from exactly these, so an entry can only + mislead where a later program in the same process declares a struct under + a copy's key by hand, and [struct_copy] refuses that name the moment the + program asks for the copy itself. *) +let struct_apps : (string, string * Types.t list) Hashtbl.t = Hashtbl.create 16 + +(* The length every length variable has inside a generic body's abstract + pass. Large so that no constant index into such an array is refused as out + of bounds there, and within i32 so that [(length a)] is an ordinary index. + Every length is answered again, exactly, per copy. *) +let abstract_len = 2147483647L + type env = { structs : (string, Tast.structure) Hashtbl.t; datas : (string, Tast.data) Hashtbl.t; @@ -198,13 +236,32 @@ type env = { pass made would come back from the copy, at the same line, once per type it was called at. *) refused_generics : (string, unit) Hashtbl.t; + (* The generic structs, by name; see [gstruct]. *) + gstructs : (string, gstruct) Hashtbl.t; + (* The struct copies this env made, by key, and whether each is one at + variables — those are left out of the program. *) + copies : (string, bool) Hashtbl.t; + (* A generic defn's length variables, by name: the ones of its [gsigs] + variables that are lengths. *) + glens : (string, string list) Hashtbl.t; + (* Which of [tyvars] are lengths. A length variable is also a value inside + the body — [n] reads as the integer it was bound to. *) + mutable lenvars : string list; + (* Set while a generic body is checked abstractly, and while a struct copy + at variables is laid out: a length variable's array is then + [abstract_len] long rather than the [Types.LArray] a signature pattern + needs. *) + mutable len_placeholder : bool; + (* The struct copies being laid out, innermost last, so a template that + asks for a copy of itself at a bigger type is refused rather than + followed forever. *) + mutable schain : (string * Types.t list) list; (* Set while a struct, data-case or union field's type is being resolved, and only then. It exists for one message: an unknown lowercase name in a type slot is told to introduce a type variable with [$name] in the - parameter vector, and a field has no parameter vector — only a defn - signature binds, and a field is built at one type for every value. The - flag is what lets [resolve_name] say the honest thing in each place - instead of a suggestion that cannot be followed. *) + parameter vector, and a field has no parameter vector — a defstruct's + field introduces one where it stands. The flag is what lets + [resolve_name] say the honest thing in each place. *) mutable in_field : bool; (* Every [defclass], by name: its slots in constructor order, each with the type a value stored in it must have — [Types.Dyn] for a slot written @@ -247,6 +304,12 @@ let new_env () = { tvpreds = []; chain = []; refused_generics = Hashtbl.create 4; + gstructs = Hashtbl.create 4; + copies = Hashtbl.create 8; + glens = Hashtbl.create 8; + lenvars = []; + len_placeholder = false; + schain = []; in_field = false; classes = Hashtbl.create 8; tracks = Hashtbl.create 16; @@ -262,6 +325,13 @@ let new_env () = { the name is not one this environment placed, so it degrades to the message alone rather than to a wrong pointer. *) let declared_note env name = + (* A generic struct's copy is declared where its template is, and is + spoken of by the template's name there. *) + let shown = + match Hashtbl.find_opt struct_apps name with + | Some (g, _) when Hashtbl.mem env.copies name -> g + | _ -> name + in match Hashtbl.find_opt env.locs name with | None -> [] | Some at -> @@ -277,8 +347,8 @@ let declared_note env name = | None -> []) in let what = - if names = [] then name ^ " is declared here" - else name ^ " is declared here, with " ^ String.concat ", " names + if names = [] then shown ^ " is declared here" + else shown ^ " is declared here, with " ^ String.concat ", " names in [ Loc.note at what ] @@ -1202,6 +1272,119 @@ let rec unfillable env seen (t : Types.t) : Types.t option = | None -> Some t) | _ -> Some t +(* How a concrete type is spelled inside an instantiation's name. The prelude + already writes this by hand — [filter-i32], [sum-f32], [append-i64] — so a + generated name reads like the handwritten one it replaces, which is what a + backtrace, a [Reach] edge and a dev-build cell all end up showing. + [Types.to_string] cannot serve: [[i32]] and [(Vec i32)] are not symbols. *) +let rec mangle_ty (t : Types.t) = + match t with + | Types.Unit -> "unit" + | Types.Slice (Types.Mut, e) -> "slice-" ^ mangle_ty e + | Types.Slice (Types.Const, e) -> "cslice-" ^ mangle_ty e + | Types.Array (n, e) -> Printf.sprintf "arr%Ld-%s" n (mangle_ty e) + | Types.Map (k, v) -> Printf.sprintf "map-%s-%s" (mangle_ty k) (mangle_ty v) + | Types.Ptr (Types.Mut, e) -> "ptr-" ^ mangle_ty e + | Types.Ptr (Types.Const, e) -> "cptr-" ^ mangle_ty e + | Types.Vec e -> "vec-" ^ mangle_ty e + | Types.Option e -> "opt-" ^ mangle_ty e + | Types.Fn (ps, r) -> + Printf.sprintf "fn-%s-to-%s" + (String.concat "-" (List.map mangle_ty ps)) (mangle_ty r) + | Types.CFn (ps, r) -> + Printf.sprintf "cfn-%s-to-%s" + (String.concat "-" (List.map mangle_ty ps)) (mangle_ty r) + (* Bare, because [Types.to_string] spells a variable with its [$] for the + reader and a symbol has no room for one. *) + | Types.Var n -> n + (* The key, not [Types.to_string]'s [(Small 8 i32)], which is a reader's + spelling and not a symbol. *) + | Types.Named n -> n + | t -> Types.to_string t + +let rec occurs_in ~needle (t : Types.t) = + Types.equal needle t + || + match t with + | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e + | Types.Option e -> occurs_in ~needle e + | Types.Map (k, v) -> occurs_in ~needle k || occurs_in ~needle v + | Types.Fn (ps, r) | Types.CFn (ps, r) -> + List.exists (occurs_in ~needle) ps || occurs_in ~needle r + | Types.LArray (_, e) -> occurs_in ~needle e + (* Through a struct copy's arguments, or [(Node (Node $t))] would not be + seen to contain [(Node $t)]. *) + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (_, args) -> List.exists (occurs_in ~needle) args + | None -> false) + | _ -> false + +(* [b] is [a] with something built around it: same shape, strictly bigger. *) +let grows ~from_:a ~to_:b = + List.length a = List.length b + && List.for_all2 (fun x y -> occurs_in ~needle:x y) a b + && not (List.for_all2 Types.equal a b) + +(* A generic struct's copy at [args], by key: [Small-8-i32], or + [Small-$n-$t] at variables. Recorded in [struct_apps] and [Types.display] + as the key is made; the copy's fields are [struct_copy]'s business. *) +let struct_app g args = + let key = + g ^ "-" + ^ String.concat "-" + (List.map + (function + | Types.Var v -> "$" ^ v + | Types.Len n -> Int64.to_string n + | t -> mangle_ty t) + args) + in + if not (Hashtbl.mem struct_apps key) then begin + Hashtbl.replace struct_apps key (g, args); + Hashtbl.replace Types.display key + (Printf.sprintf "(%s %s)" g + (String.concat " " (List.map Types.to_string args))) + end; + key + +(* Does [name] contain itself by value? [check_finite] asks it of every + declared type once they are all collected, and a generic struct's copy asks + it of itself when it is made, which is after that. *) +let finite_from env name0 = + let rec walk seen name = + if List.mem name seen then + (let shown = Types.to_string (Types.Named name) in + fail (Option.value (Hashtbl.find_opt env.locs name) ~default:Loc.unknown) + "%s contains itself by value, so it has no size — go through (Ptr %s)" + shown shown); + let seen = name :: seen in + match Hashtbl.find_opt env.structs name with + | Some s -> List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) s.Tast.fields + | None -> + match Hashtbl.find_opt env.datas name with + | Some u -> + List.iter + (fun (c : Tast.variant) -> + List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) c.Tast.vfields) + u.Tast.cases + | None -> + (* A union whose member is itself is the same infinite type a struct's + is — the size is the largest member and the largest member is the + whole thing. Nothing about overlaying storage makes the recursion + finite, so it is on the same walk rather than left to hang the + layout calculator. *) + match Hashtbl.find_opt env.unions name with + | None -> () + | Some u -> + List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) u.Tast.fields + and ty seen = function + | Types.Named n -> walk seen n + | Types.Array (_, e) | Types.Option e -> ty seen e + | _ -> () + in + walk [] name0 + (* The name under the sigil. [$t] is how a defn signature introduces a type variable and [t] is how the body spells the same one, so the tables that record which variables are in scope — [env.tyvars] and [env.subst] — are @@ -1234,7 +1417,17 @@ let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t = | Ast.Tarray (l, e) -> let e = resolve env ~seen e in no_zeroed_fn loc "a fixed array's element" e; - Types.Array (array_len env loc l, e) + (match l with + | Ast.Lname n + when (not env.len_placeholder) + && List.mem (tyvar_bare n) env.lenvars + && not (List.mem_assoc (tyvar_bare n) env.subst) -> + Types.LArray (tyvar_bare n, e) + | _ -> Types.Array (array_len env loc l, e)) + | Ast.Tlen n -> + fail loc + "%Ld is not a type. An integer stands only where a generic struct takes \ + a length, as in (Small 8 i32)" n (* {K V} is the type spelling. There is no map *literal*: a bare map form in expression position is a struct literal's field list, and giving the same braces two meanings is what the colon-to-dot change was for. A map is @@ -1298,15 +1491,10 @@ let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t = (resolve env ~seen v) | "Map", _ -> fail loc "(Map K V) takes exactly two types" | "Result", _ -> unimplemented loc "(Result T E)" 6 + | _ when Hashtbl.mem env.gstructs name -> apply_struct env ~seen loc name args | _ -> - (* Not generics, which are here: a *function* is generic over [$t] and - instantiated per call site. This is a parameterised named type — - [(Pair i32 f64)] — and that is a different thing and is not built. - [Types.Named] is a bare string with no parameters, so there is - nowhere to put the arguments, and giving it some is a change to - [Types.t] and therefore to the layout calculator, both backends, - [Render] and the DWARF path. docs/SPIKE-GENERICS.md, question 4, - prices it and leaves it out. *) + (* No type of this name takes arguments: a generic struct is caught + by the arm above, and [Ptr], [Option], [Vec] and [Map] further up. *) (* A head that is not a type at all but one edit from one is the typo [(Vect i32)], and the generics sentence would answer a question nobody asked. *) @@ -1323,9 +1511,154 @@ let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t = "unknown type %s — did you mean %s?" name m | _ -> ()); fail loc - "%s takes no type arguments. A generic function is written with $t \ - in its parameter vector; a generic type is not there yet" - name) + "%s takes no type arguments. A generic struct is one whose fields \ + introduce $t, as in (defstruct %s [x $t]), and a generic function \ + one whose parameter vector does" + name name) + +(* [(Small 8 i32)]: each argument read as the parameter it stands for — a + length or a type — and the copy made, or found. *) +and apply_struct env ~seen loc name args = + let g = Hashtbl.find env.gstructs name in + let spelled = + Printf.sprintf "(%s %s)" name + (String.concat " " (List.map (fun (p, _) -> "$" ^ p) g.gparams)) + in + let n = List.length g.gparams in + if List.length args <> n then + Loc.failk "check/generic-struct-arity" loc + ~notes:[ Loc.note g.gloc (name ^ " is declared here") ] + "%s takes %d argument%s, %s, and this gives %d" + name n (if n = 1 then "" else "s") spelled (List.length args); + let targs = + List.map2 + (fun (p, is_len) (a : Ast.texpr) -> + if is_len then struct_len_arg env name p a + else + match a.Ast.t with + | Ast.Tlen k -> + fail a.Ast.tloc + "%s's $%s is a type, and %Ld is a length — %s" name p k spelled + | _ -> resolve env ~seen a) + g.gparams args + in + Types.Named (struct_copy env loc name targs) + +and struct_len_arg env name p (a : Ast.texpr) = + let not_one what = + fail a.Ast.tloc + "%s's $%s is a length: an integer, a constant's name or a length \ + variable, and %s is %s" name p (Cimport.ty_source a) what + in + match a.Ast.t with + | Ast.Tlen k when Int64.compare k 0L < 0 -> + fail a.Ast.tloc "%s's $%s is a length, and %Ld is negative" name p k + | Ast.Tlen k -> Types.Len k + | Ast.Tname n -> + let bare = tyvar_bare n in + (match List.assoc_opt bare env.subst with + | Some (Types.Len _ as l) -> l + | Some (Types.Var v) -> Types.Var v + | Some t -> not_one ("the type " ^ Types.to_string t) + | None -> + if List.mem bare env.lenvars then Types.Var bare + else if List.mem bare env.tyvars then not_one "a type variable" + else + match Hashtbl.find_opt env.consts n with + | Some k -> Types.Len k + | None -> not_one "none of them") + | _ -> not_one "a type" + +(* The copy of generic struct [name] at [targs], made on first use and + registered as an ordinary struct under its key. *) +and struct_copy env loc name targs = + let key = struct_app name targs in + if Hashtbl.mem env.copies key then key + else begin + if Hashtbl.mem env.structs key || Hashtbl.mem env.datas key + || Hashtbl.mem env.unions key then + fail loc + "%s at these arguments is called %s, and %s is already defined — \ + rename one" name key key; + let g = Hashtbl.find env.gstructs name in + (* A copy that asks for a copy of its own template at a type built around + its own arguments — [(defstruct Grow [next (Ptr (Grow [$t]))])] — asks + forever, and pointers do not stop it: each copy is made the moment it + is named. *) + let chain_text () = + String.concat "\n " + (List.map + (fun (h, a) -> + Printf.sprintf "(%s %s)" h + (String.concat " " (List.map Types.to_string a))) + (env.schain @ [ (name, targs) ])) + in + if List.exists + (fun (h, a) -> String.equal h name && grows ~from_:a ~to_:targs) + env.schain + || List.length env.schain >= 64 then + Loc.failk "check/runaway-instantiation" loc + ~notes:[ Loc.note g.gloc (name ^ " is declared here") ] + "%s names a copy of itself at a type built around its own \ + arguments, and that copy names another, without end:\n %s\n\ + Name the same arguments, or smaller ones" name (chain_text ()); + let generic = List.exists generic_arg targs in + (* In before its fields, so a field that names the same copy through a + pointer — [(defstruct Node [next (Ptr (Node $t))])] — finds it. *) + Hashtbl.replace env.copies key generic; + Hashtbl.replace env.structs key { Tast.sname = key; fields = [] }; + Hashtbl.replace env.locs key g.gloc; + let saved = + (env.subst, env.tyvars, env.lenvars, env.tvpreds, env.len_placeholder, + env.in_field, env.schain) + in + let restore () = + let s, t, l, p, lp, f, c = saved in + env.subst <- s; env.tyvars <- t; env.lenvars <- l; env.tvpreds <- p; + env.len_placeholder <- lp; env.in_field <- f; env.schain <- c + in + env.subst <- List.map2 (fun (p, _) a -> (p, a)) g.gparams targs; + env.tyvars <- []; + env.lenvars <- []; + env.tvpreds <- []; + env.len_placeholder <- generic; + env.in_field <- true; + env.schain <- env.schain @ [ (name, targs) ]; + match + List.map + (fun (f : Ast.field) -> + let fty = resolve env f.Ast.fty in + no_zeroed_fn f.Ast.fty.Ast.tloc + (Printf.sprintf "the field %s" f.Ast.fname) fty; + { Tast.fname = f.Ast.fname; fty }) + g.gfields + with + | fields -> + restore (); + Hashtbl.replace env.structs key { Tast.sname = key; fields }; + finite_from env key; + key + | exception e -> + restore (); + Hashtbl.remove env.copies key; + Hashtbl.remove env.structs key; + raise e + end + +(* Does a struct argument still mention a variable? *) +and generic_arg (t : Types.t) = + match t with + | Types.Var _ | Types.LArray _ -> true + | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e + | Types.Option e -> generic_arg e + | Types.Map (k, v) -> generic_arg k || generic_arg v + | Types.Fn (ps, r) | Types.CFn (ps, r) -> + List.exists generic_arg ps || generic_arg r + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (_, a) -> List.exists generic_arg a + | None -> false) + | _ -> false (* One edit away from a type that exists — a substitution, an insertion, a deletion or a transposition of neighbours. Bounded at one, because two edits @@ -1359,12 +1692,19 @@ and resolve_name env ~seen loc n = one, a mistyped type name silently became a type parameter and made the function more permissive than it was written to be. *) let bare = tyvar_bare n in + let a_length () = + fail loc + "%s is a length, not a type — it stands where an array's length does, \ + as in [%s T], or as a generic struct's length argument" n n + in match List.assoc_opt bare env.subst with + | Some (Types.Len _) -> a_length () (* Inside an instantiation: the variable is this concrete type, and every node checked under it is as concrete as if it had been written out. *) | Some t -> t | None -> - if List.mem bare env.tyvars then Types.Var bare + if List.mem bare env.lenvars then a_length () + else if List.mem bare env.tyvars then Types.Var bare else if n <> bare then (* A sigil on a name nothing binds. Two different mistakes wear the same spelling, and which one it is turns on whether any variable is in scope @@ -1383,8 +1723,8 @@ and resolve_name env ~seen loc n = (match (match env.tyvars with [] -> List.map fst env.subst | vs -> vs) with | [] -> Loc.failk "check/unbound-type-variable" loc - "%s introduces a type variable, and only a defn signature can — write \ - the concrete type here" n + "%s introduces a type variable, and only a defn signature or a \ + defstruct's fields can — write the concrete type here" n | [ v ] -> Loc.failk "check/unbound-type-variable" loc "nothing binds the type variable %s — this signature introduces %s, \ @@ -1423,6 +1763,13 @@ and resolve_name env ~seen loc n = if List.mem n seen then fail loc "the type alias %s is defined in terms of itself" n else resolve env ~seen:(n :: seen) (Hashtbl.find env.aliases n) + | _ when Hashtbl.mem env.gstructs n -> + let g = Hashtbl.find env.gstructs n in + Loc.failk "check/generic-struct-arity" loc + ~notes:[ Loc.note g.gloc (n ^ " is declared here") ] + "%s is generic, and a type only once it is given its arguments: \ + write (%s %s)" n n + (String.concat " " (List.map (fun (p, _) -> "$" ^ p) g.gparams)) | _ when Hashtbl.mem env.structs n -> Types.Named n (* A data type is [Named] exactly as a struct is: one case in [Types.t] covers both, and which table the name is in is what tells them apart. @@ -1460,18 +1807,16 @@ and resolve_name env ~seen loc n = permissive than it was written to be. *) | _ when n <> "" && n.[0] = Char.lowercase_ascii n.[0] -> (* The parameter-vector suggestion is only followable where a - parameter vector exists. A field has none and never will — only a - defn signature binds a variable, and a field is built at one type - for every value — so at a field the message offers the two things - that can actually be written there. *) + parameter vector exists. A field has none: a defstruct's field + introduces the variable where it stands, so at a field the message + says that instead. *) if env.in_field then Loc.failk "check/unknown-type" loc - "unknown type %s. A lowercase name is a type variable, and a \ - field cannot hold one: only a defn signature introduces type \ - variables, and a field is built at one type for every value — \ - generic types are not there. Write a concrete type here, or dyn \ - to hold any value" - n + "unknown type %s. A lowercase name is a type variable only where \ + it is introduced with $%s, and in a defstruct's fields that makes \ + the struct generic over it. Write $%s, a concrete type, or dyn to \ + hold any value" + n n n else Loc.failk "check/unknown-type" loc "unknown type %s. A lowercase name is a type variable only where a \ @@ -1483,7 +1828,19 @@ and resolve_name env ~seen loc n = and array_len env loc = function | Ast.Lint n -> n | Ast.Lname n -> - (match Hashtbl.find_opt env.consts n with + let bare = tyvar_bare n in + (match List.assoc_opt bare env.subst with + | Some (Types.Len k) -> k + | Some (Types.Var _) -> abstract_len + | Some t -> + fail loc "%s is the type %s here, and an array length is an integer, a \ + constant or a length variable" n (Types.to_string t) + | None when List.mem bare env.lenvars -> abstract_len + | None when List.mem bare env.tyvars -> + fail loc "%s is a type variable, and an array length is an integer, a \ + constant or a length variable" n + | None -> + match Hashtbl.find_opt env.consts n with | Some v -> v | None -> fail loc "%s is not a compile-time integer constant, so it cannot be \ @@ -1514,6 +1871,7 @@ let is_type_name env n = || List.mem n [ "bool"; "string"; "dyn"; "Unit"; "Never"; "Allocator" ] || Hashtbl.mem env.aliases n || Hashtbl.mem env.structs n + || Hashtbl.mem env.gstructs n || Hashtbl.mem env.datas n || Hashtbl.mem env.unions n || Hashtbl.mem env.enums n @@ -1828,6 +2186,7 @@ let defvar_reads_as_type env (t : Ast.texpr) = | Ast.Tname n -> is_type_name env n | Ast.Tapp (head, _) -> List.mem head [ "Ptr"; "Option"; "Vec"; "Map"; "Result" ] + || Hashtbl.mem env.gstructs head (* A slice, a fixed array, a map type or an (Fn ...): [Parse] only carries one of these over when it read as a type and had no value reading, so there is nothing here to decide. *) @@ -2004,9 +2363,9 @@ let settle_defvars env (decls : Ast.decl list) : Ast.decl list = (* The variables a signature introduces: every [$t] written in it, in the order written, once each. Only a [defn] signature is scanned, which is what makes the binding site a *place* and not merely a spelling. *) -let signature_tyvars (fn : Ast.fn) = +let sigil_vars ~kinds_of (ts : Ast.texpr list) = let acc = ref [] in - let name loc n = + let add loc n is_len = if n <> "" && n.[0] = '$' then begin let bare = String.sub n 1 (String.length n - 1) in if bare = "" then fail loc "$ on its own does not name a type variable"; @@ -2016,24 +2375,59 @@ let signature_tyvars (fn : Ast.fn) = || Types.ikind_of_name bare <> None || Types.fkind_of_name bare <> None then fail loc "%s is a type, so $%s cannot be a type variable" bare bare; - if not (List.mem bare !acc) then acc := bare :: !acc + match List.assoc_opt bare !acc with + | None -> acc := (bare, is_len) :: !acc + | Some k when k = is_len -> () + | Some _ -> + fail loc + "$%s stands for a length in one place here and a type in another — \ + a length goes in an array's length slot, [$%s T], and a type \ + everywhere else. Give the two different names" bare bare end in let rec ty (t : Ast.texpr) = match t.Ast.t with - | Ast.Tname n -> name t.Ast.tloc n + | Ast.Tname n -> add t.Ast.tloc n false | Ast.Tslice (_, e) -> ty e + | Ast.Tarray (Ast.Lname n, e) -> add t.Ast.tloc n true; ty e | Ast.Tarray (_, e) -> ty e | Ast.Tmap (k, v) -> ty k; ty v - (* The head of an application is a constructor — [Ptr], [Option], [Vec] — - and a variable cannot stand there: this spike is generic over types, - not over type constructors. A [$t] inside the arguments is ordinary. *) - | Ast.Tapp (_, args) -> List.iter ty args + (* The head of an application is a constructor — [Ptr], [Option], [Vec], + a generic struct — and a variable cannot stand there: this is generic + over types, not over type constructors. A [$t] inside the arguments is + ordinary, and a generic struct's length argument is a length. *) + | Ast.Tapp (h, args) -> + (match kinds_of h with + | Some ks when List.length ks = List.length args -> + List.iter2 + (fun is_len (a : Ast.texpr) -> + match a.Ast.t with + | Ast.Tname n when is_len -> add a.Ast.tloc n true + | _ -> ty a) + ks args + | _ -> List.iter ty args) | Ast.Tfn (_, ps, r) -> List.iter ty ps; ty r + | Ast.Tlen _ -> () in - List.iter (fun (p : Ast.field) -> ty p.Ast.fty) fn.Ast.params; - (match fn.Ast.ret with Some r -> ty r | None -> ()); - List.rev !acc + List.iter ty ts; + let vs = List.rev !acc in + (List.map fst vs, List.filter_map (fun (v, l) -> if l then Some v else None) vs, + vs) + +let struct_kinds env h = + Option.map (fun g -> List.map snd g.gparams) (Hashtbl.find_opt env.gstructs h) + +(* The variables a signature introduces: every [$t] written in it, in the + order written, once each, and which of them are lengths. Only a [defn] + signature and a [defstruct]'s fields are scanned, which is what makes the + binding site a *place* and not merely a spelling. *) +let signature_tyvars env (fn : Ast.fn) = + let vars, lens, _ = + sigil_vars ~kinds_of:(struct_kinds env) + (List.map (fun (p : Ast.field) -> p.Ast.fty) fn.Ast.params + @ Option.to_list fn.Ast.ret) + in + vars, lens (* Bind the variables in a parameter's written type from the type an argument turned out to have. Odin's [is_polymorphic_type_assignable], structurally @@ -2102,6 +2496,17 @@ let rec bind_ty ?(widen = false) ?(ro = true) subst (pat : Types.t) | Types.Fn (ps, r), Types.CFn (ps', r') when widen -> List.length ps = List.length ps' && List.for_all2 inner ps ps' && inner r r' + (* A length variable's array against a concrete one: the length is bound + the way a type variable is, to a [Types.Len]. *) + | Types.LArray (v, p), Types.Array (n, a) -> + bind_ty ~ro:false subst (Types.Var v) (Types.Len n) && inner p a + (* A struct copy at variables against a copy of the same template: each + argument against its own. *) + | Types.Named p, Types.Named a when not (String.equal p a) -> + (match Hashtbl.find_opt struct_apps p, Hashtbl.find_opt struct_apps a with + | Some (g, ps), Some (h, as_) when String.equal g h -> + List.length ps = List.length as_ && List.for_all2 inner ps as_ + | _ -> false) (* Nothing generic left on the pattern side: this is ordinary type equality, and [Never] fits anywhere exactly as it does elsewhere. *) | p, a -> Types.fits ~expected:p ~actual:a @@ -2118,12 +2523,29 @@ let rec subst_ty subst (t : Types.t) = | Types.Fn (ps, r) -> Types.Fn (List.map (subst_ty subst) ps, subst_ty subst r) | Types.CFn (ps, r) -> Types.CFn (List.map (subst_ty subst) ps, subst_ty subst r) + | Types.LArray (v, e) -> + (match List.assoc_opt v subst with + | Some (Types.Len n) -> Types.Array (n, subst_ty subst e) + | Some (Types.Var w) -> Types.LArray (w, subst_ty subst e) + | _ -> Types.LArray (v, subst_ty subst e)) + (* A struct copy at variables becomes the copy at what they are bound to. + Only its key is made here — there is no env to lay it out in — and + [realise] makes the copy itself before anything reads its fields. *) + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (g, args) when List.exists open_ty args -> + let args = List.map (subst_ty subst) args in + Types.Named (struct_app g args) + | _ -> t) | t -> t -(* Does this resolved type still mention a variable? *) -let rec generic_ty (t : Types.t) = +(* Does this resolved type still mention a variable? Not through a struct + copy's arguments: an operator over a [(Pair $t)] is refused as one over a + struct, not as one over a type variable. [open_ty] is the question that + does look through, for binding and substituting. *) +and generic_ty (t : Types.t) = match t with - | Types.Var _ -> true + | Types.Var _ | Types.LArray _ -> true | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e | Types.Option e -> generic_ty e | Types.Map (k, v) -> generic_ty k || generic_ty v @@ -2131,6 +2553,37 @@ let rec generic_ty (t : Types.t) = List.exists generic_ty ps || generic_ty r | _ -> false +and open_ty (t : Types.t) = + match t with + | Types.Var _ | Types.LArray _ -> true + | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e + | Types.Option e -> open_ty e + | Types.Map (k, v) -> open_ty k || open_ty v + | Types.Fn (ps, r) | Types.CFn (ps, r) -> List.exists open_ty ps || open_ty r + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (_, args) -> List.exists open_ty args + | None -> false) + | _ -> false + +(* Make every struct copy [t] names that [subst_ty] only named. A copy has + to exist in [env.structs] before a field of it is read, and [subst_ty] has + no env to make one in. *) +let rec realise env loc (t : Types.t) = + match t with + | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e + | Types.Option e | Types.LArray (_, e) -> realise env loc e + | Types.Map (k, v) -> realise env loc k; realise env loc v + | Types.Fn (ps, r) | Types.CFn (ps, r) -> + List.iter (realise env loc) ps; realise env loc r + | Types.Named k when not (Hashtbl.mem env.structs k) -> + (match Hashtbl.find_opt struct_apps k with + | Some (g, args) when Hashtbl.mem env.gstructs g -> + List.iter (realise env loc) args; + ignore (struct_copy env loc g args) + | _ -> ()) + | _ -> () + (* Does a type a call site bound a variable to reach a [dyn] anywhere? See the refusal in [generic_call]: [dyn] is a concrete type and substitutes like any other, so nothing stopped a copy being made at it, and the copies walked @@ -2170,33 +2623,6 @@ let unconstrained env loc op ~needs (t : Types.t) = (Types.to_string t) (Types.to_string t) (Types.to_string t) -(* How a concrete type is spelled inside an instantiation's name. The prelude - already writes this by hand — [filter-i32], [sum-f32], [append-i64] — so a - generated name reads like the handwritten one it replaces, which is what a - backtrace, a [Reach] edge and a dev-build cell all end up showing. - [Types.to_string] cannot serve: [[i32]] and [(Vec i32)] are not symbols. *) -let rec mangle_ty (t : Types.t) = - match t with - | Types.Unit -> "unit" - | Types.Slice (Types.Mut, e) -> "slice-" ^ mangle_ty e - | Types.Slice (Types.Const, e) -> "cslice-" ^ mangle_ty e - | Types.Array (n, e) -> Printf.sprintf "arr%Ld-%s" n (mangle_ty e) - | Types.Map (k, v) -> Printf.sprintf "map-%s-%s" (mangle_ty k) (mangle_ty v) - | Types.Ptr (Types.Mut, e) -> "ptr-" ^ mangle_ty e - | Types.Ptr (Types.Const, e) -> "cptr-" ^ mangle_ty e - | Types.Vec e -> "vec-" ^ mangle_ty e - | Types.Option e -> "opt-" ^ mangle_ty e - | Types.Fn (ps, r) -> - Printf.sprintf "fn-%s-to-%s" - (String.concat "-" (List.map mangle_ty ps)) (mangle_ty r) - | Types.CFn (ps, r) -> - Printf.sprintf "cfn-%s-to-%s" - (String.concat "-" (List.map mangle_ty ps)) (mangle_ty r) - (* Bare, because [Types.to_string] spells a variable with its [$] for the - reader and a symbol has no room for one. *) - | Types.Var n -> n - | t -> Types.to_string t - (* ── The runaway instantiation, refused by name rather than by depth ──── [(defn grow [x $t] () (grow [x x]))] asks for a copy at [[t]], which asks for one at [[[t]]], forever. Before this the checker did not fail, it @@ -2223,23 +2649,6 @@ let rec mangle_ty (t : Types.t) = is the whole design. The depth backstop below stays as a backstop only: it catches a growth this test does not recognise, and it is never the thing the message is about. *) -let rec occurs_in ~needle (t : Types.t) = - Types.equal needle t - || - match t with - | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e - | Types.Option e -> occurs_in ~needle e - | Types.Map (k, v) -> occurs_in ~needle k || occurs_in ~needle v - | Types.Fn (ps, r) | Types.CFn (ps, r) -> - List.exists (occurs_in ~needle) ps || occurs_in ~needle r - | _ -> false - -(* [b] is [a] with something built around it: same shape, strictly bigger. *) -let grows ~from_:a ~to_:b = - List.length a = List.length b - && List.for_all2 (fun x y -> occurs_in ~needle:x y) a b - && not (List.for_all2 Types.equal a b) - let runaway env loc gname cparams = let chain_text () = String.concat "\n " @@ -3042,7 +3451,8 @@ let box loc (e : Tast.expr) : Tast.expr = caller that starts doing that gets a sentence instead of a silent mis-lowering. *) | Types.Named _ | Types.Enum _ | Types.Option _ | Types.Ptr _ - | Types.Alloc | Types.Fn _ | Types.CFn _ | Types.Var _ -> + | Types.Alloc | Types.Fn _ | Types.CFn _ | Types.Var _ | Types.Len _ + | Types.LArray _ -> no_dyn_yet loc ~into:true e.Tast.ty "" let unbox loc (want : Types.t) (e : Tast.expr) : Tast.expr = @@ -4260,6 +4670,23 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = (mk loc Types.Dyn (Tast.Let ([ (m, empty) ], sets @ [ mval ]))) | Ast.Quote _ -> unimplemented loc "a quoted symbol (restart names)" 6 + (* A length variable read as a value is the integer it was bound to, as a + literal — so it takes its width from where it stands, the way a written + 8 would. In the abstract pass it is a 1: a literal that fits every + integer type, since the real one is answered again per copy. A local of + the same name shadows it. *) + | Ast.Var name + when (not (List.mem_assoc name ctx.scope)) + && (List.mem name ctx.env.lenvars + || (match List.assoc_opt name ctx.env.subst with + | Some (Types.Len _) -> true + | _ -> false)) -> + let n = + match List.assoc_opt name ctx.env.subst with + | Some (Types.Len n) -> n + | _ -> 1L + in + check ctx ?want { e with Ast.e = Ast.Int n } | Ast.Var name -> var ctx loc ~want name | Ast.Do body -> ctx.tail <- tail; block ctx ?want loc body (* [defer_ok] rides through: a [let] at the top level of a function body has @@ -4400,7 +4827,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = (match Tast.field_index s name with | None -> Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname) - "%s has no field %s" sname name + "%s has no field %s" (Types.to_string (Types.Named sname)) name | Some i -> let fty = (List.nth s.Tast.fields i).Tast.fty in expect ctx loc ~want (mk loc fty (Tast.Field (target, i)))) @@ -6022,6 +6449,101 @@ and callable ctx name = | Some b -> (match b.bty with Types.Fn _ -> true | _ -> false) | None -> false) +(* [(Pair 1 2)] and [(Pair {.a 1 .b 2})]: which copy of a generic struct a + value builds. The position says, when a copy of this struct is wanted + there; otherwise the fields do, each given one's type binding the + template's variables the way a generic call's arguments bind its own. The + fields are only probed here — each check is abandoned — and the ordinary + constructor checks them again against the copy it is handed. *) +and generic_ctor ctx ~want loc name given = + let env = ctx.env in + let g = Hashtbl.find env.gstructs name in + match want with + | Some (Types.Named k) + when (match Hashtbl.find_opt struct_apps k with + | Some (h, _) -> String.equal h name + | None -> false) -> + realise env loc (Types.Named k); k + | _ -> + let open_key = + struct_copy env loc name (List.map (fun (p, _) -> Types.Var p) g.gparams) + in + let fields = (Hashtbl.find env.structs open_key).Tast.fields in + let pairs = + match given with + | `Positional args when List.length args = List.length fields -> + List.combine fields args + (* The wrong number of fields: the copy at variables is handed on, and + the constructor says what is wrong with the count in its own words. *) + | `Positional _ -> [] + | `Named kvs -> + List.filter_map + (fun (f, v) -> + List.find_opt + (fun (fl : Tast.field) -> String.equal fl.Tast.fname f) fields + |> Option.map (fun fl -> (fl, v))) + kvs + in + let subst = ref [] and unsure = ref [] in + (* An untyped literal has no type of its own to bring, so the fields that + do have one bind first: [(Node 2 (addr c))] over a [(Node i64)] [c] is + a [(Node i64)], and the 2 takes its width from that. *) + let literal (a : Ast.expr) = + match a.Ast.e with + | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ -> true + | _ -> false + in + let pairs = + List.filter (fun (_, a) -> not (literal a)) pairs + @ List.filter (fun (_, a) -> literal a) pairs + in + List.iter + (fun ((f : Tast.field), (a : Ast.expr)) -> + if open_ty f.Tast.fty + && not (literal a && subst_ty !subst f.Tast.fty |> open_ty |> not) + then begin + let seen = ref None in + let probe () = + seen := Some (check ctx a).Tast.ty; + Loc.fail a.Ast.loc "probe" + in + let refusal = match trial ctx probe with Error d -> Some d | Ok _ -> None in + match !seen with + (* No type of its own — [None], a bare {.field v} — is no + evidence; the constructor checks it against the copy the other + fields decide, and its refusal is the one given if they decide + nothing. *) + | None -> Option.iter (fun d -> unsure := d :: !unsure) refusal + | Some t -> + if not (bind_ty subst f.Tast.fty t) then + fail a.Ast.loc "%s's .%s is %s here, and this is %s" + (Types.to_string (Types.Named open_key)) f.Tast.fname + (Types.to_string (subst_ty !subst f.Tast.fty)) + (Types.to_string t) + end) + pairs; + (match given with + | `Positional args when List.length args <> List.length fields -> open_key + | _ -> + let targs = + List.map + (fun (p, _) -> + match List.assoc_opt p !subst with + | Some t -> t + | None -> + (match List.rev !unsure with + | d :: _ -> Loc.raise_diag d + | [] -> ()); + Loc.failk "check/generic-struct-undetermined" loc + ~notes:[ Loc.note g.gloc (name ^ " is declared here") ] + "%s's $%s is not decided by the fields given here. Name the \ + type where the value goes, as in (the (%s %s) ...)" + name p name + (String.concat " " (List.map (fun (q, _) -> "$" ^ q) g.gparams))) + g.gparams + in + struct_copy env loc name targs) + (* [(Cell 1 2)] — a struct built from its fields in declaration order. The parser cannot make this one either, and for a sharper reason than the @@ -6051,6 +6573,14 @@ and positional_struct ctx ~want loc name args = let n = List.length fields in let given = List.length args in let note = declared_note ctx.env name in + (* The constructor is written with the template's name for a generic + struct's copy, and the copy is spoken of as [(Pair i32)]. *) + let ctor = + match Hashtbl.find_opt struct_apps name with + | Some (g, _) when Hashtbl.mem ctx.env.copies name -> g + | _ -> name + in + let shown = Types.to_string (Types.Named name) in if given < n then begin let missing = List.nth fields given in Loc.failk "check/positional-too-few" loc ~notes:note @@ -6058,15 +6588,15 @@ and positional_struct ctx ~want loc name args = Positional construction gives every field, in declaration order; to \ give some of them and zero the rest, a struct value is written (%s \ {.field value ...})" - name n (if n = 1 then "" else "s") given - (if given = 1 then "was" else "were") missing.Tast.fname name + shown n (if n = 1 then "" else "s") given + (if given = 1 then "was" else "were") missing.Tast.fname ctor end; if given > n then begin let extra = List.nth args n in Loc.failk "check/positional-too-many" extra.Ast.loc ~notes:note "%s has %d field%s, and this is argument %d — a struct value is written \ (%s {.field value ...}) or (%s %s)" - name n (if n = 1 then "" else "s") (n + 1) name name + shown n (if n = 1 then "" else "s") (n + 1) ctor ctor (String.concat " " (List.map (fun (f : Tast.field) -> f.Tast.fname) fields)) end; (* Left to right, each against its own field's type, exactly as the argument @@ -6089,7 +6619,7 @@ and positional_struct ctx ~want loc name args = Loc.notes = d.Loc.notes @ [ Loc.note a.Ast.loc - (Printf.sprintf "this is %s's field .%s" name + (Printf.sprintf "this is %s's field .%s" shown f.Tast.fname) ] @ note }) fields args @@ -6149,6 +6679,9 @@ and check_bare ctx ~want loc kvs = what lets the decision be made against the tables, exactly. *) and check_struct ctx ~want loc name kvs = match Hashtbl.find_opt ctx.env.structs name with + | None when Hashtbl.mem ctx.env.gstructs name -> + check_struct ctx ~want loc + (generic_ctor ctx ~want loc name (`Named kvs)) kvs | None when Hashtbl.mem ctx.env.unions name -> check_union ctx ~want loc name kvs | None -> @@ -6224,7 +6757,7 @@ and check_struct ctx ~want loc name kvs = if Tast.field_index s k = None then Loc.failk "check/unknown-field" v.Ast.loc ~notes:(declared_note ctx.env name) - "%s has no field %s" name k) + "%s has no field %s" (Types.to_string (Types.Named name)) k) in let fields = zii_fill ctx loc seen s.Tast.fields in expect ctx loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields))) @@ -7399,7 +7932,7 @@ and check_place ?(store = true) ctx loc (p : Ast.place) : Tast.place * Types.t = (match Tast.field_index s name with | None -> Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname) - "%s has no field %s" sname name + "%s has no field %s" (Types.to_string (Types.Named sname)) name | Some i -> if store then Option.iter (refuse_const_place ctx.env loc) (const_reached target); Tast.Pfield (target, i), (List.nth s.Tast.fields i).Tast.fty) @@ -7993,7 +8526,7 @@ and file_guard ctx loc ~path_slot ~op mk_steps = (* An argument written as a type: a type expression, or a bare name that is a type and not a local or a global of the same spelling. *) and type_arg ctx (a : Ast.expr) = - type_of_expr a <> None + type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a <> None || (match a.Ast.e with | Ast.Var n -> lookup ctx n = None && (not (Hashtbl.mem ctx.env.globals n)) @@ -8027,8 +8560,11 @@ and type_named ctx n = and vec_new_elem ctx ~want loc args = let named = match args with - | a :: rest when type_of_expr a <> None -> - Some (resolve ctx.env (Option.get (type_of_expr a)), rest) + | a :: rest when type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a <> None -> + Some + (resolve ctx.env + (Option.get (type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a)), + rest) | { Ast.e = Ast.Var n; _ } :: rest when lookup ctx n = None && (not (Hashtbl.mem ctx.env.globals n)) @@ -8051,12 +8587,12 @@ and vec_new_elem ctx ~want loc args = brackets — an allocator is never an array — or a parenthesised Ptr, Option, Vec, Map, Fn or CFn. A bare name is not one of them, because there it may be an allocator's name; the callers ask about that themselves. *) -and type_of_expr (e : Ast.expr) : Ast.texpr option = +and type_of_expr ?(generic = fun _ -> false) (e : Ast.expr) : Ast.texpr option = let mk t = { Ast.t; tloc = e.Ast.loc } in let inner (e : Ast.expr) = match e.Ast.e with | Ast.Var s -> Some { Ast.t = Ast.Tname s; tloc = e.Ast.loc } - | _ -> type_of_expr e + | _ -> type_of_expr ~generic e in let all es = let ts = List.filter_map inner es in @@ -8080,6 +8616,18 @@ and type_of_expr (e : Ast.expr) : Ast.texpr option = | Ast.Call ({ Ast.e = Ast.Var (("Ptr" | "Option" | "Vec" | "Map") as c); _ }, (_ :: _ as args)) -> Option.map (fun ts -> mk (Ast.Tapp (c, ts))) (all args) + (* A generic struct applied to its arguments, [(vec-new (Small 8 i32))]: + the caller says which heads are ones, since only the env knows. An + integer argument is a length. *) + | Ast.Call ({ Ast.e = Ast.Var c; _ }, (_ :: _ as args)) when generic c -> + let arg (a : Ast.expr) = + match a.Ast.e with + | Ast.Int n -> Some { Ast.t = Ast.Tlen n; tloc = a.Ast.loc } + | _ -> inner a + in + let ts = List.filter_map arg args in + if List.length ts = List.length args then Some (mk (Ast.Tapp (c, ts))) + else None | _ -> None (* The key and value types, or the reason this is not a Map. *) @@ -8102,7 +8650,7 @@ and map_new_types ctx ~want loc args = (* A type position holds a bare name or a type expression Parse has read as one, as [vec-new]'s does. *) let as_type (a : Ast.expr) = - match a.Ast.e, type_of_expr a with + match a.Ast.e, type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a with | _, Some t -> Some (resolve ctx.env t) | Ast.Var n, None when is_type n -> Some (resolve_name ctx.env ~seen:[] loc n) | _ -> None @@ -8110,7 +8658,7 @@ and map_new_types ctx ~want loc args = match args with | k :: v :: rest when as_type k <> None && as_type v <> None -> Option.get (as_type k), Option.get (as_type v), rest - | a :: _ when type_of_expr a <> None -> + | a :: _ when type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a <> None -> fail loc "(map-new) names a key and no value — write both, as (map-new string \ i32)" @@ -8596,7 +9144,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = fail (List.hd args).Ast.loc "%s takes a type, as in (%s i32)" name name; let a = List.hd args in let ty = - match type_of_expr a, a.Ast.e with + match type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a, a.Ast.e with | Some t, _ -> resolve ctx.env t | _, Ast.Var n -> resolve_name ctx.env ~seen:[] a.Ast.loc n | _ -> fail a.Ast.loc "internal: %s's type argument is not a type" name @@ -10266,7 +10814,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = checked with [t] concrete. One generic argument defers the whole call: the printers for its neighbours would be re-selected at instantiation anyway, so building them here would be work thrown away twice. *) - if List.exists (fun a -> generic_ty a.Tast.ty) checked then + if List.exists (fun a -> open_ty a.Tast.ty) checked then mk loc Types.Unit Tast.Unit else let bslice = Types.Slice (Types.Mut, (Types.Int Types.U8)) in @@ -10295,7 +10843,20 @@ and named_call ?(qualified = false) ctx ~want loc name args = match a.Tast.ty with | Types.String | Types.Slice (_, (Types.Int Types.U8)) -> [ write (mk loc bslice (Tast.Prim (Tast.Bytes, [ a ]))) ] - | _ -> Render.render rc 0 a + (* The walk names the value once per piece it reads — an option's tag + and then its payload, each field of a struct — so anything but a + plain variable is bound to a slot first, or [(println (pop! s))] + pops once per piece. *) + | _ -> + (match a.Tast.e with + | Tast.Local _ | Tast.Global _ -> Render.render rc 0 a + | _ -> + let s = fresh_slot ctx a.Tast.ty in + [ mk loc Types.Unit + (Tast.Let + ([ (s, a) ], + Render.render rc 0 (mk a.Tast.loc a.Tast.ty (Tast.Local s)))) + ]) in (* Built fresh per use rather than shared: nothing else in this file puts one node in two places of a tree, and a pass that hangs state off a @@ -10338,7 +10899,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = arity ctx loc name 2 args; let label = check ctx ~want:Types.String (List.hd args) in let v = check ctx (List.nth args 1) in - if generic_ty v.Tast.ty then mk loc Types.Unit Tast.Unit + if open_ty v.Tast.ty then mk loc Types.Unit Tast.Unit else begin let unit_rt sym args = mk loc Types.Unit (Tast.Prim (Tast.Rt sym, args)) in let bslice = Types.Slice (Types.Mut, (Types.Int Types.U8)) in @@ -10634,6 +11195,10 @@ and ordinary_call ctx ~want loc name args = name dname dname c.Tast.vname dname c.Tast.vname else if Hashtbl.mem ctx.env.structs name then positional_struct ctx ~want loc name args + else if Hashtbl.mem ctx.env.gstructs name then + positional_struct ctx ~want loc + (generic_ctor ctx ~want loc name + (`Positional args)) args else if List.mem_assoc name operator_aliases then (* Asked before the package test, because [/=] and [=/=] have a slash in them and are not package calls. The did-you-mean cannot reach @@ -10763,10 +11328,10 @@ and ordinary_call ctx ~want loc name args = same thing here so the answer does not depend on which side of the fork the form fell down. *) Loc.failk "check/unknown-function" loc - "unknown function %s. A capitalised name is a type, and (%s \ - ...) is a generic type, which is not there yet — a generic \ - function is, written with $t in its parameter vector" - name name + "unknown function %s. A capitalised name is a type, and no \ + struct or generic struct %s is declared — a generic struct is \ + one whose fields introduce $t, as in (defstruct %s [x $t])" + name name name else Loc.failk "check/unknown-function" loc "unknown function %s" name (* Does the program's own definition of this name take this call over? @@ -10920,9 +11485,14 @@ and generic_call ctx ~want loc name vars pats pret args = | Types.Var u -> String.equal u v | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e | Types.Option e -> mentions v e + | Types.LArray (u, e) -> String.equal u v || mentions v e | Types.Map (k, w) -> mentions v k || mentions v w | Types.Fn (ps, r) | Types.CFn (ps, r) -> List.exists (mentions v) ps || mentions v r + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (_, args) -> List.exists (mentions v) args + | None -> false) | _ -> false in let bound_exactly v = @@ -10950,7 +11520,7 @@ and generic_call ctx ~want loc name vars pats pret args = the [sort-by] path below is untouched by construction. *) let bound_scalar = match pat with - | Types.Var v when (not (generic_ty p)) && Types.is_numeric p -> + | Types.Var v when (not (open_ty p)) && Types.is_numeric p -> Some v | _ -> None in @@ -10971,11 +11541,11 @@ and generic_call ctx ~want loc name vars pats pret args = let bound_view = match pat, p with | Types.Var v, (Types.Slice _ | Types.Ptr _) - when not (generic_ty p || bound_exactly v) -> Some v + when not (open_ty p || bound_exactly v) -> Some v | _ -> None in let a = - if generic_ty p || bound_view <> None then check ctx a + if open_ty p || bound_view <> None then check ctx a else if bound_scalar <> None && not untyped_literal then (* On its own terms first. A form that has no type without a want — [(zeroed)] is the one that matters — refuses here and is @@ -11180,7 +11750,8 @@ and generic_call ctx ~want loc name vars pats pret args = !subst; let cparams = List.map (subst_ty !subst) pats in let cret = subst_ty !subst pret in - if List.exists generic_ty cparams || generic_ty cret then begin + List.iter (realise ctx.env loc) (cret :: cparams); + if List.exists open_ty cparams || open_ty cret then begin (* One generic function calling another at its *own* variable, seen from the abstract pass over the caller's body — [sort-by] calling [swap] at [t]. There is no copy to make yet: [t] is not a type. The node is @@ -11209,7 +11780,7 @@ and generic_call ctx ~want loc name vars pats pret args = type variable %s, which nothing here declares %s. Add \ {:where (%s $%s)} to this function's own clause" name p.Ast.pname p.Ast.pvar v p.Ast.pname p.Ast.pname v - | Some t when not (generic_ty t) && not (pred_holds p.Ast.pname t) -> + | Some t when not (open_ty t) && not (pred_holds p.Ast.pname t) -> Loc.failk "check/predicate-unsatisfied" loc "%s is written {:where (%s $%s)}, and this call passes %s, \ which is not %s" @@ -11284,13 +11855,17 @@ and instantiate env loc gname vars subst cparams cret = concrete as one written out by hand. The [where] clause goes out of scope with them — there is nothing abstract left for it to permit, and every operator is answered by the concrete type it now has. *) + let saved_lens = env.lenvars and saved_ph = env.len_placeholder in env.subst <- List.map (fun v -> (v, List.assoc v subst)) vars; env.tyvars <- []; + env.lenvars <- []; + env.len_placeholder <- false; env.tvpreds <- []; env.chain <- env.chain @ [ (gname, cparams, loc) ]; let restore () = env.subst <- saved_subst; env.tyvars <- saved_vars; - env.tvpreds <- saved_preds; env.chain <- saved_chain + env.tvpreds <- saved_preds; env.chain <- saved_chain; + env.lenvars <- saved_lens; env.len_placeholder <- saved_ph in if Hashtbl.mem env.refused_generics gname then begin restore (); @@ -12137,10 +12712,28 @@ let collect env (decls : Ast.decl list) = | None -> ()); Hashtbl.add claimed n d.Ast.dloc) decls; + (* A defstruct whose fields introduce a variable is a template. *) + let generic_fields (fs : Ast.field list) = + let vs, _, _ = + sigil_vars ~kinds_of:(fun _ -> None) + (List.map (fun (f : Ast.field) -> f.Ast.fty) fs) + in + vs <> [] + in + let gpending = Hashtbl.create 4 in (* Names first, so a struct may mention one declared below it. *) List.iter (fun (d : Ast.decl) -> match d.Ast.d with + | Ast.Defstruct (n, fs, parent) when generic_fields fs -> + (match parent with + | Some t -> + fail t.Ast.tloc + "%s is generic, and a condition struct is not — a handler \ + matches one type, and %s is a type only at its arguments" n n + | None -> ()); + Hashtbl.replace env.locs n d.Ast.dloc; + Hashtbl.replace gpending n (fs, d.Ast.dloc) | Ast.Defstruct (n, _, _) -> Hashtbl.replace env.locs n d.Ast.dloc; Hashtbl.replace env.structs n { Tast.sname = n; fields = [] } @@ -12181,6 +12774,26 @@ let collect env (decls : Ast.decl list) = | Ast.Defalias (n, t) -> Hashtbl.replace env.aliases n t | _ -> ()) decls; + (* Each template's parameters, which needs every other template's: a + template's length argument to another is a length of its own. A cycle + between templates reads the arguments on it as types; any length among + them is then refused where it is used. *) + let rec params_of visiting n = + match Hashtbl.find_opt env.gstructs n with + | Some g -> Some (List.map snd g.gparams) + | None -> + match Hashtbl.find_opt gpending n with + | None -> None + | Some _ when List.mem n visiting -> None + | Some (fs, gloc) -> + let _, _, vs = + sigil_vars ~kinds_of:(params_of (n :: visiting)) + (List.map (fun (f : Ast.field) -> f.Ast.fty) fs) + in + Hashtbl.replace env.gstructs n { gparams = vs; gfields = fs; gloc }; + Some (List.map snd vs) + in + Hashtbl.iter (fun n _ -> ignore (params_of [] n)) gpending; (* Compile-time integer constants next, to a fixpoint, because an array length may name a constant declared below it — top-level names in a package are order-independent (plan.org, Modules). *) @@ -12317,6 +12930,17 @@ let collect env (decls : Ast.decl list) = Hashtbl.replace env.externs fn.Ast.name csym; Hashtbl.replace env.extern_locs fn.Ast.name loc | Ast.Defalias _ -> () + | Ast.Defstruct (n, fs, _) when Hashtbl.mem env.gstructs n -> + let names = List.map (fun (f : Ast.field) -> f.Ast.fname) fs in + if List.length (List.sort_uniq compare names) <> List.length names then + fail loc "%s declares the same field twice" n; + (* The template is checked once, here, at its variables: an unknown + type in a field is refused at the defstruct rather than at the + first use of it. *) + let g = Hashtbl.find env.gstructs n in + ignore + (struct_copy env loc n + (List.map (fun (p, _) -> Types.Var p) g.gparams)) | Ast.Defstruct (n, fs, parent) -> let names = List.map (fun (f : Ast.field) -> f.Ast.fname) fs in if List.length (List.sort_uniq compare names) <> List.length names then @@ -12437,7 +13061,7 @@ let collect env (decls : Ast.decl list) = signature: it goes in [gsigs] and the function goes nowhere near [fns], because nothing can be called at [t]. Every call site turns it into an ordinary entry. *) - let vars = signature_tyvars fn in + let vars, lens = signature_tyvars env fn in (* The [where] clause is checked against the signature here, once, rather than at every use of it: a predicate nobody has heard of, or one about a variable the signature never bound, is a mistake @@ -12455,18 +13079,35 @@ let collect env (decls : Ast.decl list) = (if vars = [] then " — it binds none" else " — it binds " - ^ String.concat ", " (List.map (fun v -> "$" ^ v) vars))) + ^ String.concat ", " (List.map (fun v -> "$" ^ v) vars)); + (* A where clause takes type predicates, and a length is not a + type. Whether it should take value predicates over one is + an open question in TODO.org, not an accident to fall out + of this. *) + if List.mem p.Ast.pvar lens then + Loc.failk "check/length-predicate" p.Ast.ploc + "$%s is a length, and a where clause takes type predicates \ + only — %s is about a type" p.Ast.pvar p.Ast.pname) fn.Ast.fwhere; env.tyvars <- vars; + env.lenvars <- lens; env.tvpreds <- fn.Ast.fwhere; - let params = - List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) fn.Ast.params + let params, ret = + Fun.protect + ~finally:(fun () -> + env.tyvars <- []; env.lenvars <- []; env.tvpreds <- []) + (fun () -> + let params = + List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) + fn.Ast.params + in + let ret = + match fn.Ast.ret with + | None -> Types.Unit + | Some t -> resolve env t + in + params, ret) in - let ret = - match fn.Ast.ret with None -> Types.Unit | Some t -> resolve env t - in - env.tyvars <- []; - env.tvpreds <- []; if fn.Ast.fprivate <> Ast.Exported then Hashtbl.replace env.privates fn.Ast.name (fn.Ast.nloc, fn.Ast.fprivate); @@ -12477,7 +13118,8 @@ let collect env (decls : Ast.decl list) = end else begin Hashtbl.replace env.generics fn.Ast.name fn; - Hashtbl.replace env.gsigs fn.Ast.name (vars, params, ret) + Hashtbl.replace env.gsigs fn.Ast.name (vars, params, ret); + Hashtbl.replace env.glens fn.Ast.name lens end | Ast.Defvar (n, t, _, k) -> let ty = match t with @@ -12548,36 +13190,7 @@ let collect env (decls : Ast.decl list) = it is inline. Caught here rather than when a backend tries to lay the type out or a zero value is built for it — which would not fail, it would hang. *) let check_finite env = - let rec walk seen name = - if List.mem name seen then - fail (Option.value (Hashtbl.find_opt env.locs name) ~default:Loc.unknown) - "%s contains itself by value, so it has no size — go through (Ptr %s)" - name name; - let seen = name :: seen in - match Hashtbl.find_opt env.structs name with - | Some s -> List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) s.Tast.fields - | None -> - match Hashtbl.find_opt env.datas name with - | Some u -> - List.iter - (fun (c : Tast.variant) -> - List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) c.Tast.vfields) - u.Tast.cases - | None -> - (* A union whose member is itself is the same infinite type a struct's - is — the size is the largest member and the largest member is the - whole thing. Nothing about overlaying storage makes the recursion - finite, so it is on the same walk rather than left to hang the - layout calculator. *) - match Hashtbl.find_opt env.unions name with - | None -> () - | Some u -> - List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) u.Tast.fields - and ty seen = function - | Types.Named n -> walk seen n - | Types.Array (_, e) | Types.Option e -> ty seen e - | _ -> () - in + let walk _ n = finite_from env n in Hashtbl.iter (fun n _ -> walk [] n) env.structs; Hashtbl.iter (fun n _ -> walk [] n) env.datas; Hashtbl.iter (fun n _ -> walk [] n) env.unions @@ -12758,8 +13371,30 @@ let rec check_fn env (fn : Ast.fn) : Tast.fn = and check_generic env (fn : Ast.fn) = let vars, params, ret = Hashtbl.find env.gsigs fn.Ast.name in let saved_lifted = env.lifted and saved_vars = env.tyvars - and saved_preds = env.tvpreds in + and saved_preds = env.tvpreds and saved_lens = env.lenvars + and saved_ph = env.len_placeholder in + (* The body sees a length variable's array at [abstract_len], an ordinary + array every array operation already answers for; the signature keeps + its [Types.LArray] for call sites to bind against. *) + let rec at_placeholder (t : Types.t) = + match t with + | Types.LArray (_, e) -> Types.Array (abstract_len, at_placeholder e) + | Types.Slice (m, e) -> Types.Slice (m, at_placeholder e) + | Types.Array (n, e) -> Types.Array (n, at_placeholder e) + | Types.Ptr (m, e) -> Types.Ptr (m, at_placeholder e) + | Types.Vec e -> Types.Vec (at_placeholder e) + | Types.Option e -> Types.Option (at_placeholder e) + | Types.Map (k, v) -> Types.Map (at_placeholder k, at_placeholder v) + | Types.Fn (ps, r) -> Types.Fn (List.map at_placeholder ps, at_placeholder r) + | Types.CFn (ps, r) -> + Types.CFn (List.map at_placeholder ps, at_placeholder r) + | t -> t + in + let params = List.map at_placeholder params and ret = at_placeholder ret in env.tyvars <- vars; + env.lenvars <- + Option.value (Hashtbl.find_opt env.glens fn.Ast.name) ~default:[]; + env.len_placeholder <- true; (* What the abstract pass may assume. Every operator the body reaches asks [env.tvpreds] whether the variable was declared to support it, and every instantiation asks the concrete type the same question again. *) @@ -12769,7 +13404,9 @@ and check_generic env (fn : Ast.fn) = Hashtbl.remove env.fns fn.Ast.name; env.lifted <- saved_lifted; env.tyvars <- saved_vars; - env.tvpreds <- saved_preds + env.tvpreds <- saved_preds; + env.lenvars <- saved_lens; + env.len_placeholder <- saved_ph in (match check_fn env fn with | _ -> finish () @@ -14036,7 +14673,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : |> List.sort (fun (a : Tast.extern) b -> String.compare a.Tast.esym b.Tast.esym) in let p = - { Tast.structs = values (fun (s : Tast.structure) -> s.Tast.sname) env.structs; + { Tast.structs = + (* A struct copy at variables was only ever for an abstract pass. *) + List.filter + (fun (s : Tast.structure) -> + Hashtbl.find_opt env.copies s.Tast.sname <> Some true) + (values (fun (s : Tast.structure) -> s.Tast.sname) env.structs); datas = values (fun (u : Tast.data) -> u.Tast.dname) env.datas; unions = values (fun (u : Tast.structure) -> u.Tast.sname) env.unions; globals; externs; fns; cshim } @@ -14128,6 +14770,24 @@ let lifted_since env mark = let fresh = List.length env.lifted - mark in List.rev (List.filteri (fun i _ -> i < fresh) env.lifted) +(* The struct copies this env made that [have] does not hold: what an + expression checked against a running session named for the first time — + [(Pair 1 2)] typed at a REPL makes [(Pair i32)] — which the module built + for it has to lay out, and the session has to keep. *) +let fresh_copies env (have : Tast.structure list) = + Hashtbl.fold + (fun k at_vars acc -> + if at_vars + || List.exists (fun (s : Tast.structure) -> String.equal s.Tast.sname k) + have + then acc + else + match Hashtbl.find_opt env.structs k with + | Some s -> s :: acc + | None -> acc) + env.copies [] + |> List.sort (fun (a : Tast.structure) b -> String.compare a.Tast.sname b.Tast.sname) + let env_structs env (fns : Tast.fn list) = List.filter_map (fun (f : Tast.fn) -> Hashtbl.find_opt env.structs ("env/" ^ f.Tast.name)) diff --git a/lib/cimport.ml b/lib/cimport.ml index 9fea9ebe..266879f5 100644 --- a/lib/cimport.ml +++ b/lib/cimport.ml @@ -407,6 +407,7 @@ let rec ty_source (t : Ast.texpr) = | Ast.Tname n -> n | Ast.Tapp (n, args) -> Printf.sprintf "(%s %s)" n (String.concat " " (List.map ty_source args)) + | Ast.Tlen n -> Int64.to_string n | Ast.Tslice (c, e) -> Printf.sprintf "[%s%s]" (if c then "const " else "") (ty_source e) | Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (ty_source e) diff --git a/lib/dev.ml b/lib/dev.ml index 8c54e3e7..c4c78efc 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1819,8 +1819,27 @@ let defs t = ~loc:(Loc.to_string loc) ()) classes in + (* A generic struct is listed by its template, as [(Pair $t)]; its copies + are struct names only the compiler wrote. *) + let structs = + Hashtbl.fold + (fun name _ acc -> + if Hashtbl.mem env.Check.copies name then acc + else entry ~name ~kind:"struct" ~sign:name ~loc:"" () :: acc) + env.Check.structs [] + @ Hashtbl.fold + (fun name (g : Check.gstruct) acc -> + entry ~name ~kind:"struct" + ~sign: + (Printf.sprintf "(%s %s)" name + (String.concat " " + (List.map (fun (p, _) -> "$" ^ p) g.Check.gparams))) + ~loc:"" () + :: acc) + env.Check.gstructs [] + in List.sort compare - (of_table "struct" env.Check.structs + (structs @ datas @ classes @ of_table "union" env.Check.unions @ of_table "enum" env.Check.enums diff --git a/lib/emit.ml b/lib/emit.ml index 3572b27b..fac5022a 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -370,7 +370,7 @@ let rec ll (t : Types.t) = integer spelling costs no casts and keeps the emitter honest about not knowing whether the bits are a pointer. *) | Types.Dyn -> "i64" - | Types.Var _ -> + | Types.Var _ | Types.Len _ | Types.LArray _ -> (* The checker rejects it by name — nothing reaches here. *) internal "no layout for %s" (Types.to_string t) @@ -638,7 +638,8 @@ let rec lay m (t : Types.t) : int * int = | Some u -> union_lay m u | None -> internal "no layout for struct %s" n) | Types.Dyn -> 8, 8 - | Types.Var _ -> internal "no layout for %s" (Types.to_string t) + | Types.Var _ | Types.Len _ | Types.LArray _ -> + internal "no layout for %s" (Types.to_string t) (* Size, alignment, and the offset of every member. *) and lay_fields m tys = @@ -1175,7 +1176,7 @@ let rec dty m d (t : Types.t) : int = reading: it prints, and the person reading it can hand it to the runtime's own printer. *) | Types.Dyn -> basic "dyn" 64 "DW_ATE_unsigned" - | Types.Var _ -> + | Types.Var _ | Types.Len _ | Types.LArray _ -> internal "no debug type for %s" (Types.to_string t) in Hashtbl.replace d.dtys key n; diff --git a/lib/js.ml b/lib/js.ml index 221faf9e..921d4683 100644 --- a/lib/js.ml +++ b/lib/js.ml @@ -249,6 +249,8 @@ let rec refuse_ty loc (t : Types.t) = host's own, and that work has not been done" | Types.Var n -> at loc "a type variable (%s) reached the backend, which cannot happen" n + | Types.Len _ | Types.LArray _ -> + at loc "a length variable reached the backend, which cannot happen" (* Aggregates in the sense that matters here: the types whose assignment copies in Flan and would alias in JS. A slice is deliberately not one — diff --git a/lib/load.ml b/lib/load.ml index a6f70b98..724ebd4a 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -205,8 +205,11 @@ let rec rename_texpr owned alias (t : Ast.texpr) : Ast.texpr = Ast.Tarray (rename_len owned alias l, rename_texpr owned alias e) | Ast.Tmap (k, v) -> Ast.Tmap (rename_texpr owned alias k, rename_texpr owned alias v) + (* The head too, when it is a generic struct the package declares. *) | Ast.Tapp (n, args) -> + let n = if List.mem n owned then qualify alias n else n in Ast.Tapp (n, List.map (rename_texpr owned alias) args) + | Ast.Tlen _ as k -> k | Ast.Tfn (env, ps, r) -> Ast.Tfn (env, List.map (rename_texpr owned alias) ps, rename_texpr owned alias r) @@ -792,8 +795,11 @@ let rec texpr_uses acc (t : Ast.texpr) = (match l with Ast.Lname n -> acc := (n, t.Ast.tloc) :: !acc | Ast.Lint _ -> ()); texpr_uses acc e | Ast.Tmap (k, v) -> texpr_uses acc k; texpr_uses acc v - | Ast.Tapp (_, args) -> List.iter (texpr_uses acc) args + | Ast.Tapp (n, args) -> + acc := (n, t.Ast.tloc) :: !acc; + List.iter (texpr_uses acc) args | Ast.Tfn (_, ps, r) -> List.iter (texpr_uses acc) ps; texpr_uses acc r + | Ast.Tlen _ -> () let rec expr_uses acc (e : Ast.expr) = let go = expr_uses acc in diff --git a/lib/parse.ml b/lib/parse.ml index e5190994..6263645a 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -136,7 +136,25 @@ let rec texpr (f : Form.t) : Ast.texpr = mk (Ast.Tfn (env, List.map texpr params, texpr ret)) | _ -> fail f "a function type is (%s [T ...] R)" which) | List ({ v = Sym name; _ } :: args) when args <> [] -> - mk (Ast.Tapp (name, List.map texpr args)) + (* An integer argument is a generic struct's length, and a type + constructor is capitalised. A lowercase head is a body form in the + return slot — (+ x 1) — and its integer is the type parser's reason to + give up, which is the refusal that slot is built on. *) + let capitalised = + let base = + match String.rindex_opt name '/' with + | Some i -> String.sub name (i + 1) (String.length name - i - 1) + | None -> name + in + base <> "" && Char.uppercase_ascii base.[0] = base.[0] + && Char.lowercase_ascii base.[0] <> base.[0] + in + let arg (a : Form.t) = + match a.v with + | Int n when capitalised -> { Ast.t = Ast.Tlen n; tloc = a.loc } + | _ -> texpr a + in + mk (Ast.Tapp (name, List.map arg args)) | _ -> fail f "expected a type, found %s" (Form.to_string f) and len (f : Form.t) : Ast.len = diff --git a/lib/session.ml b/lib/session.ml index 41d45d6f..1b3744e6 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -597,7 +597,7 @@ let compatible ~loc (old_ : Tast.program) (new_ : Tast.program) = if not same then fail loc "%s changes layout. Restart to change it." - s.Tast.sname + (Types.to_string (Types.Named s.Tast.sname)) | None -> ()) new_.Tast.structs @@ -2610,10 +2610,12 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = let placed = List.filter (fun (f : Tast.fn) -> List.mem f.Tast.name own) placed in + let copies = Check.fresh_copies t.env t.program.Tast.structs in let program = { t.program with Tast.fns = t.program.Tast.fns @ fresh @ placed; - structs = t.program.Tast.structs @ Check.env_structs t.env lifted; + structs = + t.program.Tast.structs @ copies @ Check.env_structs t.env lifted; externs = t.program.Tast.externs @ externs } in let ir = @@ -2639,7 +2641,10 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = caller closes that half by taking a [held] before this and restoring it when either fails — a copy the session holds and no module defines is a null cell exactly as a stranded declaration is. *) - t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh }; + t.program <- + { t.program with + Tast.fns = t.program.Tast.fns @ fresh; + structs = t.program.Tast.structs @ copies }; { ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] } (* ── What a macro call expands to ──────────────────────────────────── *) diff --git a/lib/shim.ml b/lib/shim.ml index c3070b04..bbcdd7be 100644 --- a/lib/shim.ml +++ b/lib/shim.ml @@ -256,6 +256,7 @@ let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string = fail loc "%s is a function type, and a C callback is not implemented" what | Ast.Tapp (n, _) -> fail loc "%s is %s, which is not a type this shim generator knows" what n + | Ast.Tlen n -> fail loc "%s is %Ld, which is not a type" what n (* ── What one parameter does at the boundary ────────────────────────── *) diff --git a/lib/types.ml b/lib/types.ml index 6e2bb57d..328909f9 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -106,6 +106,15 @@ type t = | Fn of t list * t (* (Fn [T ...] R) *) | CFn of t list * t (* (CFn [T ...] R) *) | Var of string (* a type variable — milestone 5 *) + (* The two halves of a length parameter, and neither is the type of a value. + [Len] is a length standing where a generic struct's argument goes — the 8 + in (Small 8 i32) — and what a length variable is bound to. [LArray] is a + fixed array whose length is a variable, [[$n $t]], and exists only in a + generic signature, as the pattern a call site binds [n] from. A generic + body is checked with its lengths at [Check.abstract_len], so neither ever + reaches a backend. *) + | Len of int64 + | LArray of string * t (* [dyn]: one machine word whose contents the runtime knows and this module does not. It is a written type — [(defonce x dyn 5)] boxes the 5 — and it is also what an unannotated [defn] parameter means, which is why it is a @@ -206,8 +215,20 @@ let rec equal a b = && List.for_all2 equal ps ps' && equal r r' | Var x, Var y -> String.equal x y + | Len x, Len y -> Int64.equal x y + | LArray (n, x), LArray (m, y) -> String.equal n m && equal x y | _ -> false +(* How a generic struct's copy is spelled to a reader. The copy is an + ordinary struct under a symbol-safe key — [Small-8-i32] — and this is the + key's written form, [(Small 8 i32)], filled in as each copy is made. Global + rather than on a checker's env because every message that prints a type + comes through here with no env in hand. The key determines the spelling, + so an entry left from an earlier program in the same process is wrong only + for a struct that program's successor declares under a copy's key by hand, + and then only in how a message spells it. *) +let display : (string, string) Hashtbl.t = Hashtbl.create 16 + let rec to_string = function | Int k -> ikind_name k | Float k -> fkind_name k @@ -215,7 +236,8 @@ let rec to_string = function | String -> "string" | Unit -> "()" | Never -> "Never" - | Named n | Enum n -> n + | Named n -> (match Hashtbl.find_opt display n with Some d -> d | None -> n) + | Enum n -> n | Slice (Mut, t) -> "[" ^ to_string t ^ "]" | Slice (Const, t) -> "[const " ^ to_string t ^ "]" | Array (n, t) -> Printf.sprintf "[%Ld %s]" n (to_string t) @@ -232,6 +254,8 @@ let rec to_string = function Printf.sprintf "(CFn [%s] %s)" (String.concat " " (List.map to_string ps)) (to_string r) | Var n -> "$" ^ n + | Len n -> Int64.to_string n + | LArray (n, t) -> Printf.sprintf "[$%s %s]" n (to_string t) | Dyn -> "dyn" let is_numeric = function Int _ | Float _ -> true | _ -> false diff --git a/lib/x86.ml b/lib/x86.ml index bcf1ae79..f5327a4c 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -532,6 +532,7 @@ let is_agg (t : Types.t) = the arithmetic. *) | Types.Dyn -> false | Types.Var v -> unsupported "type variable %s" v + | Types.Len _ | Types.LArray _ -> unsupported "length variable" let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false let is_float (t : Types.t) = match t with Types.Float _ -> true | _ -> false diff --git a/test/programs/generic-struct.flan b/test/programs/generic-struct.flan new file mode 100644 index 00000000..564f804e --- /dev/null +++ b/test/programs/generic-struct.flan @@ -0,0 +1,89 @@ +;;;; Generic structs, end to end: type parameters and length parameters. +;;;; +;;;; A defstruct whose fields introduce $t is a template, and each set of +;;;; arguments it is given is a copy — an ordinary struct. A parameter is a +;;;; length when it stands in an array's length slot, and a type anywhere else; +;;;; the arguments are written in the order the fields first introduce them. +;;;; +;;;; Small is Odin's Small_Array: a fixed-capacity array with a count, and no +;;;; allocation anywhere. + +(defstruct Small [items [$n $t] count i32]) + +;; A generic function over a generic struct binds both of its parameters from +;; the argument, and reads the length back as a value. +(defn append! [s (Ptr (Small $n $t)) x $t] bool + (if (< (.count s) n) + (do (set (at (.items s) (.count s)) x) + (set (.count s) (+ (.count s) 1)) + true) + false)) + +(defn pop! [s (Ptr (Small $n $t))] (Option $t) + (if (= (.count s) 0) + None + (do (set (.count s) (- (.count s) 1)) + (Some (at (.items s) (.count s)))))) + +(defn capacity [s (Ptr (Small $n $t))] i32 n) + +(defn total [s (Ptr (Small $n $t))] $t {:where (numeric? $t)} + (let [acc (the $t 0)] + (dotimes [i (.count s)] + (set acc (+ acc (at (.items s) i)))) + acc)) + +;; A type parameter alone, built positionally with the type read off the +;; fields, and returned under a variable. +(defstruct Pair [a $t b $t]) + +(defn swapped [p (Pair $t)] (Pair $t) (Pair (.b p) (.a p))) + +;; A copy that names itself through a pointer, and a literal field that +;; takes its width from the one beside it. +(defstruct Node [v $t next (Option (Ptr (Node $t)))]) + +(defn sum-list [n (Ptr (Node i64))] i64 + (loop [at n acc (the i64 0)] + (let [acc (+ acc (.v at))] + (match (.next at) + (Some p) (recur p acc) + None acc)))) + +;; A template naming another at its own parameters. +(defstruct Twice [x (Small $m $u) y (Small $m $u)]) + +;; A length variable straight on an array parameter. +(defn len-of [a [$k $e]] i32 k) + +(defconst cap 3) + +(defn main [] i32 + (let [s (the (Small 4 i32) (zeroed)) + f (the (Small cap f64) (zeroed))] + (append! (addr s) 10) + (append! (addr s) 20) + (append! (addr s) 30) + (println (total (addr s)) (.count s) (capacity (addr s))) + (append! (addr f) 1.5) + (append! (addr f) 2.5) + (append! (addr f) 3.5) + (println (append! (addr f) 4.5) (total (addr f)) (capacity (addr f))) + (println (pop! (addr f)) (pop! (addr f)) (.count f)) + (let [p (Pair 1 2) + q (swapped p) + r (swapped (Pair {.a 1.5 .b 2.5}))] + (println (.a q) (.b q) (.a r) (.b r))) + (let [c (the (Node i64) {.v 3}) + b (Node 2 (Some (addr c))) + a (Node 1 (Some (addr b)))] + (println (sum-list (addr a)))) + (let [w (the (Twice 2 u8) (zeroed))] + (append! (addr (.y w)) 7) + (println (.count (.x w)) (.count (.y w)) (capacity (addr (.x w))))) + (println (len-of [1 2 3]) (len-of [1.5 2.5])) + (let [v (vec-new (Pair i32))] + (push v (Pair 5 6)) + (println (.b (at v 0))) + (free v)) + 0)) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 4f08c8bf..d9921546 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3466,6 +3466,18 @@ let () = outputs "generics" "programs/generics.flan" generics_out; outputs ~opt:"-O0" "generics, -O0" "programs/generics.flan" generics_out; + (* Generic structs — see the program's header. The third line is two pops + printed in one call, which is also the pin for a printed call being + evaluated once: the walk reads an option's tag and then its payload, + and each read used to make the call again. *) + let generic_struct_out = + "60 3 4\nfalse 7.5 3\n(some 3.5) (some 2.5) 1\n2 1 2.5 1.5\n6\n\ + 0 1 2\n3 2\n6\n" + in + outputs "generic structs" "programs/generic-struct.flan" generic_struct_out; + outputs ~x86:true "generic structs, --x86" "programs/generic-struct.flan" + generic_struct_out; + (* integer?, end to end — see the program's own header. The first eight lines are the collapsed abs at six widths and both signed minimums (which answer themselves; the negation wraps). The [0 0] after them is diff --git a/test/test_flan.ml b/test/test_flan.ml index d306b1d1..9d0ad68d 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1470,10 +1470,10 @@ let () = can actually be written there; the parameter-vector suggestion survives where it works, which the return-type pin further down exercises. *) rejects_check "a real type variable at a field" "(defstruct Holder [x elem])" - ~needle:"a field is built at one type for every value"; + ~needle:"in a defstruct's fields that makes the struct generic over it"; rejects_check "and the field message offers what a field can hold" "(defstruct Holder [x elem])" - ~needle:"Write a concrete type here, or dyn to hold any value"; + ~needle:"Write $elem, a concrete type, or dyn to hold any value"; rejects_check "an unknown concrete type" "(defn f [x Widget] ())" ~needle:"unknown type Widget"; @@ -2871,13 +2871,11 @@ let () = (* [(Pair i32)] in a defonce falls down the value fork now that the third element takes either reading, and the generics answer the type fork gave it has to be reachable from here too. *) - (* A capitalised head with arguments is a *type* given type arguments, and - that is the half of generics that is not built — Types.Named is a bare - string with no room for parameters. The sentence says which half, since - generic functions are here and pointing at them is the useful part. *) + (* A capitalised head with arguments is a *type* given type arguments; with + no such struct declared, the sentence says how one is. *) rejects_check "a capitalised call with arguments is a generic type" "(defonce x (Pair i32)) (defn f [] i32 0)" - ~needle:"is a generic type, which is not there yet"; + ~needle:"no struct or generic struct Pair is declared"; accepts "and the generic function it points at is" "(defn pair-fst [a $t b $u] $t (do b a))\n\ (defn main [] () (println (pair-fst 1 true)))"; @@ -6701,9 +6699,74 @@ let () = "(defn f [a $t b $u] i32 (do a b (let [v (vec-new $w)] (free v) 0)))"; (* Where no variable is in scope there is none to name, and the answer is the rule: a sigil binds, and only a defn signature is a binding site. *) - rejects_check "a sigil in a struct field, where nothing can bind one" - ~needle:"only a defn signature can" - "(defstruct S [v $t])"; + rejects_check "a sigil in a data case's field, where nothing can bind one" + ~needle:"only a defn signature or a defstruct's fields can" + "(defdata D [(C [v $t])])"; + + (* ── Generic structs: what is refused, and where ─────────────────── *) + rejects_check "a generic struct given the wrong number of arguments" + ~needle:"Pair takes 1 argument, (Pair $t), and this gives 2" + "(defstruct Pair [a $t b $t]) (defn f [p (Pair i32 i64)] i32 0)"; + rejects_check "a generic struct named with no arguments" + ~needle:"Pair is generic, and a type only once it is given its arguments" + "(defstruct Pair [a $t b $t]) (defn f [p Pair] i32 0)"; + rejects_check "a type where a length argument goes" + ~needle:"Small's $n is a length" + "(defstruct Small [items [$n $t] count i32]) \ + (defn f [p (Small i32 4)] i32 0)"; + rejects_check "a length where a type argument goes" + ~needle:"Small's $t is a type, and 4 is a length" + "(defstruct Small [items [$n $t] count i32]) \ + (defn f [p (Small 4 4)] i32 0)"; + rejects_check "a negative length argument" + ~needle:"-1 is negative" + "(defstruct Small [items [$n $t] count i32]) \ + (defn f [p (Small -1 i32)] i32 0)"; + rejects_check "one variable as both a length and a type" + ~needle:"$t stands for a length in one place here and a type in another" + "(defstruct Bad [x $t y [$t i32]])"; + rejects_check "a length variable where a type goes" + ~needle:"n is a length, not a type" + "(defn f [a [$n i32]] i32 (let [x (the n 0)] 0))"; + rejects_check "a where clause over a length variable" + ~needle:"$n is a length, and a where clause takes type predicates only" + "(defn f [a [$n i32]] i32 {:where (numeric? $n)} 0)"; + rejects_check "a generic struct that contains itself by value" + ~needle:"(Loop $t) contains itself by value" + "(defstruct Loop [next (Loop $t)])"; + rejects_check "a generic struct that asks for bigger copies of itself" + ~needle:"Grow names a copy of itself at a type built around its own" + "(defstruct Grow [next (Ptr (Grow [$t]))]) (defn f [p (Grow i32)] i32 0)"; + rejects_check "a copy whose key is already a struct's name" + ~needle:"Pair at these arguments is called Pair-i32, and Pair-i32 is \ + already defined" + "(defstruct Pair [a $t b $t]) (defstruct Pair-i32 [x i32]) \ + (defn f [p (Pair i32)] i32 0)"; + rejects_check "a generic struct literal whose fields decide nothing" + ~needle:"Pair's $t is not decided by the fields given here" + "(defstruct Pair [a $t b $t]) (defn f [] i32 (let [p (Pair {})] 0))"; + rejects_check "two fields that disagree about the variable" + ~needle:"(Pair $t)'s .b is i32 here, and this is f64" + "(defstruct Pair [a $t b $t]) \ + (defn f [] i32 (let [p (Pair (the i32 1) (the f64 2.5))] 0))"; + accepts "a literal field takes its width from a typed one beside it" + "(defstruct Pair [a $t b $t]) \ + (defn f [] f64 (let [p (Pair 1 (the f64 2.5))] (.a p)))"; + rejects_check "a generic struct as a condition" + ~needle:"Pair is generic, and a condition struct is not" + "(defstruct Pair :parent Error [a $t])"; + rejects_check "an operator a generic body's struct field does not support" + ~needle:"+ over the type variable $t" + "(defstruct Pair [a $t b $t]) (defn f [p (Pair $t)] $t (+ (.a p) (.b p)))"; + accepts "the same body with the predicate declared" + "(defstruct Pair [a $t b $t]) \ + (defn f [p (Pair $t)] $t {:where (numeric? $t)} (+ (.a p) (.b p))) \ + (defn main [] i32 (f (Pair 1 2)))"; + accepts "a copy wanted where it is built takes its type from there" + "(defstruct Pair [a $t b $t]) (defn f [] (Pair i64) (Pair 1 2))"; + accepts "a defonce of a generic struct's copy" + "(defstruct Pair [a $t b $t]) (defonce g (Pair i32)) \ + (defn main [] i32 (.a g))"; (* ── The builtin table against the arms it describes ────────────── [Check.builtins] is what the editor's C-c C-v and M-. read for a name no diff --git a/test/test_session.ml b/test/test_session.ml index 5af415c9..73ff7f35 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -354,6 +354,26 @@ let () = | exception Loc.Error { Loc.dmsg = m; _ } -> fail "the session was poisoned by a bad expression: %s" m); + (* A generic struct's copy first named by an expression typed at the + session: the module built for it has to lay the copy out, and the + session keeps it, as it keeps a generic function's copy. *) + (let gt, _ = Session.create ~file:"programs/reload.flan" () in + (match Session.eval gt "(defstruct Pair [a $t b $t])" with + | _ -> () + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a generic struct was refused at the session: %s" m); + match Session.eval_expr gt "(println (.b (Pair 7 8)))" with + | e -> + if not (has e.Session.ir "%\"Pair-i32\" = type") then + fail "the expression's module did not carry the struct copy"; + if not + (List.exists + (fun (s : Tast.structure) -> String.equal s.Tast.sname "Pair-i32") + gt.Session.program.Tast.structs) + then fail "the session did not keep the struct copy an expression made" + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "an expression building a generic struct was refused: %s" m); + (* The other half of "a refusal costs nothing", and the half that used to be missing: a form can check and *then* fail, in the build or at the agent, and the session that already accepted it has no way to hear about it From ea67e058bf09800d4a9afa9a753bbf64249fdbf7 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:15:40 +0700 Subject: [PATCH 03/20] A generic over a generic struct calls another at the same struct variables, and a struct copy is a map key and a function-value parameter on both backends --- lib/check.ml | 4 ++-- test/programs/generic-struct.flan | 19 +++++++++++++++++++ test/test_acceptance.ml | 2 +- 3 files changed, 22 insertions(+), 3 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 59e1ba1b..feb08cd9 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -2502,11 +2502,11 @@ let rec bind_ty ?(widen = false) ?(ro = true) subst (pat : Types.t) bind_ty ~ro:false subst (Types.Var v) (Types.Len n) && inner p a (* A struct copy at variables against a copy of the same template: each argument against its own. *) - | Types.Named p, Types.Named a when not (String.equal p a) -> + | Types.Named p, Types.Named a -> (match Hashtbl.find_opt struct_apps p, Hashtbl.find_opt struct_apps a with | Some (g, ps), Some (h, as_) when String.equal g h -> List.length ps = List.length as_ && List.for_all2 inner ps as_ - | _ -> false) + | _ -> Types.fits ~expected:pat ~actual:arg) (* Nothing generic left on the pattern side: this is ordinary type equality, and [Never] fits anywhere exactly as it does elsewhere. *) | p, a -> Types.fits ~expected:p ~actual:a diff --git a/test/programs/generic-struct.flan b/test/programs/generic-struct.flan index 564f804e..f080c4e4 100644 --- a/test/programs/generic-struct.flan +++ b/test/programs/generic-struct.flan @@ -19,6 +19,11 @@ true) false)) +;; One generic over the struct calling another at its own variables. +(defn append-all! [s (Ptr (Small $n $t)) xs [$t]] () + (dotimes [i (length xs)] + (append! s (at xs i)))) + (defn pop! [s (Ptr (Small $n $t))] (Option $t) (if (= (.count s) 0) None @@ -53,6 +58,11 @@ ;; A template naming another at its own parameters. (defstruct Twice [x (Small $m $u) y (Small $m $u)]) +;; A copy as a map key, and a named function over one handed where a +;; function value is wanted. +(defn pair-sum [p (Pair i32)] i32 (+ (.a p) (.b p))) +(defn apply-to [f (Fn [(Pair i32)] i32) p (Pair i32)] i32 (f p)) + ;; A length variable straight on an array parameter. (defn len-of [a [$k $e]] i32 k) @@ -86,4 +96,13 @@ (push v (Pair 5 6)) (println (.b (at v 0))) (free v)) + (let [t (the (Small 5 i64) (zeroed)) + xs (the [3 i64] [1 2 3])] + (append-all! (addr t) (slice xs)) + (println (total (addr t)) (.count t))) + (let [m (map-new (Pair i32) i32)] + (put m (Pair 1 2) 12) + (put m (Pair 3 4) 34) + (println (get m (Pair 3 4)) (get m (Pair 2 1)) (apply-to pair-sum (Pair 7 8))) + (free m)) 0)) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index d9921546..a61d9c18 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3472,7 +3472,7 @@ let () = and each read used to make the call again. *) let generic_struct_out = "60 3 4\nfalse 7.5 3\n(some 3.5) (some 2.5) 1\n2 1 2.5 1.5\n6\n\ - 0 1 2\n3 2\n6\n" + 0 1 2\n3 2\n6\n6 3\n(some 34) none 15\n" in outputs "generic structs" "programs/generic-struct.flan" generic_struct_out; outputs ~x86:true "generic structs, --x86" "programs/generic-struct.flan" From b51b7d0a53f62df17662e13643c43f3907b67f9f Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:20:08 +0700 Subject: [PATCH 04/20] A refusal in a prelude generic's body stands at the call that asked for the copy, with the prelude's line as a note --- lib/check.ml | 34 ++++++++++++++++++++++++++-------- test/test_flan.ml | 31 +++++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+), 8 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 8b6df651..d69941fc 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -12049,16 +12049,34 @@ and instantiate env loc gname vars subst cparams cret = which call asked for this copy; the note names it. Nested copies each add their own, so the notes walk the chain back to the call the programmer wrote. *) + let at () = + String.concat ", " + (List.map + (fun v -> Printf.sprintf "$%s = %s" v + (Types.to_string (List.assoc v subst))) + vars) + in + let in_prelude (l : Loc.t) = String.equal l.Loc.file Prelude.file in let e = match e with + (* A prelude generic's body is source nobody at this call wrote, and + an editor cannot jump to it. The refusal moves to the call that + asked for the copy, and the prelude's line comes along as a + note. *) + | Loc.Error d when in_prelude d.Loc.dloc && not (in_prelude loc) -> + Loc.Error + (Loc.sort_notes + { d with + Loc.dloc = loc; + dmsg = + Printf.sprintf "%s cannot be made at %s. In its body: %s" + gname (at ()) d.Loc.dmsg; + notes = + d.Loc.notes + @ [ Loc.note d.Loc.dloc + (Printf.sprintf "in %s's body, in the prelude" gname) ]; + expansion = None }) | Loc.Error d when d.Loc.dloc <> loc -> - let at = - String.concat ", " - (List.map - (fun v -> Printf.sprintf "$%s = %s" v - (Types.to_string (List.assoc v subst))) - vars) - in Loc.Error (Loc.sort_notes { d with @@ -12066,7 +12084,7 @@ and instantiate env loc gname vars subst cparams cret = d.Loc.notes @ [ Loc.note loc (Printf.sprintf "%s is instantiated at %s here" - gname at) ] }) + gname (at ())) ] }) | e -> e in (* A copy whose body did not check is not a copy. Both entries go back diff --git a/test/test_flan.ml b/test/test_flan.ml index 9d0ad68d..1ab6d401 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6017,6 +6017,37 @@ let () = = [ "show is instantiated at $t = (CFn [] i32) here"; "outer is instantiated at $t = (CFn [] i32) here" ])); + (* A copy that cannot be built at a closure's type: the zeroed value in the + body is refused there, and the call that asked is named. *) + (match + checked + "(defn blank [x $t] $t (let [z (the $t (zeroed))] z)) \ + (defn use-it [f (Fn [i32] i32)] i32 (blank f) 0)" + with + | _ -> check "a zeroed closure in a copy is refused" false + | exception Loc.Error d -> + check "a copy at a closure type names the call that asked" + (List.exists + (fun (n : Loc.note) -> + contains n.Loc.nmsg "blank is instantiated at $t = (Fn [i32] i32) here") + d.Loc.notes)); + + (* A prelude generic's body is nobody's source at the call: the refusal is + at the call, and the prelude's line is a note. *) + (match + checked + "(defn keep [g (Vec u8)] bool true) \ + (defn use-it [xs [(Vec u8)]] i32 (length (filter xs keep)))" + with + | _ -> check "a prelude copy that cannot be built is refused" false + | exception Loc.Error d -> + check "a prelude copy's refusal is at the user's call" + (d.Loc.dloc.Loc.file <> Prelude.file + && contains d.Loc.dmsg "filter cannot be made at $t = (Vec u8)" + && List.exists + (fun (n : Loc.note) -> n.Loc.nloc.Loc.file = Prelude.file) + d.Loc.notes)); + (* The parser resynchronises on a top-level form, so two bad declarations are two errors rather than one. *) (match Parse.program_all (read "(defn a)\n(defn b)\n") with From 730730a1a7b1fe3b408765d122024668e84de9a5 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:23:19 +0700 Subject: [PATCH 05/20] A relocated prelude refusal's note says only that the refusal is there, since the notes before it name which body --- lib/check.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/check.ml b/lib/check.ml index d69941fc..c9c6a0df 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -12074,7 +12074,7 @@ and instantiate env loc gname vars subst cparams cret = notes = d.Loc.notes @ [ Loc.note d.Loc.dloc - (Printf.sprintf "in %s's body, in the prelude" gname) ]; + "the refusal is here, in the prelude" ]; expansion = None }) | Loc.Error d when d.Loc.dloc <> loc -> Loc.Error From 9d0d42e4676536119c4eb754fc0e1ba8de564421 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:59:11 +0700 Subject: [PATCH 06/20] A generic struct's copy prints as (Pair i32 {...}), crosses to C behind a pointer, names each use that made it when refused, settles literal fields at the wider type, and is laid out by stores and restarts that first name it --- lib/check.ml | 93 ++++++++++++++++++++--- lib/dev.ml | 12 ++- lib/parse.ml | 50 ++++++++++--- lib/render.ml | 2 +- lib/session.ml | 29 +++++--- lib/shim.ml | 118 ++++++++++++++++++++++++++++++ lib/types.ml | 9 +++ test/programs/generic-struct.flan | 3 +- test/test_acceptance.ml | 33 ++++++++- test/test_dev.ml | 22 ++++++ test/test_flan.ml | 41 ++++++++++- test/test_session.ml | 50 +++++++++++++ 12 files changed, 422 insertions(+), 40 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index c9c6a0df..8efdae6b 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -79,6 +79,16 @@ let rec slot_text = function | Sclass c -> c | Sopt s -> "(Option " ^ slot_text s ^ ")" +(* Where [sep] first occurs in [m]. *) +let find_sub m sep = + let n = String.length m and k = String.length sep in + let rec go i = + if i + k > n then None + else if String.sub m i k = sep then Some i + else go (i + 1) + in + go 0 + (* ── Generic structs ───────────────────────────────────────────────── [(defstruct Small [items [$n $t] count i32])] is a template, not a type. Its parameters are the sigil names its fields introduce, in the order @@ -1642,7 +1652,17 @@ and struct_copy env loc name targs = restore (); Hashtbl.remove env.copies key; Hashtbl.remove env.structs key; - raise e + (* A field refused inside the template says nothing about which use + asked for this copy; the note names it, one per level of copies. *) + (match e with + | Loc.Error d when d.Loc.dloc <> loc -> + Loc.raise_diag + { d with + Loc.notes = + d.Loc.notes + @ [ Loc.note loc + (Types.to_string (Types.Named key) ^ " is made here") ] } + | e -> raise e) end (* Does a struct argument still mention a variable? *) @@ -1728,12 +1748,12 @@ and resolve_name env ~seen loc n = | [ v ] -> Loc.failk "check/unbound-type-variable" loc "nothing binds the type variable %s — this signature introduces %s, \ - so write %s here, or a concrete type" n v v + so write %s here, or a concrete type" n ("$" ^ v) ("$" ^ v) | vars -> Loc.failk "check/unbound-type-variable" loc "nothing binds the type variable %s — this signature introduces %s, \ so write one of those here, or a concrete type" - n (String.concat " and " vars)) + n (String.concat " and " (List.map (fun v -> "$" ^ v) vars))) else match Types.ikind_of_name n with | Some k -> Types.Int k @@ -1769,7 +1789,15 @@ and resolve_name env ~seen loc n = ~notes:[ Loc.note g.gloc (n ^ " is declared here") ] "%s is generic, and a type only once it is given its arguments: \ write (%s %s)" n n - (String.concat " " (List.map (fun (p, _) -> "$" ^ p) g.gparams)) + (* Variables are only an answer where a signature binds them; in + ordinary code the example is concrete. *) + (String.concat " " + (List.map + (fun (p, is_len) -> + if env.tyvars <> [] then "$" ^ p + else if is_len then "8" + else "i32") + g.gparams)) | _ when Hashtbl.mem env.structs n -> Types.Named n (* A data type is [Named] exactly as a struct is: one case in [Types.t] covers both, and which table the name is in is what tells them apart. @@ -4056,7 +4084,7 @@ let rec key_pair env loc (k : Types.t) : Tast.fnref * Tast.fnref = to that is still a refusal rather than a guessed pair. *) | Types.Var v -> Loc.failk "check/generic-map-key" loc - "a map keyed by the type variable %s has no hash and no equality here. \ + "a map keyed by the type variable $%s has no hash and no equality here. \ Write {:where (hashable? $%s)} at the head of the body, or write the \ operation in a function over the concrete key type and call that" v v | Types.String -> Tast.Rtfn "flan_hash_str", Tast.Rtfn "flan_eq_str" @@ -6611,12 +6639,37 @@ and generic_ctor ctx ~want loc name given = | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ -> true | _ -> false in + (* A literal's own type, the one it has with nothing expected of it. *) + let literal_type (a : Ast.expr) = + match a.Ast.e with + | Ast.Float _ -> Types.Float Types.F64 + | Ast.UInt _ -> Types.Int Types.U64 + | Ast.Byte _ -> Types.Int Types.U8 + | _ -> Types.Int Types.I32 + in let pairs = List.filter (fun (_, a) -> not (literal a)) pairs @ List.filter (fun (_, a) -> literal a) pairs in + (* Variables only literals have bound so far: a later literal may widen + them, as a generic call's literal arguments meet at the wider type — + [(Pair 1 2.5)] is a [(Pair f64)]. *) + let lit_only = ref [] in List.iter (fun ((f : Tast.field), (a : Ast.expr)) -> + match f.Tast.fty with + | Types.Var v when literal a && not (List.mem_assoc v !subst && not (List.mem v !lit_only)) -> + let t = (literal_type a) in + (match List.assoc_opt v !subst with + | None -> subst := (v, t) :: !subst; lit_only := v :: !lit_only + | Some b -> + (match Types.join b t with + | Some j -> subst := (v, j) :: List.remove_assoc v !subst + | None -> + fail a.Ast.loc "%s's .%s is %s here, and this is %s" + (Types.to_string (Types.Named open_key)) f.Tast.fname + (Types.to_string b) (Types.to_string t))) + | _ -> if open_ty f.Tast.fty && not (literal a && subst_ty !subst f.Tast.fty |> open_ty |> not) then begin @@ -6657,7 +6710,13 @@ and generic_ctor ctx ~want loc name given = "%s's $%s is not decided by the fields given here. Name the \ type where the value goes, as in (the (%s %s) ...)" name p name - (String.concat " " (List.map (fun (q, _) -> "$" ^ q) g.gparams))) + (String.concat " " + (List.map + (fun (q, is_len) -> + if env.tyvars <> [] then "$" ^ q + else if is_len then "8" + else "i32") + g.gparams))) g.gparams in struct_copy env loc name targs) @@ -11946,7 +12005,7 @@ and generic_call ctx ~want loc name vars pats pret args = | Some (Types.Var v) when not (declares ctx.env.tvpreds v p.Ast.pname) -> Loc.failk "check/predicate-not-carried" loc "%s is written {:where (%s $%s)}, and this call passes the \ - type variable %s, which nothing here declares %s. Add \ + type variable $%s, which nothing here declares %s. Add \ {:where (%s $%s)} to this function's own clause" name p.Ast.pname p.Ast.pvar v p.Ast.pname p.Ast.pname v | Some t when not (open_ty t) && not (pred_holds p.Ast.pname t) -> @@ -12064,17 +12123,29 @@ and instantiate env loc gname vars subst cparams cret = asked for the copy, and the prelude's line comes along as a note. *) | Loc.Error d when in_prelude d.Loc.dloc && not (in_prelude loc) -> + (* Only the reason comes along. The rest of the body's message is + a fix to the body, which the caller cannot make. *) + let reason = + let cut sep m = + match find_sub m sep with + | Some i -> String.sub m 0 i + | None -> m + in + cut ". " (cut " — " d.Loc.dmsg) + in Loc.Error (Loc.sort_notes { d with Loc.dloc = loc; dmsg = - Printf.sprintf "%s cannot be made at %s. In its body: %s" - gname (at ()) d.Loc.dmsg; + Printf.sprintf + "%s cannot be made at %s: its body in the prelude does \ + not compile at that type. Pass a value of a type it \ + takes, or write the operation here" + gname (at ()); notes = d.Loc.notes - @ [ Loc.note d.Loc.dloc - "the refusal is here, in the prelude" ]; + @ [ Loc.note d.Loc.dloc ("in the prelude, " ^ reason) ]; expansion = None }) | Loc.Error d when d.Loc.dloc <> loc -> Loc.Error diff --git a/lib/dev.ml b/lib/dev.ml index f4982178..c5649835 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1920,13 +1920,19 @@ let defs t = text about the type and never touches the program. *) let layout t ~ty = let structs = t.session.Session.program.Tast.structs in + (* A generic struct's copy answers to the spelling a printed value's head + gives it, [Pair i32], and to its type's, [(Pair i32)], as well as to its + key. *) + let names (s : Tast.structure) = + [ s.Tast.sname; Types.struct_head s.Tast.sname; + Types.to_string (Types.Named s.Tast.sname) ] + in match - List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname ty) - structs + List.find_opt (fun (s : Tast.structure) -> List.mem ty (names s)) structs with | Some s -> ok - [ ":type " ^ Wire.quote s.Tast.sname; + [ ":type " ^ Wire.quote (Types.to_string (Types.Named s.Tast.sname)); ":fields " ^ Wire.list (List.map diff --git a/lib/parse.ml b/lib/parse.ml index 6263645a..e8e84523 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -73,6 +73,16 @@ let no_pattern (f : Form.t) = (* ── Type expressions ──────────────────────────────────────────────── *) +(* A type constructor's spelling: its last segment starts with a capital. *) +let capitalised_name name = + let base = + match String.rindex_opt name '/' with + | Some i -> String.sub name (i + 1) (String.length name - i - 1) + | None -> name + in + base <> "" && Char.uppercase_ascii base.[0] = base.[0] + && Char.lowercase_ascii base.[0] <> base.[0] + let rec texpr (f : Form.t) : Ast.texpr = let mk t = { Ast.t; tloc = f.loc } in match f.v with @@ -135,23 +145,41 @@ let rec texpr (f : Form.t) : Ast.texpr = | [ { v = Vec params; _ }; ret ] -> mk (Ast.Tfn (env, List.map texpr params, texpr ret)) | _ -> fail f "a function type is (%s [T ...] R)" which) - | List ({ v = Sym name; _ } :: args) when args <> [] -> + | List ({ v = Sym name; _ } :: args) + when args <> [] || capitalised_name name -> (* An integer argument is a generic struct's length, and a type constructor is capitalised. A lowercase head is a body form in the return slot — (+ x 1) — and its integer is the type parser's reason to give up, which is the refusal that slot is built on. *) - let capitalised = - let base = - match String.rindex_opt name '/' with - | Some i -> String.sub name (i + 1) (String.length name - i - 1) - | None -> name - in - base <> "" && Char.uppercase_ascii base.[0] = base.[0] - && Char.lowercase_ascii base.[0] <> base.[0] + let capitalised = capitalised_name name in + (* Integer arithmetic over literals is a length too — [(Small (+ 4 4) + i32)] — folded here, since nothing later reads it as a value. *) + let rec fold (a : Form.t) = + match a.v with + | Int n -> Some n + | List ({ v = Sym (("+" | "-" | "*") as op); _ } :: (_ :: _ as xs)) -> + let vs = List.map fold xs in + if List.for_all Option.is_some vs then + let vs = List.map Option.get vs in + match op, vs with + | "-", [ x ] -> Some (Int64.neg x) + | "+", v :: rest -> Some (List.fold_left Int64.add v rest) + | "-", v :: rest -> Some (List.fold_left Int64.sub v rest) + | "*", v :: rest -> Some (List.fold_left Int64.mul v rest) + | _ -> None + else None + | _ -> None in let arg (a : Form.t) = - match a.v with - | Int n when capitalised -> { Ast.t = Ast.Tlen n; tloc = a.loc } + match a.v, fold a with + | _, Some n when capitalised -> { Ast.t = Ast.Tlen n; tloc = a.loc } + | List _, None when capitalised -> + (try texpr a with + | Loc.Error _ -> + fail a + "%s is not a type or a length. An argument here is a type, or a \ + length: an integer, a constant's name or a length variable" + (Form.to_string a)) | _ -> texpr a in mk (Ast.Tapp (name, List.map arg args)) diff --git a/lib/render.ml b/lib/render.ml index c5cf9f6d..1f16802c 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -333,7 +333,7 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis @ render c (depth + 1) v) shown) in - [ do_ ((lit ("(" ^ n ^ " {") :: parts) + [ do_ ((lit ("(" ^ Types.struct_head n ^ " {") :: parts) @ (if List.length fields > max_span then [ lit " ..." ] else []) @ [ lit "})" ]) ]) (* A fixed array's length is in its type, so it unrolls — capped, because diff --git a/lib/session.ml b/lib/session.ml index ac732970..fff0f656 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1543,7 +1543,7 @@ let render_locals ?(origin = "") t ~frame ~(fn : Tast.fn) ~bound let loc = fn.Tast.floc in let extra = ref [] and nslots = ref 0 in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -1655,7 +1655,7 @@ let render_condition t ~(st : Tast.structure) : change * (string * string) list let loc = Loc.unknown in let extra = ref [] and nslots = ref 0 in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -1916,7 +1916,7 @@ let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path | Some name -> let extra = ref [] and nslots = ref 0 in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -2233,7 +2233,7 @@ let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path in let extra = ref [] and nslots = ref (Array.length base) in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = @@ -2270,11 +2270,15 @@ let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path Array.append bnames (Array.make (List.length !extra) None) } in + (* A struct copy the values named first, laid out in this + module and kept, as [eval_expr] keeps one. *) + let copies = Check.fresh_copies t.env t.program.Tast.structs in let program = { t.program with Tast.fns = t.program.Tast.fns @ fresh @ claim_lifted t lmark tname @ [ thunk ]; + structs = t.program.Tast.structs @ copies; externs = t.program.Tast.externs @ externs } in let ir = @@ -2287,7 +2291,9 @@ let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path [eval_expr] says why, and the caller takes the same [held] around this that it takes around one. *) t.program <- - { t.program with Tast.fns = t.program.Tast.fns @ fresh }; + { t.program with + Tast.fns = t.program.Tast.fns @ fresh; + structs = t.program.Tast.structs @ copies }; Ok ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, where, Types.to_string shown.Tast.ty)))) @@ -2359,7 +2365,7 @@ let arm_restart ?(origin = "") t ~index ~(params : Types.t list) in let extra = ref [] and nslots = ref (Array.length base) in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -2400,17 +2406,22 @@ let arm_restart ?(origin = "") t ~index ~(params : Types.t list) slots = Array.append base (Array.of_list (List.rev !extra)); snames = Array.append bnames (Array.make (List.length !extra) None) } in + let copies = Check.fresh_copies t.env t.program.Tast.structs in let program = { t.program with Tast.fns = t.program.Tast.fns @ fresh @ claim_lifted t lmark tname @ [ thunk ]; + structs = t.program.Tast.structs @ copies; externs = t.program.Tast.externs @ externs } in let ir = redefinition t ~call:tname program ~fns:(List.map (fun (f : Tast.fn) -> f.Tast.name) fresh @ [ tname ]) in - t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh }; + t.program <- + { t.program with + Tast.fns = t.program.Tast.fns @ fresh; + structs = t.program.Tast.structs @ copies }; Ok ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, List.map Types.to_string params) @@ -2443,7 +2454,7 @@ let render_globals ?(origin = "") t ~(globals : Tast.global list) let loc = Loc.unknown in let extra = ref [] and nslots = ref 0 in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -2564,7 +2575,7 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = appended past [base] and collected here to size the frame below. *) let extra = ref [] and nslots = ref (Array.length base) in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; diff --git a/lib/shim.ml b/lib/shim.ml index bbcdd7be..10475b19 100644 --- a/lib/shim.ml +++ b/lib/shim.ml @@ -177,6 +177,106 @@ let prim_cty = function | "bool" -> Some "bool" | _ -> None +(* ── Generic structs ────────────────────────────────────────────────── + A defstruct whose fields introduce [$t] is a template, and C only ever sees + one of its copies: the fields with the arguments written in, laid out the + way [Check] lays the same copy out. The copy is registered here under its + written spelling, [(G u8)], which [ctype_name] turns into a C name. *) + +let sigil n = n <> "" && n.[0] = '$' +let bare n = if sigil n then String.sub n 1 (String.length n - 1) else n + +(* A template's parameters, in the order its fields first introduce them, and + whether each is a length — [Check]'s reading, repeated over the AST + because this runs before [Check] does. *) +let rec template_params ?(fuel = 16) env n = + match Hashtbl.find_opt env.structs n with + | None -> [] + | Some fs -> + let acc = ref [] in + let add m is_len = + if sigil m && not (List.mem_assoc (bare m) !acc) then + acc := (bare m, is_len) :: !acc + in + let rec walk (t : Ast.texpr) = + match t.Ast.t with + | Ast.Tname m -> add m false + | Ast.Tslice (_, e) -> walk e + | Ast.Tarray (Ast.Lname m, e) -> add m true; walk e + | Ast.Tarray (_, e) -> walk e + | Ast.Tmap (k, v) -> walk k; walk v + | Ast.Tapp (h, args) -> + let kinds = + if fuel = 0 || String.equal h n then [] + else List.map snd (template_params ~fuel:(fuel - 1) env h) + in + if List.length kinds = List.length args then + List.iter2 + (fun is_len (a : Ast.texpr) -> + match a.Ast.t with + | Ast.Tname m when is_len -> add m true + | _ -> walk a) + kinds args + else List.iter walk args + | Ast.Tfn (_, ps, r) -> List.iter walk ps; walk r + | Ast.Tlen _ -> () + in + List.iter (fun (f : Ast.field) -> walk f.Ast.fty) fs; + List.rev !acc + +let rec source (t : Ast.texpr) = + match t.Ast.t with + | Ast.Tname n -> n + | Ast.Tlen n -> Int64.to_string n + | Ast.Tapp (n, args) -> + Printf.sprintf "(%s %s)" n (String.concat " " (List.map source args)) + | Ast.Tslice (c, e) -> Printf.sprintf "[%s%s]" (if c then "const " else "") (source e) + | Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (source e) + | Ast.Tarray (Ast.Lname n, e) -> Printf.sprintf "[%s %s]" n (source e) + | Ast.Tmap (k, v) -> Printf.sprintf "(Map %s %s)" (source k) (source v) + | Ast.Tfn (env, ps, r) -> + Printf.sprintf "(%s [%s] %s)" (if env then "Fn" else "CFn") + (String.concat " " (List.map source ps)) (source r) + +(* The copy of template [n] at [args], registered and named. *) +let copy env ~loc n (args : Ast.texpr list) = + let ps = template_params env n in + if List.length ps <> List.length args then + fail loc "%s takes %d argument%s, and this gives %d" n (List.length ps) + (if List.length ps = 1 then "" else "s") (List.length args); + let key = source { Ast.t = Ast.Tapp (n, args); tloc = loc } in + if not (Hashtbl.mem env.structs key) then begin + let sub = List.combine (List.map fst ps) args in + let rec go (t : Ast.texpr) = + let k = + match t.Ast.t with + | Ast.Tname m when List.mem_assoc (bare m) sub -> + (List.assoc (bare m) sub).Ast.t + | Ast.Tname _ | Ast.Tlen _ -> t.Ast.t + | Ast.Tslice (c, e) -> Ast.Tslice (c, go e) + | Ast.Tarray (Ast.Lname m, e) when List.mem_assoc (bare m) sub -> + let l = + match (List.assoc (bare m) sub).Ast.t with + | Ast.Tlen k -> Ast.Lint k + | Ast.Tname c -> Ast.Lname c + | _ -> fail loc "%s's $%s is a length" n (bare m) + in + Ast.Tarray (l, go e) + | Ast.Tarray (l, e) -> Ast.Tarray (l, go e) + | Ast.Tmap (k, v) -> Ast.Tmap (go k, go v) + | Ast.Tapp (h, a) -> Ast.Tapp (h, List.map go a) + | Ast.Tfn (b, ps, r) -> Ast.Tfn (b, List.map go ps, go r) + in + { t with Ast.t = k } + in + Hashtbl.replace env.structs key + (List.map (fun (f : Ast.field) -> { f with Ast.fty = go f.Ast.fty }) + (Hashtbl.find env.structs n)) + end; + key + +let is_template env n = template_params env n <> [] + (* [needed] collects the structs whose typedefs this signature pulls in, in the order they were first met. Order is the program's and never a hash fold's: the object cache keys on the generated text, so a reordering would be a @@ -184,6 +284,14 @@ let prim_cty = function let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string = let t = unalias env t in match t.Ast.t with + | Ast.Tname n when Hashtbl.mem env.structs n && is_template env n -> + fail loc "%s is %s, a generic struct, which is a type only at its \ + arguments — write them, as in (%s %s)" what n n + (String.concat " " + (List.map (fun (_, l) -> if l then "8" else "i32") + (template_params env n))) + | Ast.Tapp (n, args) when Hashtbl.mem env.structs n && is_template env n -> + cty env ~needed ~loc ~what { t with Ast.t = Ast.Tname (copy env ~loc n args) } | Ast.Tname n -> (match prim_cty n with | Some c -> c @@ -269,6 +377,14 @@ let classify env ~needed ~loc ~what (t : Ast.texpr) = let t' = unalias env t in match t'.Ast.t with | Ast.Tname "string" -> (Pstr, "const char *") + (* A copy crosses behind a pointer only: by value, the Flan half this + generator writes would have to spell the copy's type, and it builds its + wrapper from struct names. *) + | Ast.Tapp (n, _) when Hashtbl.mem env.structs n && is_template env n -> + fail loc + "%s is %s, a generic struct's copy, which crosses to C behind a pointer \ + only — declare (Ptr %s) and let the C side read it" + what (source t') (source t') | Ast.Tname n when Hashtbl.mem env.structs n -> ignore (cty env ~needed ~loc ~what t'); (Pstruct n, ctype_name n) @@ -546,6 +662,8 @@ let typedefs env needed = (fun (f : Ast.field) -> match (unalias env f.Ast.fty).Ast.t with | Ast.Tname m when Hashtbl.mem env.structs m -> define m + | Ast.Tapp (m, args) when Hashtbl.mem env.structs m && is_template env m -> + define (copy env ~loc:f.Ast.floc m args) | _ -> ()) fs; Printf.bprintf b "struct %s_s { /* %s */\n" (ctype_name n) n; diff --git a/lib/types.ml b/lib/types.ml index 328909f9..a6f25857 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -229,6 +229,15 @@ let rec equal a b = and then only in how a message spells it. *) let display : (string, string) Hashtbl.t = Hashtbl.create 16 +(* A struct's name as a printed value's head: its own name, or for a generic + struct's copy the template and its arguments, [Pair i32] — so a value + prints as [(Pair i32 {.a 1 .b 2})], the way its type is written. *) +let struct_head n = + match Hashtbl.find_opt display n with + | Some d when String.length d >= 2 && d.[0] = '(' -> + String.sub d 1 (String.length d - 2) + | _ -> n + let rec to_string = function | Int k -> ikind_name k | Float k -> fkind_name k diff --git a/test/programs/generic-struct.flan b/test/programs/generic-struct.flan index f080c4e4..f295fbd8 100644 --- a/test/programs/generic-struct.flan +++ b/test/programs/generic-struct.flan @@ -83,7 +83,8 @@ (let [p (Pair 1 2) q (swapped p) r (swapped (Pair {.a 1.5 .b 2.5}))] - (println (.a q) (.b q) (.a r) (.b r))) + (println (.a q) (.b q) (.a r) (.b r)) + (println q (Pair 1 2.5))) (let [c (the (Node i64) {.v 3}) b (Node 2 (Some (addr c))) a (Node 1 (Some (addr b)))] diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 04ef62d0..005df81a 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3471,7 +3471,8 @@ let () = evaluated once: the walk reads an option's tag and then its payload, and each read used to make the call again. *) let generic_struct_out = - "60 3 4\nfalse 7.5 3\n(some 3.5) (some 2.5) 1\n2 1 2.5 1.5\n6\n\ + "60 3 4\nfalse 7.5 3\n(some 3.5) (some 2.5) 1\n2 1 2.5 1.5\n\ + (Pair i32 {.a 2 .b 1}) (Pair f64 {.a 1 .b 2.5})\n6\n\ 0 1 2\n3 2\n6\n6 3\n(some 34) none 15\n" in outputs "generic structs" "programs/generic-struct.flan" generic_struct_out; @@ -4229,6 +4230,36 @@ level "1" end in let v2 = "(defstruct Vector2 [x f32 y f32])\n" in + + (* A generic struct's copy crosses behind a pointer, as a typedef of its + own with the arguments written in, and one held by value inside a + struct is defined before that struct. clang reads the text, so the + typedef is C and not only a spelling. *) + let gsrc = + "(defstruct G [x $t count i32])\n\ + (defstruct O [v i32 inner (G u8)])\n\ + (declare-c c-g [s (Ptr (G u8))] i32 \"c_g\")\n\ + (declare-c c-o [o (Ptr O)] i32 \"c_o\")\n" + in + shim_case "declare-c: a generic struct's copy crosses behind a pointer" gsrc + [ "/* (G u8) */\n uint8_t x;\n int32_t count;\n"; "inner;\n" ]; + (match shim_of gsrc with + | c -> + let file = Filename.temp_file "flan-shim-generic" ".c" in + let oc = open_out file in + output_string oc c; + close_out oc; + if Sys.command (Printf.sprintf "clang -fsyntax-only %s" (Filename.quote file)) <> 0 + then begin + incr failures; + print_endline "FAIL declare-c: a generic struct's copy is C clang accepts" + end; + Sys.remove file + | exception Loc.Error _ -> ()); + shim_refuses "declare-c: a generic struct's copy by value" + "(defstruct G [x $t])\n(declare-c c-v [s (G u8)] i32 \"c_v\")" + "crosses to C behind a pointer only"; + let img = "(defstruct Image [data (Ptr u8) width i32 height i32])\n" in diff --git a/test/test_dev.ml b/test/test_dev.ml index fa86db9c..926c1971 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -628,6 +628,28 @@ let () = | Some { Form.v = Form.Sym "t"; _ } -> () | _ -> fail "an expression against the park reported the program live"); + (* A generic struct's copy prints the way its type is written, with the + arguments after the template's name, and [layout] answers to that + spelling. *) + let r = + request c + "(:op \"eval\" :code \"(defstruct GPair [a $t b $t])\" :file \"/tmp/buf.flan\")" + in + if status r <> "ok" then + fail "a generic struct at the daemon: %s" + (Option.value ~default:(status r) (Wire.string_field r "message")); + let r = + request c + "(:op \"eval-expr\" :code \"(GPair 1 2)\" :file \"/tmp/buf.flan\")" + in + if Wire.string_field r "value" <> Some "(GPair i32 {.a 1 .b 2})" then + fail "a generic struct's copy printed as %s" + (Option.value ~default:(status r) (Wire.string_field r "value")); + let r = request c "(:op \"layout\" :type \"GPair i32\")" in + if Wire.string_field r "type" <> Some "(GPair i32)" then + fail "layout of a copy by its printed head: %s" + (Option.value ~default:(status r) (Wire.string_field r "message")); + (* And the half that needs the process rather than only the compiler. [extra] is a global this session introduced and the first run left at 105 — the third reload's [step] does not touch it — so this is the diff --git a/test/test_flan.ml b/test/test_flan.ml index 1ab6d401..ed62a56b 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6044,6 +6044,7 @@ let () = check "a prelude copy's refusal is at the user's call" (d.Loc.dloc.Loc.file <> Prelude.file && contains d.Loc.dmsg "filter cannot be made at $t = (Vec u8)" + && not (contains d.Loc.dmsg "clone") && List.exists (fun (n : Loc.note) -> n.Loc.nloc.Loc.file = Prelude.file) d.Loc.notes)); @@ -6720,13 +6721,13 @@ let () = bound, because inside a signature that introduces one the mistake is nearly always the second spelling of the first. *) rejects_check "vec-new over a sigil that names no variable in scope" - ~needle:"this signature introduces t, so write t here" + ~needle:"this signature introduces $t, so write $t here" "(defn f [x $t] i32 (do x (let [v (vec-new $u)] (free v) 0)))"; rejects_check "and a cast over one tells the same story" - ~needle:"this signature introduces t, so write t here" + ~needle:"this signature introduces $t, so write $t here" "(defn f [x i32 d $t] $t {:where (numeric? $t)} (do d ($u x)))"; rejects_check "two variables in scope are both named" - ~needle:"introduces t and u, so write one of those" + ~needle:"introduces $t and $u, so write one of those" "(defn f [a $t b $u] i32 (do a b (let [v (vec-new $w)] (free v) 0)))"; (* Where no variable is in scope there is none to name, and the answer is the rule: a sigil binds, and only a defn signature is a binding site. *) @@ -6795,6 +6796,40 @@ let () = (defn main [] i32 (f (Pair 1 2)))"; accepts "a copy wanted where it is built takes its type from there" "(defstruct Pair [a $t b $t]) (defn f [] (Pair i64) (Pair 1 2))"; + (* A copy whose field is refused names each use that asked for it. *) + (match + checked + "(defstruct Box [f $t]) (defstruct Outer [b (Box $w)]) \ + (defn go [g (Fn [i32] i32)] i32 \ + (.x (the (Outer (Fn [i32] i32)) (zeroed))) 0)" + with + | _ -> check "a copy with a zeroed function field is refused" false + | exception Loc.Error d -> + let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in + check "a refused copy names each use that made it" + (List.mem "(Box (Fn [i32] i32)) is made here" notes + && List.mem "(Outer (Fn [i32] i32)) is made here" notes)); + rejects_check "a bare generic struct in ordinary code suggests real arguments" + ~needle:"write (Pair i32)" + "(defstruct Pair [a $t b $t]) (defn main [] i32 (let [p (the Pair (zeroed))] 0))"; + rejects_check "a generic struct applied to nothing" + ~needle:"Pair takes 1 argument, (Pair $t), and this gives 0" + "(defstruct Pair [a $t b $t]) \ + (defn main [] i32 (let [p (the (Pair) (zeroed))] 0))"; + rejects_check "a length argument that is not one" + ~needle:"(+ n 1) is not a type or a length" + "(defstruct Small [items [$n $t] count i32]) \ + (defn main [] i32 (let [n 3 p (the (Small (+ n 1) i32) (zeroed))] 0))"; + accepts "a length argument of literal arithmetic is folded" + "(defstruct Small [items [$n $t] count i32]) \ + (defn main [] i32 (let [p (the (Small (+ 1 2) i32) (zeroed))] \ + (length (.items p))))"; + accepts "two literal fields meet at the wider type" + "(defstruct Pair [a $t b $t]) \ + (defn f [] f64 (let [p (Pair 1 2.5)] (+ (.a p) (.b p))))"; + rejects_check "a callee's predicate names the caller's variable with its $" + ~needle:"passes the type variable $t, which nothing here declares ordered?" + "(defn f [s [$t]] () (sort s))"; accepts "a defonce of a generic struct's copy" "(defstruct Pair [a $t b $t]) (defonce g (Pair i32)) \ (defn main [] i32 (.a g))"; diff --git a/test/test_session.ml b/test/test_session.ml index 73ff7f35..9f206aa6 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -374,6 +374,56 @@ let () = | exception Loc.Error { Loc.dmsg = m; _ } -> fail "an expression building a generic struct was refused: %s" m); + (* And the same for the other two modules the break loop builds out of + typed-in values: a store into a frame slot, and a restart's arguments. + A copy first named in one of them is laid out there and kept. *) + (let keeps t what = + List.exists + (fun (s : Tast.structure) -> String.equal s.Tast.sname what) + t.Session.program.Tast.structs + in + let lays_out (c : Session.change) what = + has c.Session.ir ("%\"" ^ what ^ "\" = type") + in + let st, _ = Session.create ~file:"programs/reload.flan" () in + (match Session.eval st "(defstruct Pair [a $t b $t])" with + | _ -> () + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "Pair: %s" m); + (match Session.eval st "(defn holder [] i64 (let [x (the i64 0)] x))" with + | _ -> () + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "holder: %s" m); + let fn = + List.find (fun (f : Tast.fn) -> f.Tast.name = "holder") + st.Session.program.Tast.fns + in + let slot = + let r = ref (-1) in + Array.iteri (fun i n -> if n = Some "x" then r := i) fn.Tast.snames; + !r + in + (match + Session.write_slot st ~frame:0 ~fn ~slot ~path:[] + ~edits:[ ([], "(.a (Pair (the i64 5) 6))") ] + with + | Ok (c, _, _) -> + if not (lays_out c "Pair-i64") then + fail "a store's module did not carry the struct copy its value made"; + if not (keeps st "Pair-i64") then + fail "the session did not keep the struct copy a store made" + | Error why -> fail "a store building a generic struct was refused: %s" why + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a store building a generic struct was refused: %s" m); + match + Session.arm_restart st ~index:0 ~params:[ Types.Int Types.U16 ] + ~codes:[ "(.b (Pair (the u16 5) 6))" ] + with + | Ok (c, _) -> + if not (lays_out c "Pair-u16") then + fail "a restart's module did not carry the struct copy its argument made" + | Error why -> fail "a restart building a generic struct was refused: %s" why + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a restart building a generic struct was refused: %s" m); + (* The other half of "a refusal costs nothing", and the half that used to be missing: a form can check and *then* fail, in the build or at the agent, and the session that already accepted it has no way to hear about it From 8c814b39c1035238cd1ae0f5f287171df25f5820 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 17:13:12 +0700 Subject: [PATCH 07/20] .fln files open in flan-fln-mode, which evaluates, moves over, indents and edits statements, clauses and top-level forms, and every Flan mode derives from flan-base-mode --- emacs/MANUAL.md | 48 ++ emacs/flan-dape.el | 12 +- emacs/flan-fln-mode.el | 1449 +++++++++++++++++++++++++++++++++++ emacs/flan-mode.el | 57 +- emacs/flan-watch.el | 10 +- emacs/flan.el | 15 +- emacs/test-flan-cider.el | 5 + emacs/test-flan-fln-live.el | 171 +++++ emacs/test-flan-fln.el | 647 ++++++++++++++++ emacs/test-flan.el | 7 + spec-syntax.md | 4 + 11 files changed, 2393 insertions(+), 32 deletions(-) create mode 100644 emacs/flan-fln-mode.el create mode 100644 emacs/test-flan-fln-live.el create mode 100644 emacs/test-flan-fln.el diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 7c4a4b01..872c6199 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -1178,6 +1178,53 @@ Use `C-c C-g` if you need frames. --- +## Indented files (.fln) + +`.fln` files open in `flan-fln-mode`. The session keys (`C-c C-b`, `C-c C-i`, +`C-c C-k`, the REPL, watch, dape) work as in a `.flan` file; these differ. + +| Holy | Evil | Does | +|---|---|---| +| `C-c C-c`, `C-M-x` | same | the top-level form: a declaration installed, anything else evaluated | +| `C-u C-c C-c` | same | ...and stop at the innermost bracket group, else the statement on point's line (`C-u C-u`: on entry) | +| `C-x C-e` | same, cursor on the line's last character | at a line's end, the innermost statement ending there; elsewhere, the term before point | +| `C-c C-e` | same | the statement at point with its body and clauses, or the region's whole lines; on a bare `let x = v`, the `let` and the rest of its block | +| `C-c C-n` | same | `C-c C-e`, then move to the next statement | +| `C-c C-k` | same | the whole buffer | +| `C-M-a` / `C-M-e` / `C-M-h` | `[[` / `]]` | top-level form: start, end, mark | +| `M-a` / `M-e` | `(` / `)` | statement: start / end (`)`: start of the next) | +| `C-M-u` | same | up to the enclosing bracket, or the line that owns the block | +| `C-M-f` / `C-M-b` | same | brackets and terms, as everywhere | +| `TAB` | same | deepest valid column first; each repeat steps out a level | +| `DEL` in indentation | same | drop one level | +| `C-c <` / `C-c >` | `<` / `>` | shift the region's lines a level | +| `M-` / `M-` | same | move the statement past its neighbour | +| `M-` / `M-` | same | pull the next statement into this block / push its last one out | +| `M-r` | same | replace the block's owner with the statement at point | +| `M-k` | `das` | kill the statement's lines | +| — | `ie` `ae` | term | +| — | `is` `as` | statement (`as`: whole lines) | +| — | `ii` `ai` | body / whole statement | +| — | `ik` `ak` | clause's block / clause | +| — | `id` `ad` | top-level form (`ad`: with the blank lines after it) | + +`else`, `elif`, `on` and `restart` snap to their header's column as you type +them. `indent-region` and `C-y` move lines only as a block, never one line +against another. expand-region steps term, group, statement, clause, +enclosing statement, top-level form. + +- **term**: a run with no space outside brackets — `f(a, b)`, `grid[r, c]`, `p.x`. +- **group**: a bracket pair and what is inside it. +- **statement**: a line, the deeper lines under it, lines inside brackets it leaves open, lines an operator continues, and `else`/`elif`/`on`/`restart` at its column. Blank and comment lines inside never end it. +- **body**: a statement's own block, up to its first clause. +- **clause**: one `else`/`elif`/`on`/`restart` line and its block. +- **top-level form**: a column-0 line that is code, not a clause and not a continuation, through the last code line before the next one. + +`flan-fln-indent-offset` (2) is one level. `flan-fln-smartparens` (`t`) turns +on plain `smartparens-mode`, which pairs brackets and strings but not `'`. + +--- + ## Full key reference | Key | Does | @@ -1257,6 +1304,7 @@ fix is to delete `-dev` from it. | File | What it is | |---|---| | `flan-mode.el` | the major mode: syntax, indentation, imenu, the keymap | +| `flan-fln-mode.el` | the mode for indented `.fln` files: objects, keys, indentation | | `flan.el` | the client — the socket, evaluation, xref, eldoc, completion | | `flan-repl.el` | the `*flan-repl*` buffer | | `flan-watch.el` | watched values: the program pushes, this paints them in a buffer and inline | diff --git a/emacs/flan-dape.el b/emacs/flan-dape.el index 4ba767be..9f55a19a 100644 --- a/emacs/flan-dape.el +++ b/emacs/flan-dape.el @@ -89,14 +89,14 @@ does and does not buy." :type '(repeat string)) (defun flan-dape--source () - "The .flan file this session is about. + "The .flan or .fln file this session is about. The buffer's own file, or the nearest one up from it — so M-x flan-debug from a *compilation* buffer or a dired still has an answer." (or (and buffer-file-name - (string-suffix-p ".flan" buffer-file-name) + (string-match-p "\\.fla?n\\'" buffer-file-name) buffer-file-name) - (car (directory-files default-directory t "\\.flan\\'")) - (user-error "No .flan file here to debug"))) + (car (directory-files default-directory t "\\.fla?n\\'")) + (user-error "No .flan or .fln file here to debug"))) (defun flan-dape--binary (source) "Where the debug build of SOURCE goes. @@ -126,7 +126,7 @@ one made by `flan build'." ;; can just read `buffer-file-name'. `dape' itself expects an already ;; evaluated config, so `flan-debug' below must not hand it the raw entry. (defconst flan-dape-config - '(modes (flan-mode) + '(modes (flan-base-mode) ensure dape-ensure-command command-cwd dape-command-cwd compile (flan-dape--compile-command (flan-dape--source)) @@ -178,7 +178,7 @@ common case is one command rather than a config prompt." ;; thing entirely. ;;;###autoload (with-eval-after-load 'flan-mode - (define-key (symbol-value 'flan-mode-map) (kbd "C-c C-g") #'flan-debug)) + (define-key (symbol-value 'flan-base-mode-map) (kbd "C-c C-g") #'flan-debug)) ;;; --dev and --debug are different builds ;; diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el new file mode 100644 index 00000000..d9182a64 --- /dev/null +++ b/emacs/flan-fln-mode.el @@ -0,0 +1,1449 @@ +;;; flan-fln-mode.el --- Major mode for indented Flan (.fln) -*- lexical-binding: t; -*- + +;; Author: Joseph Ferano +;; Version: 0.1.0 +;; Package-Requires: ((emacs "29.1")) +;; Keywords: languages, tools + +;; The mode for the indented syntax (spec-syntax.md). It shares everything +;; that talks to the running program with `flan-mode' through their parent, +;; `flan-base-mode', and owns the one thing that differs: what a piece of the +;; text is. +;; +;; Nothing here parses Flan. Every object is found from lines, columns and +;; the syntax table: a statement is a line and the lines under it, a term is a +;; run with no space outside brackets. The reader decides what the text +;; means; this only decides which text to send, and sends it unchanged with +;; the line and column it starts at. +;; +;; The objects, smallest first: +;; +;; term a run with no space in it outside brackets: `x', `f(a, b)', +;; `grid[r, c]', `camera.target.x'. +;; group a bracket pair and what is inside it. +;; statement a line, the deeper lines under it, the lines inside brackets it +;; leaves open, the lines an operator continues, and the +;; `else'/`elif'/`on'/`restart' clauses at its own column. Blank +;; and comment lines inside never end it; trailing ones are not +;; part of it. +;; body a statement's own block: the deeper lines under its first line, +;; up to its first clause. +;; clause one `else'/`elif'/`on'/`restart' line and its block. +;; top-level a column-0 statement start and everything to the next one. + +;;; Code: + +(require 'flan-mode) +(require 'thingatpt) +(require 'seq) + +;; The client, which every command that sends code needs and which this file +;; must not load merely to edit one. +(declare-function flan--eval "flan" (code what &optional start end pause)) +(declare-function flan--eval-expression "flan" (start end arg)) +(declare-function flan--text "flan" (start end)) +(defvar flan--declaration-heads) +(defvar flan--defun-heads) +;; Set buffer-locally when the packages are there; declared so the setq-local +;; below does not make a stray global. +(defvar er/try-expand-list) +(defvar evil-shift-width) +(defvar evil-state) +(declare-function smartparens-mode "smartparens" (&optional arg)) +(declare-function sp-local-pair "smartparens" (modes open close &rest args)) +(declare-function evil-define-key* "evil-core" (state keymap key def &rest bindings)) +(declare-function evil-range "evil-common" (beg end &optional type &rest properties)) + +(defcustom flan-fln-indent-offset 2 + "Columns one block level adds in a .fln file." + :type 'integer + :group 'flan) + +(defcustom flan-fln-smartparens t + "Turn on plain `smartparens-mode' in .fln buffers, when it is installed. +Plain rather than strict: strict mode keeps s-expressions balanced, and a +.fln file's blocks are not s-expressions, so it would refuse edits that are +fine here. Brackets and strings are still paired." + :type 'boolean + :group 'flan) + +;;; Words + +;; The spaced binary operators of lib/indent_reader.ml (`binops'). A line +;; that starts with one, or follows a line that ends with one, continues the +;; line above. +(defconst flan-fln--binops + '("or" "and" "==" "!=" "<" "<=" ">" ">=" "<<" ">>" "+" "-" "*" "/" "%")) + +(defconst flan-fln--binop-re (regexp-opt flan-fln--binops)) + +(defconst flan-fln--clause-words '("else" "elif" "on" "restart") + "Words that start a clause of the statement above, at its column.") + +(defconst flan-fln--clause-re + "\\(else\\|elif\\|on\\|restart\\)\\(?:[ \t]\\|$\\)") + +(defconst flan-fln--clause-headers + '(("else" "if" "elif") ("elif" "if" "elif") + ("on" "handler-case" "handler-bind" "on") + ("restart" "restart-case" "restart")) + "For each clause word, the words of the lines it may sit under.") + +;; `header_follow' in lib/indent_reader.ml: the words a statement starts with. +(defconst flan-fln--header-words + '("fn" "fn-" "def" "once" "const" "struct" "union" "data" "enum" "import" + "if" "elif" "else" "while" "until" "for" "match" "let" "return" "break" + "continue" "defer" "handler-case" "handler-bind" "restart-case" "on" + "restart" "quote")) + +;; The headers whose block follows on the lines under them. `defer' and +;; `quote' open one only when nothing follows them on the line; `fn' does not +;; when it is the one-line `fn f(x) = e'; `if' does not when it is the one-line +;; `if c then a else b'. +(defconst flan-fln--opener-words + '("fn" "fn-" "struct" "union" "data" "enum" "if" "elif" "else" "while" + "until" "for" "match" "defer" "handler-case" "handler-bind" + "restart-case" "on" "restart" "quote")) + +(defconst flan-fln--declaration-words + '(("fn" . "defn") ("fn-" . "defn-") ("def" . "def") ("once" . "defonce") + ("const" . "defconst") ("struct" . "defstruct") ("data" . "defdata") + ("enum" . "defenum") ("union" . "defunion") ("import" . "import")) + "Each declaration header word, and the paren head it reads as.") + +;;; Syntax + +(defvar flan-fln-mode-syntax-table + (let ((table (make-syntax-table))) + ;; Name characters: a name is anything up to a delimiter (`is_delimiter' + ;; in lib/reader.ml), so `key-pressed?', `dyn->f64' and `rl/draw-fps' are + ;; one symbol each. `:' too, so `:key-r' is one; the colon of `x: T' is + ;; glued to the name and is trimmed off a term where it matters. + (dolist (c '(?- ?_ ?? ?! ?/ ?. ?$ ?& ?* ?+ ?< ?> ?= ?% ?: ?@ ?# ?^ ?| ?~)) + (modify-syntax-entry c "_" table)) + (modify-syntax-entry ?\; "<" table) + (modify-syntax-entry ?\n ">" table) + (modify-syntax-entry ?\" "\"" table) + ;; `\c' is a character literal, `\(' included: escaping it keeps the + ;; paren out of the bracket count. + (modify-syntax-entry ?\\ "\\" table) + (modify-syntax-entry ?' "'" table) + ;; A comma separates, so it is not part of any term. + (modify-syntax-entry ?, "." table) + (modify-syntax-entry ?\( "()" table) + (modify-syntax-entry ?\) ")(" table) + (modify-syntax-entry ?\[ "(]" table) + (modify-syntax-entry ?\] ")[" table) + (modify-syntax-entry ?{ "(}" table) + (modify-syntax-entry ?} "){" table) + table) + "Syntax table for `flan-fln-mode'.") + +;;; Lines + +;; Every object is built from these. A position argument names the line it +;; is on; each answers for that line and leaves point alone. + +(defun flan-fln--bol (pos) + (save-excursion (goto-char pos) (line-beginning-position))) + +(defun flan-fln--indent-at (pos) + (save-excursion (goto-char pos) (current-indentation))) + +(defun flan-fln--first-char (pos) + "Where the text of POS's line starts." + (save-excursion (goto-char pos) (back-to-indentation) (point))) + +(defun flan-fln--in-open-p (pos) + "Non-nil if POS's line starts inside a bracket or a string." + (let ((s (save-excursion (syntax-ppss (flan-fln--bol pos))))) + (or (> (car s) 0) (nth 3 s)))) + +(defun flan-fln--blank-p (pos) + "Non-nil if POS's line holds no code: it is blank, or only a comment." + (save-excursion + (goto-char (flan-fln--bol pos)) + (and (not (nth 3 (syntax-ppss (point)))) + (progn (skip-chars-forward " \t") + (or (eolp) (eq (char-after) ?\;)))))) + +(defun flan-fln--code-end (pos) + "Where the code on POS's line ends: before a trailing comment and spaces." + (save-excursion + (goto-char pos) + (let* ((bol (line-beginning-position)) + (eol (line-end-position)) + (s (syntax-ppss eol))) + (goto-char (if (and (nth 4 s) (>= (nth 8 s) bol)) (nth 8 s) eol)) + (skip-chars-backward " \t" bol) + (point)))) + +(defun flan-fln--ends-in-op-p (pos) + "Non-nil if POS's line ends in a spaced binary operator." + (save-excursion + (let ((end (flan-fln--code-end pos))) + (goto-char end) + (and (not (nth 3 (syntax-ppss end))) + (looking-back (concat "\\(?:^\\|[ \t]\\)" flan-fln--binop-re) + (line-beginning-position)))))) + +(defun flan-fln--starts-with-op-p (pos) + "Non-nil if POS's line starts with a spaced binary operator." + (save-excursion + (goto-char pos) + (back-to-indentation) + (looking-at (concat flan-fln--binop-re "\\(?:[ \t]\\|$\\)")))) + +(defun flan-fln--prev-code (pos) + "The start of the nearest code line above POS's line, or nil." + (save-excursion + (goto-char pos) + (let (hit) + (while (and (not hit) (zerop (forward-line -1))) + (unless (flan-fln--blank-p (point)) (setq hit (point)))) + hit))) + +(defun flan-fln--next-code (pos) + "The start of the nearest code line below POS's line, or nil." + (save-excursion + (goto-char pos) + (let (hit) + (while (and (not hit) (zerop (forward-line 1)) (not (eobp))) + (unless (flan-fln--blank-p (point)) (setq hit (point)))) + ;; The last line of a buffer with no final newline: `forward-line' + ;; reports it could not move a whole line, but it did reach it. + (when (and (not hit) (eobp) (not (bolp)) + (> (line-beginning-position) (flan-fln--bol pos)) + (not (flan-fln--blank-p (point)))) + (setq hit (line-beginning-position))) + hit))) + +(defun flan-fln--continuation-p (pos) + "Non-nil if POS's line continues the line above it. +Inside a bracket or a string, after a line that ends in a spaced operator, or +starting with one: the reader's three ways a line break is not a new line." + (or (flan-fln--in-open-p pos) + (flan-fln--starts-with-op-p pos) + (let ((p (flan-fln--prev-code pos))) + (and p (flan-fln--ends-in-op-p p))))) + +(defun flan-fln--clause-line-p (pos) + "Non-nil if POS's line starts a clause: else, elif, on or restart. +A word, and only when a space or the end of the line follows it." + (and (not (flan-fln--continuation-p pos)) + (save-excursion + (goto-char pos) + (back-to-indentation) + (looking-at flan-fln--clause-re)))) + +(defun flan-fln--logical-start (pos) + "The first line of the line POS is on, after continuation lines are joined." + (let ((bol (flan-fln--bol pos)) p) + (while (and (flan-fln--continuation-p bol) + (setq p (flan-fln--prev-code bol))) + (setq bol p)) + bol)) + +(defun flan-fln--logical-end (pos) + "The last line of the joined line whose first line is POS's." + (let ((bol (flan-fln--bol pos)) n) + (while (and (setq n (flan-fln--next-code bol)) + (flan-fln--continuation-p n)) + (setq bol n)) + bol)) + +;;; Statements + +(defun flan-fln--statement-last (start &optional no-clauses) + "The last code line of the statement whose first line is START. +With NO-CLAUSES, stop before the first clause at START's column: the first +line's own block only." + (let* ((indent (flan-fln--indent-at start)) + (last (flan-fln--logical-end start)) + (next (flan-fln--next-code last))) + (while (and next + (or (> (flan-fln--indent-at next) indent) + (flan-fln--continuation-p next) + (and (not no-clauses) + (= (flan-fln--indent-at next) indent) + (flan-fln--clause-line-p next)))) + (setq last (flan-fln--logical-end next) + next (flan-fln--next-code last))) + last)) + +(defun flan-fln--span (start last) + "(BEG . END) from the text of START's line to the code end of LAST's." + (cons (flan-fln--first-char start) (flan-fln--code-end last))) + +(defun flan-fln--statement-bounds (start) + "Bounds of the statement whose first line is START." + (flan-fln--span start (flan-fln--statement-last start))) + +(defun flan-fln--clause-header (start) + "The header line the clause at START belongs to, or START if it is not one." + (if (not (flan-fln--clause-line-p start)) + start + (let ((ind (flan-fln--indent-at start)) (p start) hit) + (while (and (not hit) (setq p (flan-fln--prev-code p))) + (setq p (flan-fln--logical-start p)) + (let ((i (flan-fln--indent-at p))) + (cond ((< i ind) (setq hit start)) + ((and (= i ind) (not (flan-fln--clause-line-p p))) + (setq hit p))))) + (or hit start)))) + +(defun flan-fln--code-line-at (pos) + "POS's line if it holds code, else the code line above, else the one below." + (let ((bol (flan-fln--bol pos))) + (if (flan-fln--blank-p bol) + (or (flan-fln--prev-code bol) (flan-fln--next-code bol)) + bol))) + +(defun flan-fln--line-statement (pos) + "The first line of the statement POS's line starts or continues. +A clause line answers for itself." + (let ((l (flan-fln--code-line-at pos))) + (and l (flan-fln--logical-start l)))) + +(defun flan-fln--statement-start-at (pos) + "The first line of the statement at POS; a clause gives its header's." + (let ((l (flan-fln--line-statement pos))) + (and l (flan-fln--clause-header l)))) + +(defun flan-fln--parent (start) + "The nearest line above START that is shallower: its block's owner, or nil. +A clause line owns its own block, so it can be the answer." + (let ((ind (flan-fln--indent-at start)) (p start) hit) + (when (> ind 0) + (while (and (not hit) (setq p (flan-fln--prev-code p))) + (setq p (flan-fln--logical-start p)) + (when (< (flan-fln--indent-at p) ind) (setq hit p)))) + hit)) + +(defun flan-fln--body-bounds (start) + "Bounds of the block under START's first line, or nil when it has none." + (let* ((head-last (flan-fln--logical-end start)) + (first (flan-fln--next-code head-last))) + (when (and first (> (flan-fln--indent-at first) (flan-fln--indent-at start))) + (flan-fln--span first (flan-fln--statement-last start t))))) + +(defun flan-fln--clause-at (pos) + "The clause line whose clause holds POS, the innermost one, or nil." + (let* ((line (flan-fln--line-statement pos)) + (p line) + (limit (and line (1+ (flan-fln--indent-at line)))) + hit) + (while (and p (not hit)) + (let ((i (flan-fln--indent-at p))) + (when (< i limit) + (if (flan-fln--clause-line-p p) + (setq hit p) + (setq limit i))) + (setq p (and (> limit 0) + (let ((q (flan-fln--prev-code p))) + (and q (flan-fln--logical-start q))))))) + hit)) + +(defun flan-fln--clause-bounds (start) + (flan-fln--span start (flan-fln--statement-last start t))) + +;;; Top-level forms + +(defun flan-fln--toplevel-start-p (pos) + "Non-nil if POS's line starts a top-level form. +Column 0 and code, and not a clause, an operator continuation, or a line +inside a bracket or a string -- spec-syntax.md §4.5, tightened." + (and (not (flan-fln--blank-p pos)) + (zerop (flan-fln--indent-at pos)) + (not (flan-fln--continuation-p pos)) + (not (flan-fln--clause-line-p pos)))) + +(defun flan-fln--toplevel-start (pos) + "The first line of the top-level form at or before POS, else the next one." + (save-excursion + (goto-char (flan-fln--bol pos)) + (let (hit) + (while (and (not hit) + (progn (when (flan-fln--toplevel-start-p (point)) + (setq hit (point))) + (not hit)) + (zerop (forward-line -1)))) + (unless hit + (goto-char (flan-fln--bol pos)) + (while (and (not hit) (zerop (forward-line 1)) (not (eobp))) + (when (flan-fln--toplevel-start-p (point)) (setq hit (point))))) + hit))) + +(defun flan-fln--toplevel-last (start) + "The last code line of the top-level form starting at START." + (save-excursion + (goto-char start) + (let ((last start)) + (while (and (zerop (forward-line 1)) (not (eobp)) + (not (flan-fln--toplevel-start-p (point)))) + (unless (flan-fln--blank-p (point)) (setq last (point)))) + ;; A last line with no newline after it. + (when (and (eobp) (not (bolp)) + (not (flan-fln--toplevel-start-p (line-beginning-position))) + (not (flan-fln--blank-p (point)))) + (setq last (line-beginning-position))) + last))) + +(defun flan-fln--toplevel-bounds (pos) + "Bounds of the top-level form at POS, or nil in a buffer with none." + (let ((s (flan-fln--toplevel-start pos))) + (and s (flan-fln--span s (flan-fln--toplevel-last s))))) + +(defun flan-fln--beginning-of-defun (&optional arg) + "Move to the start of the ARGth top-level form back; forward when negative. +For `beginning-of-defun-function'." + (setq arg (or arg 1)) + (let ((found t)) + (if (> arg 0) + (dotimes (_ arg) + (let ((here (point)) hit) + (beginning-of-line) + (when (and (< (point) here) (flan-fln--toplevel-start-p (point))) + (setq hit t)) + (while (and (not hit) (zerop (forward-line -1))) + (when (flan-fln--toplevel-start-p (point)) (setq hit t))) + (unless hit (setq found nil)))) + (dotimes (_ (- arg)) + (let (hit) + (while (and (not hit) (zerop (forward-line 1)) (not (eobp))) + (when (flan-fln--toplevel-start-p (point)) (setq hit t))) + (unless hit (setq found nil))))) + found)) + +(defun flan-fln--end-of-defun () + "From the start of a top-level form, move to its end. +For `end-of-defun-function'." + (goto-char (cdr (flan-fln--span (point) (flan-fln--toplevel-last (point)))))) + +;;; Terms and groups + +(defun flan-fln--term-forward (pos) + (save-excursion + (goto-char pos) + (let (done) + (while (and (not done) (not (eobp))) + (let ((c (char-after)) + (syn (syntax-class (syntax-after (point))))) + (cond ((memq c '(?\s ?\t ?\n ?, ?\;)) (setq done t)) + ((eq c ?\\) (forward-char (min 2 (- (point-max) (point))))) + ((memq syn '(4 7)) + (condition-case nil (forward-sexp 1) + (scan-error (setq done t)))) + ((eq syn 5) (setq done t)) + (t (forward-char 1))))) + (point)))) + +(defun flan-fln--term-back (pos) + (save-excursion + (goto-char pos) + (let (done) + (while (and (not done) (not (bobp))) + (let ((c (char-before)) + (syn (syntax-class (syntax-after (1- (point)))))) + (cond ((and (> (1- (point)) (point-min)) + (eq (char-before (1- (point))) ?\\)) + (backward-char 2)) + ((memq c '(?\s ?\t ?\n ?,)) (setq done t)) + ((eq syn 4) (setq done t)) + ((memq syn '(5 7)) + (condition-case nil (backward-sexp 1) + (scan-error (setq done t)))) + (t (backward-char 1))))) + (point)))) + +(defun flan-fln--trim-colon (beg end) + "END, less the trailing colon of `x:' or `f(x):' when BEG..END has one." + (if (and (> end (1+ beg)) (eq (char-before end) ?:) + (not (eq (char-after beg) ?:))) + (1- end) + end)) + +(defun flan-fln--term-bounds (pos) + "Bounds of the term at POS: a run with no space in it outside brackets." + (let ((s (save-excursion (syntax-ppss pos)))) + (unless (nth 4 s) + (let* ((pos (if (nth 3 s) (nth 8 s) pos)) + (beg (flan-fln--term-back pos)) + (end (flan-fln--trim-colon beg (flan-fln--term-forward pos)))) + (and (< beg end) (cons beg end)))))) + +(defun flan-fln--term-before (pos) + "Bounds of the term that ends at POS, spaces before POS skipped, or nil." + (save-excursion + (goto-char pos) + (skip-chars-backward " \t,") + (let* ((end (point)) + (beg (flan-fln--term-back end)) + (end (flan-fln--trim-colon beg end))) + (and (< beg end) (cons beg end))))) + +(defun flan-fln--group-bounds (pos) + "Bounds of the innermost bracket pair around POS, or nil." + (let ((open (nth 1 (save-excursion (syntax-ppss pos))))) + (and open (cons open (ignore-errors (scan-lists open 1 0)))))) + +(defun flan-fln--group-form-start (open) + "Where the reader starts the form the bracket at OPEN belongs to. +A bracket glued to what is before it is a call, an index or a struct literal, +and the form starts where that term does (`f' of `f(x)', not the paren). A +free `(' groups one value and the form is that value. A free `[' or `{' is +the form." + (let ((before (char-before open))) + (cond + ((and before (not (memq before '(?\s ?\t ?\n ?, ?\( ?\[ ?\{)))) + (let ((b (flan-fln--term-back open))) + ;; `-f(x)' reads as the negation of the call, and the call starts at f. + (if (and (eq (char-after b) ?-) + (string-match-p "[a-zA-Z$_*]" (string (char-after (1+ b))))) + (1+ b) + b))) + ((eq (char-after open) ?\() + (save-excursion + (goto-char (1+ open)) + (skip-chars-forward " \t\n") + (if (eq (char-after) ?\)) open (point)))) + (t open)))) + +;;; Declarations + +(defun flan-fln--declaration-head-at (pos &optional heads) + "The paren head of the declaration written at POS, or nil. +The .fln twin of `flan--declaration-head-at': POS must be at column 0 and not +in a string or comment, and the header word -- `fn', `def', `struct', ... -- +or the fallback call's name, `defmethod(', must read as one of HEADS, +`flan--declaration-heads' by default." + (save-excursion + (let ((state (syntax-ppss pos))) + (goto-char pos) + (and (zerop (current-column)) + (zerop (car state)) + (not (nth 8 state)) + (let ((head + (cond + ((looking-at (concat (regexp-opt (mapcar #'car flan-fln--declaration-words) t) + "[ \t]")) + (cdr (assoc (match-string-no-properties 1) + flan-fln--declaration-words))) + ((looking-at "\\([^][ \t\n(){},;\":]+\\)(") + (match-string-no-properties 1))))) + (and head (member head (or heads flan--declaration-heads)) head)))))) + +;;; Sending + +(defun flan-fln--client () + (require 'flan)) + +(defun flan-fln--send (beg end arg heads) + "Send BEG..END: installed when it is a declaration at column 0, else run. +HEADS says which heads count as declarations. ARG is a prefix: on a +declaration it marks the whole form (stop on entry), on an expression it is +the stop-here flag." + (let ((head (flan-fln--declaration-head-at beg heads))) + (if head + (flan--eval (flan--text beg end) head beg end (and arg (cons beg end))) + (prog1 (flan--eval-expression beg end arg) + (pulse-momentary-highlight-region beg end))))) + +(defun flan-fln--pause-bounds (b arg) + "The form to mark inside the top-level form B for prefix ARG, or nil. +One `C-u': the innermost bracket group around point -- the form it belongs +to, from where the reader starts it -- else the statement on point's line. +Two: B itself, which stops on entry." + (cond + ((null arg) nil) + ((and (consp arg) (> (prefix-numeric-value arg) 4)) b) + (t (or (flan-fln--pause-target (point) b) b)))) + +(defun flan-fln--pause-target (pos b) + (let ((g (flan-fln--group-bounds pos))) + (if (and g (cdr g) (> (car g) (car b))) + (cons (flan-fln--group-form-start (car g)) (cdr g)) + (let ((s (flan-fln--statement-start-at pos))) + (and s (flan-fln--statement-bounds s)))))) + +;;;###autoload +(defun flan-fln-eval-defun (&optional arg) + "Evaluate the top-level form at point in the running program. +A declaration is installed and anything else is evaluated, as `C-c C-c' does +in a .flan file. With one \\[universal-argument] on a declaration, also stop +at the innermost bracket group around point, or else at the statement on +point's line, when it next runs; with two, on entry." + (interactive "P") + (flan-fln--client) + (let ((b (flan-fln--toplevel-bounds (point)))) + (unless b (user-error "flan: no top-level form at point to evaluate")) + (let ((head (flan-fln--declaration-head-at (car b) flan--defun-heads))) + (if head + (flan--eval (flan--text (car b) (cdr b)) head (car b) (cdr b) + (flan-fln--pause-bounds b arg)) + (prog1 (flan--eval-expression (car b) (cdr b) arg) + (pulse-momentary-highlight-region (car b) (cdr b))))))) + +(defun flan-fln--point-for-last () + "Point, or under Evil's normal state the position after the cursor's char. +The cursor sits *on* the last character of a line, never after it." + (if (and (bound-and-true-p evil-local-mode) + (memq evil-state '(normal motion)) + (not (eolp))) + (1+ (point)) + (point))) + +(defun flan-fln--statement-ending-at (pos) + "Bounds of the innermost statement whose last line is POS's, or nil." + (let ((l (flan-fln--line-statement pos))) + (when (and l (not (flan-fln--blank-p pos)) (not (flan-fln--clause-line-p l)) + (= (flan-fln--statement-last l) (flan-fln--bol pos))) + (flan-fln--statement-bounds l)))) + +;;;###autoload +(defun flan-fln-eval-last (&optional arg) + "Evaluate the statement that ends at point, or the term before point. +At the end of a line, the innermost statement whose last line it is; a +declaration at column 0 is installed. Anywhere else, the term that ends +before point. With ARG, stop there instead, as \\[flan-eval-last-sexp] does." + (interactive "P") + (flan-fln--client) + (let* ((end (flan-fln--point-for-last)) + (st (and (>= end (flan-fln--code-end end)) + (flan-fln--statement-ending-at end)))) + (if st + (flan-fln--send (car st) (cdr st) arg flan--declaration-heads) + (let ((tb (flan-fln--term-before end))) + (unless tb (user-error "flan: no form before point to evaluate")) + (flan--eval-expression (car tb) (cdr tb) arg))))) + +(defun flan-fln--snap-lines (beg end) + "BEG..END widened to whole lines, less leading blank lines and trailing space." + (let ((first (flan-fln--bol beg)) + (last (flan-fln--bol (if (and (> end beg) + (save-excursion (goto-char end) (bolp))) + (1- end) + end)))) + (when (flan-fln--blank-p first) (setq first (flan-fln--next-code first))) + (when (and first (<= first last)) + (cons (flan-fln--first-char first) + (save-excursion (goto-char last) (end-of-line) + (skip-chars-backward " \t\n" first) (point)))))) + +(defun flan-fln--bare-let-p (start) + "Non-nil if START's statement is a `let' with no block of its own." + (and (save-excursion (goto-char (flan-fln--first-char start)) + (looking-at "let[ \t]")) + (= (flan-fln--statement-last start) (flan-fln--logical-end start)))) + +(defun flan-fln--block-rest (start) + "START's statement and every statement after it in the same block." + (let* ((ind (flan-fln--indent-at start)) + (last (flan-fln--statement-last start)) + (next (flan-fln--next-code last))) + (while (and next (= (flan-fln--indent-at next) ind) + (not (flan-fln--clause-line-p next))) + (setq last (flan-fln--statement-last next) + next (flan-fln--next-code last))) + (flan-fln--span start last))) + +(defun flan-fln--statement-to-send (pos) + "The statement at POS as sent by `C-c C-e': with its body and clauses, and +for a bare `let x = v', with the rest of its block, which is its scope." + (let ((s (flan-fln--statement-start-at pos))) + (and s (if (flan-fln--bare-let-p s) + (flan-fln--block-rest s) + (flan-fln--statement-bounds s))))) + +;;;###autoload +(defun flan-fln-eval-statement (&optional arg) + "Evaluate the statement at point, with its body and clauses. +With an active region, the lines it touches instead. On a bare `let x = v', +the `let' and the rest of its block, which is what it is in scope for; the +span sent is flashed so the extent is visible. A declaration at column 0 is +installed. ARG is as for \\[flan-fln-eval-last]." + (interactive "P") + (flan-fln--client) + (let ((b (if (use-region-p) + (flan-fln--snap-lines (region-beginning) (region-end)) + (flan-fln--statement-to-send (point))))) + (unless b (user-error "flan: no statement at point to evaluate")) + (when (use-region-p) (deactivate-mark)) + (flan-fln--send (car b) (cdr b) arg flan--defun-heads))) + +;;;###autoload +(defun flan-fln-eval-statement-and-next () + "Evaluate the statement at point, then move to the statement after it." + (interactive) + (flan-fln--client) + (let ((b (flan-fln--statement-to-send (point)))) + (unless b (user-error "flan: no statement at point to evaluate")) + (prog1 (flan-fln--send (car b) (cdr b) nil flan--defun-heads) + (let ((n (flan-fln--next-code (cdr b)))) + (goto-char (if n (flan-fln--first-char n) (cdr b))))))) + +;;; Motion + +(defun flan-fln-backward-statement (&optional n) + "Move to the start of the statement at point, or to the one before it. +Before it at the same level, else out to the line that owns this block." + (interactive "^p") + (dotimes (_ (or n 1)) + (let* ((l (flan-fln--line-statement (point))) + (here (and l (flan-fln--first-char l)))) + (cond + ((null l)) + ((> (point) here) (goto-char here)) + (t + (let ((ind (flan-fln--indent-at l)) (p l) hit) + (while (and (not hit) (setq p (flan-fln--prev-code p))) + (setq p (flan-fln--logical-start p)) + (when (<= (flan-fln--indent-at p) ind) + (setq hit (if (= (flan-fln--indent-at p) ind) + (flan-fln--clause-header p) + p)))) + (when hit (goto-char (flan-fln--first-char hit))))))))) + +(defun flan-fln-forward-statement (&optional n) + "Move to the end of the statement at point, or of the one after it." + (interactive "^p") + (dotimes (_ (or n 1)) + (let* ((s (flan-fln--statement-start-at (point))) + (e (and s (cdr (flan-fln--statement-bounds s))))) + (cond + ((null s)) + ((< (point) e) (goto-char e)) + (t (let ((nx (flan-fln--next-code (flan-fln--statement-last s)))) + (when nx + (goto-char (cdr (flan-fln--statement-bounds + (flan-fln--clause-header + (flan-fln--logical-start nx)))))))))))) + +(defun flan-fln-next-statement (&optional n) + "Move to the start of the statement after the one at point." + (interactive "^p") + (dotimes (_ (or n 1)) + (let* ((s (flan-fln--statement-start-at (point))) + (nx (and s (flan-fln--next-code (flan-fln--statement-last s))))) + (when nx (goto-char (flan-fln--first-char nx)))))) + +(defun flan-fln-up (&optional n) + "Move up to the bracket around point, or to the line that owns its block." + (interactive "^p") + (dotimes (_ (or n 1)) + (let ((open (nth 1 (syntax-ppss)))) + (if open + (goto-char open) + (let* ((l (flan-fln--line-statement (point))) + (p (and l (flan-fln--parent l)))) + (if p (goto-char (flan-fln--first-char p)) + (user-error "flan: at top level"))))))) + +;;; Marking, for expand-region and anything else that marks + +(defun flan-fln--region () + (if (use-region-p) (cons (region-beginning) (region-end)) (cons (point) (point)))) + +(defun flan-fln--larger-p (b r) + "Non-nil if bounds B contain region R and are larger than it." + (and b (cdr b) (<= (car b) (car r)) (>= (cdr b) (cdr r)) + (> (- (cdr b) (car b)) (- (cdr r) (car r))))) + +(defun flan-fln--mark (b) + (when b + (goto-char (car b)) + (push-mark (cdr b) t t) + (activate-mark) + b)) + +(defun flan-fln-mark-term () + "Mark the term at point, or the one around the marked text." + (interactive) + (let* ((r (flan-fln--region)) + (b (flan-fln--term-bounds (car r)))) + ;; Out through the brackets until the term holds the region. + (while (and b (not (flan-fln--larger-p b r))) + (let ((g (flan-fln--group-bounds (car b)))) + (setq b (and g (flan-fln--term-bounds (car g)))))) + (flan-fln--mark b))) + +(defun flan-fln-mark-group () + "Mark the bracket group around point, or around the marked text." + (interactive) + (let* ((r (flan-fln--region)) + (b (flan-fln--group-bounds (car r)))) + (while (and b (not (flan-fln--larger-p b r))) + (setq b (flan-fln--group-bounds (car b)))) + (flan-fln--mark b))) + +(defun flan-fln--statement-around (r) + "The innermost statement that holds region R and is larger than it." + (let* ((s (flan-fln--statement-start-at (car r))) + (b (and s (flan-fln--statement-bounds s)))) + (while (and s (not (flan-fln--larger-p b r))) + ;; A clause's statement is its header's. + (let ((h (flan-fln--clause-header s))) + (setq s (if (/= h s) h (flan-fln--parent s))) + (setq b (and s (flan-fln--statement-bounds s))))) + b)) + +(defun flan-fln-mark-statement () + "Mark the statement at point, or the one around the marked text." + (interactive) + (flan-fln--mark (flan-fln--statement-around (flan-fln--region)))) + +(defun flan-fln-mark-clause () + "Mark the clause at point, or the one around the marked text." + (interactive) + (let* ((r (flan-fln--region)) + (c (flan-fln--clause-at (car r))) + (b (and c (flan-fln--clause-bounds c)))) + (while (and c (not (flan-fln--larger-p b r))) + (setq c (let ((p (flan-fln--parent c))) (and p (flan-fln--clause-at p)))) + (setq b (and c (flan-fln--clause-bounds c)))) + (flan-fln--mark b))) + +(defun flan-fln-mark-toplevel () + "Mark the top-level form at point." + (interactive) + (flan-fln--mark (flan-fln--toplevel-bounds (car (flan-fln--region))))) + +;; thing-at-point, so `(bounds-of-thing-at-point 'flan-fln-statement)' and +;; everything built on it knows the objects. +(put 'flan-fln-term 'bounds-of-thing-at-point + (lambda () (flan-fln--term-bounds (point)))) +(put 'flan-fln-group 'bounds-of-thing-at-point + (lambda () (flan-fln--group-bounds (point)))) +(put 'flan-fln-statement 'bounds-of-thing-at-point + (lambda () (let ((s (flan-fln--statement-start-at (point)))) + (and s (flan-fln--statement-bounds s))))) +(put 'flan-fln-body 'bounds-of-thing-at-point + (lambda () (let ((s (flan-fln--statement-start-at (point)))) + (and s (flan-fln--body-bounds s))))) +(put 'flan-fln-clause 'bounds-of-thing-at-point + (lambda () (let ((c (flan-fln--clause-at (point)))) + (and c (flan-fln--clause-bounds c))))) +(put 'flan-fln-toplevel 'bounds-of-thing-at-point + (lambda () (flan-fln--toplevel-bounds (point)))) + +;;; Indentation + +;; TAB offers the columns of the blocks open above the line, plus one level +;; deeper after a line that opens a block. The first TAB takes the deepest, +;; each repeated TAB steps out one. A block's column is the program's +;; meaning, so nothing here ever moves a line on its own: `indent-region' +;; shifts rigidly and only when the first line is at no valid column, and a +;; yank moves its lines together. + +(defun flan-fln--opener-p (start last) + "Non-nil if the joined line START..LAST opens a block on the lines under it." + (or (save-excursion + (goto-char start) + (back-to-indentation) + (and (looking-at (concat (regexp-opt flan-fln--opener-words t) + "\\([ \t]\\|$\\)")) + (let ((w (match-string-no-properties 1)) + (alone (string= (match-string-no-properties 2) "")) + (end (flan-fln--code-end last))) + (cond + ((member w '("defer" "quote")) alone) + ((member w '("fn" "fn-")) + (not (re-search-forward "[ \t]=[ \t]" end t))) + ((member w '("if" "elif")) + (not (re-search-forward "[ \t]then[ \t]" end t))) + (t t))))) + (save-excursion + (goto-char (flan-fln--code-end last)) + (let ((bol (line-beginning-position))) + (or (looking-back ":" bol) + (looking-back "[ \t]->" bol) + ;; `let x =' and `def colors =' with the value as a block, + ;; which the author's list leaves out and the reader reads. + (looking-back "[ \t]=" bol) + ;; `let f = fn(x)' with its body under it. + (looking-back "\\_ min 0) (flan-fln--prev-code p)))) + (unless (eql min 0) (push (cons 0 nil) out)) + (nreverse out))) + +(defun flan-fln--levels (pos) + "Columns TAB offers POS's line outside brackets, deepest first." + (let* ((prev (flan-fln--prev-code pos)) + (stack (mapcar #'car (flan-fln--stack pos)))) + (if (and prev (flan-fln--opener-p (flan-fln--logical-start prev) prev)) + (cons (+ (flan-fln--indent-at (flan-fln--logical-start prev)) + flan-fln-indent-offset) + stack) + stack))) + +(defun flan-fln--clause-columns (word pos) + "Columns of the lines above POS a clause WORD may sit under, deepest first." + (let ((heads (cdr (assoc word flan-fln--clause-headers)))) + (delq nil + (mapcar (lambda (e) + (and (cdr e) + (save-excursion + (goto-char (flan-fln--first-char (cdr e))) + (and (looking-at (concat (regexp-opt heads) + "\\(?:[ \t]\\|$\\)")) + (car e))))) + (flan-fln--stack pos))))) + +(defun flan-fln--bracket-column (open) + "The column a line inside the bracket at OPEN goes to. +Under the first element when one follows the bracket on its line, one level +in from that line when none does -- the paren mode's rule for data and +calls alike. A line that starts with the closing bracket goes to the +opening line's column." + (save-excursion + (let ((closing (save-excursion (back-to-indentation) (looking-at "\\s)")))) + (goto-char open) + (if closing + (current-indentation) + (forward-char 1) + (skip-chars-forward " \t") + (if (or (eolp) (eq (char-after) ?\;)) + (+ (current-indentation) flan-fln-indent-offset) + (current-column)))))) + +(defun flan-fln--indent-candidates (pos) + "Columns TAB offers POS's line, deepest first; nil to leave it alone." + (save-excursion + (goto-char (flan-fln--bol pos)) + (let ((s (syntax-ppss (point)))) + (cond + ((nth 3 s) nil) + ((> (car s) 0) (list (flan-fln--bracket-column (nth 1 s)))) + (t + (let ((prev (flan-fln--prev-code (point)))) + (cond + ((null prev) (list 0)) + ((save-excursion (back-to-indentation) (looking-at flan-fln--clause-re)) + (or (flan-fln--clause-columns (match-string-no-properties 1) (point)) + (flan-fln--levels (point)))) + ((or (flan-fln--starts-with-op-p (point)) + (flan-fln--ends-in-op-p prev)) + (list (+ (flan-fln--indent-at (flan-fln--logical-start prev)) + flan-fln-indent-offset))) + (t (flan-fln--levels (point)))))))))) + +(defun flan-fln-indent-line () + "Indent the line to a block column: the deepest first, then out one per TAB." + (let* ((cands (flan-fln--indent-candidates (point))) + (cur (current-indentation)) + (target + (cond ((null cands) nil) + ((and (eq this-command 'indent-for-tab-command) + (eq last-command 'indent-for-tab-command) + (memq cur cands)) + (or (cadr (memq cur cands)) (car cands))) + (t (car cands))))) + (if (null target) + 'noindent + (let ((from-end (and (> (current-column) cur) (- (point-max) (point))))) + (indent-line-to target) + (when from-end (goto-char (- (point-max) from-end))))))) + +(defun flan-fln-indent-region (start end) + "Shift START..END rigidly so its first line sits at a block column. +Never re-indents a line against the others: the columns are the program." + (save-excursion + (goto-char start) + (beginning-of-line) + (while (and (< (point) end) (flan-fln--blank-p (point)) + (zerop (forward-line 1)))) + (when (< (point) end) + (let ((cands (flan-fln--indent-candidates (point))) + (cur (current-indentation))) + (when (and cands (not (memq cur cands))) + (indent-rigidly (point) end (- (car cands) cur))))))) + +(defun flan-fln-dedent-or-delete (arg) + "In a line's indentation, drop it one block level; else delete a character." + (interactive "*p") + (if (and (= arg 1) (not (use-region-p)) + (> (current-column) 0) + (= (current-column) (current-indentation)) + (not (flan-fln--in-open-p (point)))) + (let ((cur (current-indentation))) + (indent-line-to (or (seq-find (lambda (c) (< c cur)) + (flan-fln--levels (point))) + 0))) + (let ((cmd (or (command-remapping 'delete-backward-char) + #'delete-backward-char))) + (setq this-command cmd) + (call-interactively cmd)))) + +(defun flan-fln--electric-clause () + "Snap an else, elif, on or restart line to its header as it is typed. +Run when the word is finished by a space or a newline." + (when (memq last-command-event '(?\s ?\n ?\r)) + (save-excursion + (let ((nl (not (eq last-command-event ?\s)))) + (when nl (forward-line -1)) + (let ((text (buffer-substring-no-properties + (line-beginning-position) + (if nl (line-end-position) (point))))) + (when (and (string-match "\\`[ \t]*\\(else\\|elif\\|on\\|restart\\)[ \t]*\\'" + text) + (not (flan-fln--in-open-p (point)))) + (let ((cols (flan-fln--clause-columns (match-string 1 text) (point)))) + (when (and cols (not (memq (current-indentation) cols))) + (indent-line-to (car cols)))))))) + ;; The new line was indented from the old one before it moved. + (when (memq last-command-event '(?\n ?\r)) + (let ((c (car (flan-fln--indent-candidates (point))))) + (when (and c (= (current-column) (current-indentation))) + (indent-line-to c)))))) + +(defun flan-fln-shift-right (start end &optional n) + "Shift the lines of the region, or the line, right by N block levels." + (interactive (if (use-region-p) + (list (region-beginning) (region-end) (prefix-numeric-value current-prefix-arg)) + (list (line-beginning-position) (line-end-position) + (prefix-numeric-value current-prefix-arg)))) + (let ((deactivate-mark nil)) + (indent-rigidly (flan-fln--bol start) end (* (or n 1) flan-fln-indent-offset)))) + +(defun flan-fln-shift-left (start end &optional n) + "Shift the lines of the region, or the line, left by N block levels." + (interactive (if (use-region-p) + (list (region-beginning) (region-end) (prefix-numeric-value current-prefix-arg)) + (list (line-beginning-position) (line-end-position) + (prefix-numeric-value current-prefix-arg)))) + (let ((deactivate-mark nil)) + (indent-rigidly (flan-fln--bol start) end (- (* (or n 1) flan-fln-indent-offset))))) + +(defun flan-fln--yank-base (start end first-ws) + "The column the yanked text between START and END was written at. +FIRST-WS is the width of its first line's own indentation, when it kept one." + (if (> first-ws 0) + first-ws + ;; The first line was cut from its first character: read the column off + ;; the lines under it. A clause sits at the statement's column; failing + ;; one, the shallowest line is a body, one level in. + (let (min clause) + (save-excursion + (goto-char start) + (while (and (zerop (forward-line 1)) (< (point) end)) + (unless (flan-fln--blank-p (point)) + (let ((i (current-indentation))) + (when (or (null min) (< i min)) (setq min i clause nil)) + (when (and (= i min) + (save-excursion (back-to-indentation) + (looking-at flan-fln--clause-re))) + (setq clause t)))))) + (cond ((null min) 0) + (clause min) + (t (max 0 (- min flan-fln-indent-offset))))))) + +(defun flan-fln-yank (&optional arg) + "Yank, then move the lines after the first with it, rigidly. +The first line lands at point; every other line keeps its place relative to +it, so a block pasted at another depth stays one block." + (interactive "*P") + (let* ((col (current-column)) + (at-indent (<= col (current-indentation)))) + (setq this-command 'yank) + (yank arg) + (let ((end (copy-marker (max (point) (mark t)))) + (start (min (point) (mark t)))) + (save-excursion + (goto-char start) + (when (< (line-end-position) end) + (let* ((ws (save-excursion (skip-chars-forward " \t") (- (point) start))) + (base (flan-fln--yank-base start end ws))) + (when (and at-indent (> ws 0)) + (delete-region start (+ start ws))) + (forward-line 1) + (when (< (point) end) + (indent-rigidly (point) end (- col base)))))) + (set-marker end nil)))) + +;;; Block editing + +(defun flan-fln--ensure-final-newline () + (save-excursion + (goto-char (point-max)) + (unless (bolp) (insert "\n")))) + +(defun flan-fln--lines (start last) + "(BEG . END) of the whole lines START through LAST, final newline included." + (cons start (save-excursion (goto-char last) (line-beginning-position 2)))) + +(defun flan-fln--statement-lines (s) + (flan-fln--lines s (flan-fln--statement-last s))) + +(defun flan-fln-kill-statement () + "Kill the statement at point, whole lines, body and clauses included." + (interactive) + (flan-fln--ensure-final-newline) + (let ((s (flan-fln--statement-start-at (point)))) + (unless s (user-error "flan: no statement at point")) + (let ((l (flan-fln--statement-lines s))) + (kill-region (car l) (cdr l))))) + +(defun flan-fln--sibling (s dir) + "The statement next to S at its level: before it when DIR is -1, else after." + (let ((ind (flan-fln--indent-at s))) + (if (< dir 0) + (let ((p (flan-fln--prev-code s)) hit) + (while (and p (not hit)) + (setq p (flan-fln--logical-start p)) + (let ((i (flan-fln--indent-at p))) + (cond ((< i ind) (setq p nil)) + ((= i ind) (setq hit (flan-fln--clause-header p))) + (t (setq p (flan-fln--prev-code p)))))) + hit) + (let ((n (flan-fln--next-code (flan-fln--statement-last s)))) + (and n (= (flan-fln--indent-at n) ind) + (not (flan-fln--clause-line-p n)) + n))))) + +(defun flan-fln--swap (a b) + "Swap the whole-line statements A and B, A above B; keep point in its own." + (let* ((la (flan-fln--statement-lines a)) + (lb (flan-fln--statement-lines b)) + (ta (buffer-substring (car la) (cdr la))) + (gap (buffer-substring (cdr la) (car lb))) + (tb (buffer-substring (car lb) (cdr lb))) + (in-b (>= (point) (car lb))) + (off (- (point) (if in-b (car lb) (car la))))) + (goto-char (car la)) + (delete-region (car la) (cdr lb)) + (insert tb gap ta) + (goto-char (+ (car la) off (if in-b 0 (+ (length tb) (length gap))))))) + +(defun flan-fln-move-statement-up () + "Swap the statement at point with the one before it at its level." + (interactive) + (flan-fln--ensure-final-newline) + (let* ((s (flan-fln--statement-start-at (point))) + (p (and s (flan-fln--sibling s -1)))) + (unless p (user-error "flan: no statement above this one at its level")) + (flan-fln--swap p s))) + +(defun flan-fln-move-statement-down () + "Swap the statement at point with the one after it at its level." + (interactive) + (flan-fln--ensure-final-newline) + (let* ((s (flan-fln--statement-start-at (point))) + (n (and s (flan-fln--sibling s 1)))) + (unless n (user-error "flan: no statement below this one at its level")) + (flan-fln--swap s n))) + +(defun flan-fln--owner (pos) + "The line that owns the block POS is in or opens: a header with a body." + (let ((s (flan-fln--statement-start-at pos))) + (cond ((null s) nil) + ((flan-fln--body-bounds (flan-fln--line-statement pos)) + (flan-fln--line-statement pos)) + (t (flan-fln--parent (flan-fln--line-statement pos)))))) + +(defun flan-fln--shift-lines (l delta) + (indent-rigidly (car l) (cdr l) delta)) + +(defun flan-fln-slurp () + "Pull the statement after this block into it, as its last statement." + (interactive) + (flan-fln--ensure-final-newline) + (let* ((o (or (flan-fln--owner (point)) (user-error "flan: no block here"))) + (last (flan-fln--statement-last o t)) + (n (flan-fln--next-code last)) + (body (flan-fln--body-bounds o))) + (unless (and n (= (flan-fln--indent-at n) (flan-fln--indent-at o)) + (not (flan-fln--clause-line-p n))) + (user-error "flan: no statement after this block to pull in")) + (save-excursion + (flan-fln--shift-lines (flan-fln--statement-lines n) + (- (flan-fln--indent-at (car body)) + (flan-fln--indent-at o)))))) + +(defun flan-fln-barf () + "Push this block's last statement out, to follow the block." + (interactive) + (flan-fln--ensure-final-newline) + (let* ((o (or (flan-fln--owner (point)) (user-error "flan: no block here"))) + (body (flan-fln--body-bounds o)) + (ind (flan-fln--indent-at (car body))) + (last (flan-fln--statement-last o t)) + (after (flan-fln--next-code last)) + (child (flan-fln--bol (car body))) c) + (when (and after (= (flan-fln--indent-at after) (flan-fln--indent-at o)) + (flan-fln--clause-line-p after)) + (user-error "flan: a clause follows this block; its last statement cannot leave it")) + (while (setq c (flan-fln--sibling child 1)) (setq child c)) + (when (= (flan-fln--bol child) (flan-fln--bol (car body))) + (user-error "flan: this block has one statement; pushing it out would empty it")) + (save-excursion + (flan-fln--shift-lines (flan-fln--statement-lines child) + (- (flan-fln--indent-at o) ind))))) + +(defun flan-fln-raise-statement () + "Replace the statement that owns this block with the statement at point." + (interactive) + (flan-fln--ensure-final-newline) + (let* ((s (or (flan-fln--statement-start-at (point)) + (user-error "flan: no statement at point"))) + (o (or (flan-fln--parent s) (user-error "flan: at top level"))) + (h (flan-fln--clause-header o)) + (ls (flan-fln--statement-lines s)) + (lh (flan-fln--statement-lines h)) + (text (buffer-substring (car ls) (cdr ls))) + (delta (- (flan-fln--indent-at h) (flan-fln--indent-at s)))) + (goto-char (car lh)) + (delete-region (car lh) (cdr lh)) + (let ((beg (point))) + (insert text) + (indent-rigidly beg (point) delta) + (goto-char beg) + (back-to-indentation)))) + +;;; Font lock + +(defconst flan-fln--name-re "\\([^][ \t\n(){},;\":]+\\)" + "A declared name: a run up to a bracket, a space, or the colon of `x: T'.") + +(defvar flan-fln-font-lock-keywords + `(;; The header words, at the start of a line and followed by a space or the + ;; end of it: `if(c, a)' is the fallback call and is not a header. + (,(concat "^[ \t]*" (regexp-opt flan-fln--header-words t) "\\(?:[ \t]\\|$\\)") + 1 font-lock-keyword-face) + (,(concat "^\\(fn-?\\)[ \t]+" flan-fln--name-re) + 2 font-lock-function-name-face) + (,(concat "^\\(?:struct\\|data\\|union\\|enum\\)[ \t]+" flan-fln--name-re) + 1 font-lock-type-face) + (,(concat "^\\(?:def\\|once\\|const\\)[ \t]+" flan-fln--name-re) + 1 font-lock-variable-name-face) + ;; The words inside a line: `for i in range(n)', `if c then a else b', a + ;; `where' constraint. + ("[ \t]\\(then\\|else\\|in\\|where\\)[ \t]" 1 font-lock-keyword-face) + ;; The operator words. + ("\\_<\\(and\\|or\\|not\\)\\_>" 1 font-lock-keyword-face) + (,(concat "\\_<" (regexp-opt flan--constants t) "\\_>") + 1 font-lock-constant-face) + ;; A keyword. `x:' is a name with a colon glued on, not one. + ("\\_<:[^][ \t\n(){},;\":]+" . font-lock-constant-face) + ;; A type: after the `: ' of an annotation and after `-> '. + ("[^ \t\n:]:[ \t]+\\([$a-zA-Z][^][ \t\n(){},;\"=]*\\)" 1 font-lock-type-face) + ("[ \t]->[ \t]+\\([$a-zA-Z][^][ \t\n(){},;\"=]*\\)" 1 font-lock-type-face) + ;; The package half of a qualified name, as `flan-mode' draws it. + ("\\_<\\([a-zA-Z][a-zA-Z0-9!?*+=<>._-]*/\\)" 1 font-lock-type-face) + ("\\_<\\(?:[iu]\\(?:8\\|16\\|32\\|64\\)\\|f\\(?:32\\|64\\)\\|bool\\|string\\|dyn\\|Never\\|Allocator\\|Ptr\\|Option\\|Vec\\|Map\\|C?Fn\\)\\_>" + . font-lock-type-face) + ("\\_<\\$[^][ \t\n(){},;\":]*" . font-lock-type-face) + ;; A character literal, `\c' or `\space'. + ("\\\\\\(?:space\\|newline\\|tab\\|return\\|[^ \t\n]\\)" . font-lock-string-face) + ("\\_<-?[0-9][0-9a-fA-FxX_.]*\\_>" . font-lock-number-face)) + "Font lock for `flan-fln-mode'.") + +(defvar flan-fln-imenu-generic-expression + `(("Functions" ,(concat "^fn-?[ \t]+" flan-fln--name-re) 1) + ("Macros" ,(concat "^defmacro(" flan-fln--name-re) 1) + ("Types" ,(concat "^\\(?:struct\\|data\\|union\\|enum\\)[ \t]+" flan-fln--name-re) 1) + ("Variables" ,(concat "^\\(?:def\\|once\\|const\\)[ \t]+" flan-fln--name-re) 1)) + "Imenu index for `flan-fln-mode'.") + +(defun flan-fln-current-defun-name () + "The name the top-level form at point declares, or nil." + (let ((s (flan-fln--toplevel-start (point)))) + (when s + (save-excursion + (goto-char s) + (and (looking-at (concat "\\(?:fn-?\\|def\\|once\\|const\\|struct\\|data\\|union\\|enum\\)[ \t]+" + flan-fln--name-re)) + (match-string-no-properties 1)))))) + +;;; The mode + +(defvar flan-fln-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map flan-base-mode-map) + (define-key map (kbd "C-c C-c") #'flan-fln-eval-defun) + (define-key map (kbd "C-M-x") #'flan-fln-eval-defun) + (define-key map (kbd "C-x C-e") #'flan-fln-eval-last) + (define-key map (kbd "C-c C-e") #'flan-fln-eval-statement) + (define-key map (kbd "C-c C-n") #'flan-fln-eval-statement-and-next) + ;; The sentence keys, because a statement is this syntax's sentence. + ;; M-e shadows a global binding of the same key, as any mode's M-e would. + (define-key map (kbd "M-a") #'flan-fln-backward-statement) + (define-key map (kbd "M-e") #'flan-fln-forward-statement) + (define-key map (kbd "M-k") #'flan-fln-kill-statement) + (define-key map (kbd "C-M-u") #'flan-fln-up) + (define-key map (kbd "M-") #'flan-fln-move-statement-up) + (define-key map (kbd "M-") #'flan-fln-move-statement-down) + (define-key map (kbd "M-") #'flan-fln-slurp) + (define-key map (kbd "M-") #'flan-fln-barf) + (define-key map (kbd "M-r") #'flan-fln-raise-statement) + (define-key map (kbd "C-c <") #'flan-fln-shift-left) + (define-key map (kbd "C-c >") #'flan-fln-shift-right) + (define-key map (kbd "DEL") #'flan-fln-dedent-or-delete) + (define-key map [remap yank] #'flan-fln-yank) + map) + "Keymap for `flan-fln-mode'.") + +;;;###autoload +(define-derived-mode flan-fln-mode flan-base-mode "Fln" + "Major mode for Flan in the indented syntax, a .fln file. + +\\{flan-fln-mode-map}" + :syntax-table flan-fln-mode-syntax-table + (setq-local font-lock-defaults '(flan-fln-font-lock-keywords)) + (setq-local indent-line-function #'flan-fln-indent-line) + (setq-local indent-region-function #'flan-fln-indent-region) + ;; Never re-indent the line RET leaves: its column is its meaning. + (setq-local electric-indent-inhibit t) + (add-hook 'post-self-insert-hook #'flan-fln--electric-clause -50 t) + (setq-local beginning-of-defun-function #'flan-fln--beginning-of-defun) + (setq-local end-of-defun-function #'flan-fln--end-of-defun) + ;; Left nil on purpose: C-M-f and C-M-b stay bracket and term motion, and + ;; everything built on sexps keeps meaning brackets. + (setq-local forward-sexp-function nil) + (setq-local parse-sexp-ignore-comments t) + (setq-local comment-use-syntax t) + (setq-local imenu-generic-expression flan-fln-imenu-generic-expression) + (setq-local er/try-expand-list + '(flan-fln-mark-term flan-fln-mark-group flan-fln-mark-statement + flan-fln-mark-clause flan-fln-mark-toplevel)) + (setq-local evil-shift-width flan-fln-indent-offset) + (add-hook 'which-func-functions #'flan-fln-current-defun-name nil t) + (when (and flan-fln-smartparens (require 'smartparens nil t)) + (smartparens-mode 1)) + (flan-fln--smartparens-keys)) + +(defvar smartparens-mode-map) + +(defun flan-fln--smartparens-keys () + "Keep the top-level and up motions this mode's when smartparens is on. +A minor mode's map is looked up before the major mode's, and a common +smartparens setup puts sexp commands on C-M-a, C-M-e and C-M-u. In a .fln +buffer those keys mean forms and blocks, so smartparens gets a map here +that says so and otherwise is its own." + (when (boundp 'smartparens-mode-map) + (let ((map (make-sparse-keymap))) + (set-keymap-parent map smartparens-mode-map) + (define-key map (kbd "C-M-a") #'beginning-of-defun) + (define-key map (kbd "C-M-e") #'end-of-defun) + (define-key map (kbd "C-M-h") #'mark-defun) + (define-key map (kbd "C-M-u") #'flan-fln-up) + (setq-local minor-mode-overriding-map-alist + (cons (cons 'smartparens-mode map) + (assq-delete-all 'smartparens-mode + (copy-sequence minor-mode-overriding-map-alist))))))) + +(with-eval-after-load 'smartparens + ;; `'x' quotes a name and `'(a b)' a list; neither has a closing quote. + (sp-local-pair 'flan-fln-mode "'" nil :actions nil) + (sp-local-pair 'flan-fln-mode "`" nil :actions nil)) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.fln\\'" . flan-fln-mode)) + +;;; Evil + +(defun flan-fln--evil (b type) + (if b (evil-range (car b) (cdr b) type) (error "No object here"))) + +(defun flan-fln--whole-lines (b) + (and b (cons (flan-fln--bol (car b)) (flan-fln--code-end (cdr b))))) + +(defun flan-fln--with-trailing-blanks (b) + "B's lines and the blank lines after them." + (and b (let ((n (flan-fln--next-code (cdr b)))) + (cons (car b) (if n + (save-excursion (goto-char n) (forward-line -1) + (line-end-position)) + (point-max)))))) + +(defun flan-fln--term-around (b) + "B and the spaces after it, or before it when none follow." + (and b (save-excursion + (goto-char (cdr b)) + (let ((e (progn (skip-chars-forward " \t") (point)))) + (if (> e (cdr b)) + (cons (car b) e) + (goto-char (car b)) + (skip-chars-backward " \t") + (cons (point) (cdr b))))))) + +(with-eval-after-load 'evil + ;; Evaluated here rather than written at top level: the macro is Evil's, and + ;; this file loads and compiles without Evil installed. + (eval + '(progn + (evil-define-text-object flan-fln-inner-term (count &optional _beg _end _type) + "A term." + (flan-fln--evil (flan-fln--term-bounds (point)) 'exclusive)) + (evil-define-text-object flan-fln-a-term (count &optional _beg _end _type) + "A term and the spaces after it." + (flan-fln--evil (flan-fln--term-around (flan-fln--term-bounds (point))) + 'exclusive)) + (evil-define-text-object flan-fln-inner-statement (count &optional _beg _end _type) + "A statement, from its first character to its last." + (flan-fln--evil (bounds-of-thing-at-point 'flan-fln-statement) 'exclusive)) + (evil-define-text-object flan-fln-a-statement (count &optional _beg _end _type) + "A statement's whole lines." + (flan-fln--evil (flan-fln--whole-lines + (bounds-of-thing-at-point 'flan-fln-statement)) + 'line)) + (evil-define-text-object flan-fln-inner-body (count &optional _beg _end _type) + "A statement's block, its lines." + (flan-fln--evil (flan-fln--whole-lines + (bounds-of-thing-at-point 'flan-fln-body)) + 'line)) + (evil-define-text-object flan-fln-a-body (count &optional _beg _end _type) + "The whole statement the block belongs to, its lines." + (flan-fln--evil (flan-fln--whole-lines + (bounds-of-thing-at-point 'flan-fln-statement)) + 'line)) + (evil-define-text-object flan-fln-inner-clause (count &optional _beg _end _type) + "A clause's block, its lines." + (flan-fln--evil (let ((c (flan-fln--clause-at (point)))) + (flan-fln--whole-lines (and c (flan-fln--body-bounds c)))) + 'line)) + (evil-define-text-object flan-fln-a-clause (count &optional _beg _end _type) + "A clause: its line and its block." + (flan-fln--evil (flan-fln--whole-lines + (bounds-of-thing-at-point 'flan-fln-clause)) + 'line)) + (evil-define-text-object flan-fln-inner-toplevel (count &optional _beg _end _type) + "A top-level form, its lines." + (flan-fln--evil (flan-fln--whole-lines + (bounds-of-thing-at-point 'flan-fln-toplevel)) + 'line)) + (evil-define-text-object flan-fln-a-toplevel (count &optional _beg _end _type) + "A top-level form and the blank lines after it." + (flan-fln--evil (flan-fln--with-trailing-blanks + (flan-fln--whole-lines + (bounds-of-thing-at-point 'flan-fln-toplevel))) + 'line))) + t) + (evil-define-key* '(operator visual) flan-fln-mode-map + "ie" 'flan-fln-inner-term "ae" 'flan-fln-a-term + "is" 'flan-fln-inner-statement "as" 'flan-fln-a-statement + "ii" 'flan-fln-inner-body "ai" 'flan-fln-a-body + "ik" 'flan-fln-inner-clause "ak" 'flan-fln-a-clause + "id" 'flan-fln-inner-toplevel "ad" 'flan-fln-a-toplevel) + ;; Evil's sentence motions, for the statement ones M-a and M-e are. + (evil-define-key* '(normal motion visual) flan-fln-mode-map + "(" #'flan-fln-backward-statement + ")" #'flan-fln-next-statement) + ;; Normal state's own M- bindings would otherwise win over the mode's. + (evil-define-key* 'normal flan-fln-mode-map + (kbd "M-r") #'flan-fln-raise-statement + (kbd "M-k") #'flan-fln-kill-statement + (kbd "M-") #'flan-fln-move-statement-up + (kbd "M-") #'flan-fln-move-statement-down + (kbd "M-") #'flan-fln-slurp + (kbd "M-") #'flan-fln-barf)) + +(provide 'flan-fln-mode) +;;; flan-fln-mode.el ends here diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index 8785eebc..f5638d0d 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -438,17 +438,14 @@ For `syntax-propertize-function'." ;; not. Either way forward, which is the whole of why this terminates. (goto-char (or fin from))))) -(defvar flan-mode-map +;; The keys both syntaxes share: everything that talks to the running program +;; about a name, a value or the session rather than about a piece of the text. +;; The keys that pick text out of the buffer -- which form C-c C-c means -- +;; are each child mode's own, because what a form is differs between them. +(defvar flan-base-mode-map (let ((map (make-sparse-keymap))) ;; Autoloaded from flan.el, so the client loads on first use. - (define-key map (kbd "C-c C-c") #'flan-eval-defun) - ;; The same command on the binding SLIME and CIDER put it on. Emacs binds - ;; C-M-x to eval-defun only in `emacs-lisp-mode-map', so a mode derived - ;; from `lisp-mode' inherits nothing and the key is undefined — which - ;; reads as the client being broken rather than as the key being free. - (define-key map (kbd "C-M-x") #'flan-eval-defun) (define-key map (kbd "C-c C-k") #'flan-eval-buffer) - (define-key map (kbd "C-x C-e") #'flan-eval-last-sexp) (define-key map (kbd "C-c C-z") #'flan-connect) (define-key map (kbd "C-c C-q") #'flan-disconnect) (define-key map (kbd "C-c C-d") #'flan-describe) @@ -499,23 +496,45 @@ For `syntax-propertize-function'." ;; because it is the one that works from any state. (define-key map (kbd "C-c C-M-x") #'flan-rerun) map) + "Keymap for every Flan source buffer, `flan-mode' and `flan-fln-mode'.") + +(defvar flan-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map flan-base-mode-map) + (define-key map (kbd "C-c C-c") #'flan-eval-defun) + ;; The same command on the binding SLIME and CIDER put it on. Emacs binds + ;; C-M-x to eval-defun only in `emacs-lisp-mode-map', so a mode derived + ;; from `lisp-mode' inherits nothing and the key is undefined — which + ;; reads as the client being broken rather than as the key being free. + (define-key map (kbd "C-M-x") #'flan-eval-defun) + (define-key map (kbd "C-x C-e") #'flan-eval-last-sexp) + map) "Keymap for `flan-mode'.") +;; The parent of both source modes. Everything the dev loop asks of a buffer +;; -- is this Flan, set up eldoc and completion, draw the program's names, +;; paint watched values -- asks it of this mode, so a .fln buffer gets it the +;; same way a .flan buffer does. What each syntax reads as a form is its +;; child's business. +(define-derived-mode flan-base-mode prog-mode "Flan" + "Parent mode of the Flan source modes, `flan-mode' and `flan-fln-mode'." + (setq-local comment-start ";") + (setq-local comment-start-skip ";+ *") + (setq-local comment-add 1) + ;; Spaces. The whole corpus is written with them, and alignment that is + ;; correct here is alignment under a specific *column* — a tab makes that + ;; depend on a setting the file cannot carry. In a .fln file a tab in the + ;; indentation is an error besides. + (setq-local indent-tabs-mode nil)) + ;;;###autoload -(define-derived-mode flan-mode prog-mode "Flan" +(define-derived-mode flan-mode flan-base-mode "Flan" "Major mode for editing Flan. \\{flan-mode-map}" :syntax-table flan-mode-syntax-table - (setq-local comment-start ";") - (setq-local comment-start-skip ";+ *") - (setq-local comment-add 1) (setq-local font-lock-defaults '(flan-font-lock-keywords)) (setq-local indent-line-function #'lisp-indent-line) - ;; Spaces. The whole corpus is written with them, and alignment that is - ;; correct here is alignment under a specific *column* — a tab makes that - ;; depend on a setting the file cannot carry. - (setq-local indent-tabs-mode nil) (setq-local lisp-indent-function #'flan-indent-function) (setq-local outline-regexp ";;;;+[ \t]*") (setq-local imenu-generic-expression flan-imenu-generic-expression) @@ -797,6 +816,12 @@ decision to `calculate-lisp-indent'." ;;;###autoload (add-to-list 'auto-mode-alist '("\\.flan\\'" . flan-mode)) +;; The indented syntax's mode lives in its own file; a buffer of it is the first +;; thing that loads it. +;;;###autoload +(autoload 'flan-fln-mode "flan-fln-mode" nil t) +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.fln\\'" . flan-fln-mode)) ;;; The other Flan buffers under Evil diff --git a/emacs/flan-watch.el b/emacs/flan-watch.el index d0701a0a..4eff5e7e 100644 --- a/emacs/flan-watch.el +++ b/emacs/flan-watch.el @@ -249,15 +249,19 @@ inline it has no modeline beside it to say so.") (let (bufs) (dolist (w (window-list-1 nil 'nomini t)) (let ((b (window-buffer w))) - (when (and (eq (buffer-local-value 'major-mode b) 'flan-mode) + (when (and (provided-mode-derived-p (buffer-local-value 'major-mode b) + 'flan-base-mode) (not (memq b bufs))) (push b bufs)))) bufs)) (defun flan-watch--ghost-sites () "Watch call sites in the current buffer, as a list of (NAME . END-OF-LINE)." - (let ((re (concat "(\\s-*" flan-watch-ghost-call-regexp - "\\s-+\"\\([^\"\n]*\\)\"")) + ;; Either syntax: `(watch "name" v)' in a .flan file, `watch("name", v)' in + ;; a .fln one, where the call is the name glued to its parenthesis. + (let ((re (concat "\\(?:(\\s-*\\(?:" flan-watch-ghost-call-regexp "\\)\\s-+" + "\\|\\_<\\(?:" flan-watch-ghost-call-regexp "\\)(\\s-*\\)" + "\"\\([^\"\n]*\\)\"")) (sites nil)) (save-excursion (goto-char (point-min)) diff --git a/emacs/flan.el b/emacs/flan.el index 614e91b2..21040988 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -953,7 +953,7 @@ refuses: callers cannot silently discard a running program's state." ;; buffer is not what you meant — and it still only changes what is asked, ;; never which file the unasked case picks. (let ((file (and buffer-file-name - (string-suffix-p ".flan" buffer-file-name) + (string-match-p "\\.fla?n\\'" buffer-file-name) (expand-file-name buffer-file-name)))) (list (if (and file (not current-prefix-arg)) file @@ -1143,7 +1143,7 @@ the state with something to answer in it." (defun flan-mode-line () "The Flan connection indicator, for `mode-line-misc-info'." - (when (derived-mode-p 'flan-mode 'flan-repl-mode) + (when (derived-mode-p 'flan-base-mode 'flan-repl-mode) (pcase (flan-state) ;; First, and it names the condition: a stopped program looks exactly ;; like a running one from anywhere else in Emacs, and the whole reason @@ -2108,7 +2108,7 @@ Leaves its face in `flan--dynamic-face' for the rule that calls this." (defun flan--dynamic-install () "Add or remove the dynamic rules in the current buffer, and redraw it. Called for its effect on one buffer; `flan--dynamic-sync' does every buffer." - (when (derived-mode-p 'flan-mode) + (when (derived-mode-p 'flan-base-mode) ;; Removed first in both branches, because adding is not idempotent: a ;; second install would put the rule in twice and every refresh after that ;; would add another. @@ -2127,7 +2127,7 @@ Called for its effect on one buffer; `flan--dynamic-sync' does every buffer." ;; A file opened while a session is already up: the two moments the table is ;; rebuilt are both in the past by then, so the buffer has to ask on its way in. -(add-hook 'flan-mode-hook #'flan--dynamic-install) +(add-hook 'flan-base-mode-hook #'flan--dynamic-install) (defun flan--forget-defs () "Drop what is known about the program's names." @@ -2414,14 +2414,14 @@ someone editing Flan with no program running and this file never loaded." (setq-local mode-line-misc-info (append mode-line-misc-info '((:eval (flan-mode-line))))))) -(add-hook 'flan-mode-hook #'flan-setup) +(add-hook 'flan-base-mode-hook #'flan-setup) ;; Buffers that were already in flan-mode when this file loaded: the client is ;; autoloaded on first use, so by the time it arrives the file being edited has ;; long since had its mode hooks run. (dolist (b (buffer-list)) (with-current-buffer b - (when (derived-mode-p 'flan-mode) (flan-setup)))) + (when (derived-mode-p 'flan-base-mode) (flan-setup)))) ;;; Evaluating @@ -2621,7 +2621,8 @@ columns already were, because a top-level form starts at column 1." .fln file, the paren reader's for anything else. Sent explicitly because the daemon cannot tell from `:file' — an expansion shown in parens is sent back under the name of the .fln file it came from." - (if (and buffer-file-name (string-suffix-p ".fln" buffer-file-name)) + (if (or (derived-mode-p 'flan-fln-mode) + (and buffer-file-name (string-suffix-p ".fln" buffer-file-name))) "indented" "paren")) diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 1cdcaf74..f65a1b86 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -1926,6 +1926,11 @@ stopped program, which is the case where it should fire." (file-name-directory load-file-name)) nil t) +;; The .fln mode: its objects, keys, indentation and text objects, from text. +(load (expand-file-name "test-flan-fln.el" + (file-name-directory load-file-name)) + nil t) + ;; Ghost text, which is the same kind of thing: rows in, overlays out, and the ;; buffer it reads is a fixture like any other reply here. Loaded for the same ;; reason. diff --git a/emacs/test-flan-fln-live.el b/emacs/test-flan-fln-live.el new file mode 100644 index 00000000..baa55f00 --- /dev/null +++ b/emacs/test-flan-fln-live.el @@ -0,0 +1,171 @@ +;;; test-flan-fln-live.el --- The .fln keys against a real daemon -*- lexical-binding: t; -*- + +;; Loaded by test-flan.el, near its end, with `flan-command' already the +;; compiler under test. test-flan-fln.el checks which text each key picks; +;; this checks the reader accepts that text as a whole form, on both backends: +;; a daemon of its own on a .fln file with no main, once on x86 and once on +;; LLVM, each key sent at least once, and a pause mark the daemon must find. + +;;; Code: + +(require 'flan-fln-mode) + +(declare-function test-flan--check "test-flan" (name ok)) +(declare-function test-flan--result "test-flan" ()) +(defvar test-flan-fln-live-dir) +(defvar test-flan-fln-live-socket) + +(defconst test-flan-fln-live--program + "fn fib(n: i64) -> i64 + if n < 2 + n + else + fib(n - 1) + fib(n - 2) + +fn twice(n: i64) -> i64 = n * 2 + +fn total(n: i32) -> i32 + let t = 0 + for i in range(n) + t = t + i + t + +comment(): + twice(4) + if 2 > 1 + twice(2) + else + 0 + let x = 3 + twice(x) + 1 +") + +(defun test-flan-fln-live--run (backend args) + (let* ((sock (concat test-flan-fln-live-socket "-fln-" backend)) + (file (expand-file-name (format "fln-live-%s.fln" backend) + test-flan-fln-live-dir)) + (flan-daemon-args args) + (name (lambda (s) (format "%s: %s" backend s))) + (value (lambda (code) + (plist-get (flan--request + (list :op "eval-expr" :code code :file "")) + :value))) + (goto (lambda (needle &optional after) + (goto-char (point-min)) + (search-forward needle) + (unless after (goto-char (match-beginning 0))))) + (shows (lambda (v) + (let ((r (test-flan--result))) + (prog1 (and r (string-match-p (concat "=> " (regexp-quote v) "\\'") + (string-trim r))) + (flan-clear-result)))))) + (with-temp-file file (insert test-flan-fln-live--program)) + (ignore-errors (delete-file sock)) + (flan file sock) + (test-flan--check (funcall name "a daemon starts on a .fln file") + (process-live-p flan--connection)) + (unwind-protect + (with-current-buffer (find-file-noselect file) + (test-flan--check (funcall name "which opens in flan-fln-mode") + (eq major-mode 'flan-fln-mode)) + + ;; C-c C-c, from inside a fn changed in the buffer. + (funcall goto "n * 2") + (delete-char 5) + (insert "n * 3") + (flan-fln-eval-defun) + (test-flan--check (funcall name "C-c C-c installs the fn at point") + (equal (funcall value "(twice 7)") "21")) + + ;; C-x C-e at the end of a column-0 declaration. + (funcall goto "n * 3") + (delete-char 5) + (insert "n * 4") + (flan-fln-eval-last) + (test-flan--check (funcall name "C-x C-e at the end of a column-0 fn installs it") + (equal (funcall value "(twice 7)") "28")) + + ;; C-x C-e at the end of an inner statement: text from column 3. + (funcall goto "twice(4)" t) + (flan-fln-eval-last) + (test-flan--check (funcall name "C-x C-e sends the statement ending at point") + (funcall shows "16")) + + ;; ...and inside a line, the term before point. + (funcall goto "twice(4)") + (let ((at (point))) + (insert "fib(10) + ") + (goto-char (+ at (length "fib(10)"))) + (flan-fln-eval-last) + (test-flan--check (funcall name "C-x C-e inside a line sends the term before point") + (funcall shows "55")) + (delete-region at (+ at (length "fib(10) + ")))) + + ;; C-c C-e on a clause: the whole if, from column 3, clauses and all. + (funcall goto "else\n 0") + (flan-fln-eval-statement) + (test-flan--check (funcall name "C-c C-e on a clause sends its if, and it reads") + (funcall shows "8")) + + ;; A bare let: it and the rest of its block, which is its scope. + (funcall goto "let x = 3") + (flan-fln-eval-statement) + (test-flan--check (funcall name "C-c C-e on a bare let sends its scope with it") + (funcall shows "13")) + + ;; A region of several statements reads as one (do ...). + (funcall goto "twice(4)") + (transient-mark-mode 1) + (set-mark (point)) + (funcall goto "else\n 0" t) + (flan-fln-eval-statement) + (test-flan--check (funcall name "C-c C-e on a region of statements evaluates them in order") + (funcall shows "8")) + + ;; C-c C-n sends and moves on. + (funcall goto "twice(4)") + (flan-fln-eval-statement-and-next) + (test-flan--check (funcall name "C-c C-n sends the statement") + (funcall shows "16")) + (test-flan--check (funcall name "and moves to the next") + (looking-at "if 2 > 1")) + + ;; The pause mark. What is sent is a line and column, and the daemon + ;; answers `:pause' only when a form the reader made starts exactly + ;; there (`Ast.mark_pause'). Each kind of target once, and one position + ;; a column off to show the answer can be no. + (dolist (c '(("n - 1)" "a call, from its name") + ("n < 2" "an if statement") + ("t = 0" "a let") + ("i in range" "a for") + ("+ i" "an assignment"))) + (funcall goto (car c)) + (let ((reply (flan-fln-eval-defun '(4)))) + (test-flan--check (funcall name (format "C-u C-c C-c marks %s where the reader starts it" + (cadr c))) + (plist-get reply :pause))) + (flan-fln-eval-defun)) + (test-flan--check (funcall name "and a plain C-c C-c takes the mark down") + (null (flan--pause-overlays))) + (funcall goto "fib(n - 1)") + (let* ((b (flan-fln--toplevel-bounds (point))) + (off (condition-case nil + (plist-get (flan--eval (flan--text (car b) (cdr b)) "defn" + nil nil (cons (1+ (point)) (+ 3 (point)))) + :pause) + (user-error nil)))) + (test-flan--check (funcall name "a position one column off the call is not taken") + (null off))) + (flan-fln-eval-defun) + (set-buffer-modified-p nil) + (kill-buffer)) + ;; Stopped whatever happened above: a daemon this started is its own to end. + (flan-quit)) + (ignore-errors (delete-file sock)) + (ignore-errors (delete-file file)))) + +(message "\nthe .fln keys, against a daemon on each backend") +(test-flan-fln-live--run "x86" nil) +(test-flan-fln-live--run "llvm" '("--llvm")) + +;;; test-flan-fln-live.el ends here diff --git a/emacs/test-flan-fln.el b/emacs/test-flan-fln.el new file mode 100644 index 00000000..bd3ef497 --- /dev/null +++ b/emacs/test-flan-fln.el @@ -0,0 +1,647 @@ +;;; test-flan-fln.el --- The .fln mode, from written-out text -*- lexical-binding: t; -*- + +;; Loaded by test-flan-cider.el, which runs under `dune test', for the reason +;; test-flan-mode.el is: `emacs/*.el' is already that stanza's dependency. +;; Nothing here needs a daemon; what the daemon makes of what these commands +;; send is test-flan-fln-live.el's, run from test-flan.el. +;; +;; Every snippet is text; each check says where point is with a `|' written +;; into it, which is removed before the check runs. + +;;; Code: + +(require 'flan-fln-mode) +(require 'flan) + +(declare-function test-flan--check "test-flan-cider" (name ok)) + +(defmacro test-flan-fln--in (text &rest body) + "Run BODY in a .fln buffer holding TEXT, point where TEXT has its `|'." + (declare (indent 1)) + `(with-temp-buffer + (insert ,text) + (flan-fln-mode) + (goto-char (point-min)) + (when (search-forward "|" nil t) + (delete-char -1)) + ,@body)) + +(defun test-flan-fln--text (b) + (and b (cdr b) (buffer-substring-no-properties (car b) (cdr b)))) + +(defun test-flan-fln--is (name got want) + (test-flan--check name (equal got want)) + (unless (equal got want) + (message " want %S\n got %S" want got))) + +(defun test-flan-fln--thing (thing) + (test-flan-fln--text (bounds-of-thing-at-point thing))) + +(message "\nthe .fln mode") + +;;; One parent + +(test-flan--check "flan-mode is a flan-base-mode" + (provided-mode-derived-p 'flan-mode 'flan-base-mode)) +(test-flan--check "flan-fln-mode is a flan-base-mode" + (provided-mode-derived-p 'flan-fln-mode 'flan-base-mode)) +(test-flan--check ".fln opens in flan-fln-mode" + (eq (cdr (assoc "\\.fln\\'" auto-mode-alist)) 'flan-fln-mode)) +(test-flan-fln--in "fn f() -> i32 = 1\n" + (test-flan--check "a .fln buffer sends the indented syntax" + (equal (flan--syntax) "indented")) + (test-flan--check "and gets the client's completion, as a .flan one does" + (memq #'flan-completion-at-point completion-at-point-functions)) + (test-flan--check "and the modeline indicator" + (member '(:eval (flan-mode-line)) mode-line-misc-info)) + (test-flan--check "the shared keys reach it through the parent's map" + (eq (key-binding (kbd "C-c C-b")) 'flan-cnr-show)) + (test-flan--check "and its own keys pick .fln forms" + (and (eq (key-binding (kbd "C-c C-c")) 'flan-fln-eval-defun) + (eq (key-binding (kbd "C-x C-e")) 'flan-fln-eval-last)))) +(require 'flan-watch) +(let ((b (generate-new-buffer "ghost.fln"))) + (with-current-buffer b (flan-fln-mode)) + (switch-to-buffer b) + (test-flan--check "watch paints ghost text in a shown .fln buffer" + (memq b (flan-watch--ghost-buffers))) + (with-current-buffer b + (insert "fn f() -> ()\n watch-i64(\"x\", 1)\n") + (test-flan--check "and finds a watch call written as a .fln call" + (equal (mapcar #'car (flan-watch--ghost-sites)) '("x")))) + (kill-buffer b)) +(require 'flan-dape) +(test-flan--check "dape offers its config in any Flan buffer" + (equal (plist-get flan-dape-config 'modes) '(flan-base-mode))) +(let ((buffer-file-name "/tmp/x.fln")) + (test-flan--check "and debugs the .fln file it was started from" + (equal (flan-dape--source) "/tmp/x.fln"))) + +;;; The objects + +(defconst test-flan-fln--settle + "fn settle(row: i32, col: i32) -> () + let vel = f32(gravity) + velocity[row, col] + while y > row + if 0 == grid[y, col] + grid[y, col] = grid[row, col] + ; a comment inside the body + + return + let left? = col > 0 + if left? or right? + let side = + if not left? + 1 + elif not right? + -1 + else + if f32(rand()) < 0.5 then 1 else -1 + grid[y, col + side] = grid[row, col] + y = y - 1 + velocity[row, col] = 0.0 + + ; trailing comment, not part of the function + +fn step() -> () + paint-at(i32(m.y) / cell-size, + i32(m.x) / cell-size) + if r >= 0 and r < rows - 1 + and c >= 0 + grid[r, c] = 1 + step() +") + +(defun test-flan-fln--at (text needle) + "TEXT with a `|' before the first NEEDLE." + (let ((i (string-search needle text))) + (concat (substring text 0 i) "|" (substring text i)))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "if 0 == grid") + (test-flan-fln--is "a statement takes its body, through blank and comment lines" + (test-flan-fln--thing 'flan-fln-statement) + "if 0 == grid[y, col] + grid[y, col] = grid[row, col] + ; a comment inside the body + + return") + (test-flan-fln--is "its body is the lines under its first" + (test-flan-fln--thing 'flan-fln-body) + "grid[y, col] = grid[row, col] + ; a comment inside the body + + return")) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "elif not right") + (test-flan-fln--is "on a clause, the statement is its header's, clauses and all" + (test-flan-fln--thing 'flan-fln-statement) + "if not left? + 1 + elif not right? + -1 + else + if f32(rand()) < 0.5 then 1 else -1") + (test-flan-fln--is "and the clause is its own line and block" + (test-flan-fln--thing 'flan-fln-clause) + "elif not right? + -1")) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "1\n elif") + (test-flan-fln--is "a clause is not found from the header's own block" + (test-flan-fln--thing 'flan-fln-clause) nil)) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "if f32(rand())") + (test-flan-fln--is "from inside else's block, the clause is the else" + (test-flan-fln--thing 'flan-fln-clause) + "else + if f32(rand()) < 0.5 then 1 else -1")) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "let side =") + (test-flan-fln--is "let x = with the value as a block" + (test-flan-fln--thing 'flan-fln-statement) + "let side = + if not left? + 1 + elif not right? + -1 + else + if f32(rand()) < 0.5 then 1 else -1")) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "i32(m.x)") + (test-flan-fln--is "a line inside a bracket is part of its statement" + (test-flan-fln--thing 'flan-fln-statement) + "paint-at(i32(m.y) / cell-size, + i32(m.x) / cell-size)") + (test-flan-fln--is "a term is glued, brackets and all" + (test-flan-fln--thing 'flan-fln-term) "i32(m.x)") + (test-flan-fln--is "a group is a bracket pair" + (test-flan-fln--thing 'flan-fln-group) + "(i32(m.y) / cell-size, + i32(m.x) / cell-size)")) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "and c >= 0") + (test-flan-fln--is "an operator continuation line is part of its statement" + (test-flan-fln--thing 'flan-fln-statement) + "if r >= 0 and r < rows - 1 + and c >= 0 + grid[r, c] = 1") + (test-flan-fln--is "and not the start of the body" + (test-flan-fln--thing 'flan-fln-body) "grid[r, c] = 1")) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "velocity[row, col] = 0.0") + (test-flan-fln--is "a top-level form ends before trailing comment lines" + (test-flan-fln--thing 'flan-fln-toplevel) + (substring test-flan-fln--settle 0 + (+ (string-search "= 0.0" test-flan-fln--settle) 5)))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "trailing comment") + (test-flan--check "a comment between forms belongs to the form above" + (string-prefix-p "fn settle" + (test-flan-fln--thing 'flan-fln-toplevel)))) + +(test-flan-fln--in "; a header comment\n|\nfn f() -> i32 = 1\n" + (test-flan-fln--is "before any form, the next one" + (test-flan-fln--thing 'flan-fln-toplevel) "fn f() -> i32 = 1")) + +(test-flan-fln--in "def xs = [1 2\n3 4]\n + 1\nfn|x() -> i32 = 1\n" + (test-flan-fln--is "column 0 inside a bracket or after a leading operator is no form start" + (save-excursion (beginning-of-defun) + (buffer-substring-no-properties (point) (line-end-position))) + "fnx() -> i32 = 1")) + +(test-flan-fln--in "x = 1\nhandler-case\n f()\non E(c)\n nil\n|restart y\n" + (test-flan--check "on and restart at column 0 are clauses, not forms" + (progn (beginning-of-defun) + (looking-at "handler-case")))) + +(test-flan-fln--in "let on = 3\nfoo(x):|\n bar()\n" + (test-flan-fln--is "a term ends before the trailing colon of a call's block" + (test-flan-fln--text (flan-fln--term-before (point))) "foo(x)")) + +(test-flan-fln--in "f(\\(, \\) , x.y)|\n" + (test-flan-fln--is "a character literal is not a bracket" + (test-flan-fln--text (flan-fln--term-before (point))) + "f(\\(, \\) , x.y)")) + +;;; Top-level motion + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle " y = y - 1") + (beginning-of-defun) + (test-flan--check "C-M-a goes to the form's first line" (looking-at "fn settle")) + (end-of-defun) + (test-flan--check "C-M-e goes past its last code line, not its trailing comment" + (save-excursion (forward-line -1) + (looking-at " velocity\\[row, col\\] = 0.0"))) + (end-of-defun) + (test-flan--check "and the next C-M-e ends the next form" + (= (point) (point-max))) + (goto-char (point-max)) + (beginning-of-defun) + (test-flan--check "C-M-a from the end reaches the last form" (looking-at "fn step")) + (mark-defun) + (test-flan--check "C-M-h marks the form" + (let ((m (buffer-substring (region-beginning) (region-end)))) + (and (string-prefix-p "fn step" (string-trim-left m "\n")) + (string-suffix-p " step()\n" m))))) + +;;; Statement motion + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle " let left?") + (flan-fln-backward-statement) + (test-flan--check "M-a at a statement's start goes to the one before at its level" + (looking-at "if 0 == grid")) + (flan-fln-backward-statement) + (test-flan--check "and out to the owner when there is none" (looking-at "while y")) + (flan-fln-forward-statement) + (test-flan--check "M-e goes to the end of the statement, body and all" + (looking-back "y = y - 1" (line-beginning-position))) + (flan-fln-forward-statement) + (test-flan--check "and again, to the end of the next" + (looking-back "= 0.0" (line-beginning-position)))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle " -1") + (flan-fln-up) + (test-flan--check "C-M-u goes to the line that owns the block" + (looking-at "elif not right")) + (flan-fln-up) + (test-flan--check "and from there to its owner's" (looking-at "let side"))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "m.x)") + (flan-fln-up) + (test-flan--check "C-M-u inside a bracket goes to the bracket" (looking-at "(m.x)"))) + +;;; What each key sends + +;; The request, captured where it leaves: the daemon's answer is the live +;; test's business, and here what matters is which text went out and where +;; it said the text starts. +(defvar test-flan-fln--sent nil) + +(defmacro test-flan-fln--sending (&rest body) + `(progn + (setq test-flan-fln--sent nil) + (cl-letf (((symbol-function 'flan--request) + (lambda (form) (push form test-flan-fln--sent) + (list :status "ok" :value "0"))) + ((symbol-function 'pulse-momentary-highlight-region) #'ignore)) + ,@body) + (car test-flan-fln--sent))) + +(defun test-flan-fln--sent-code (req) + (plist-get req :code)) + +(defconst test-flan-fln--prog + "fn fib(n: i64) -> i64 + if n < 2 + n + else + fib(n - 1) + fib(n - 2) + +comment(): + twice(4) + let x = 3 + if x > 2 + twice(x) + else + 0 + +fn twice(n: i64) -> i64 = n * 2 +") + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "fib(n - 1)") + (let ((r (test-flan-fln--sending (flan-fln-eval-defun)))) + (test-flan--check "C-c C-c inside a fn installs the whole fn" + (and (equal (plist-get r :op) "eval") + (string-suffix-p "fib(n - 1) + fib(n - 2)" + (test-flan-fln--sent-code r)) + (string-prefix-p "fn fib" (test-flan-fln--sent-code r)) + (equal (plist-get r :syntax) "indented"))))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "twice(4)") + (let ((r (test-flan-fln--sending (flan-fln-eval-defun)))) + (test-flan--check "C-c C-c on a column-0 call evaluates it" + (equal (plist-get r :op) "eval-expr")))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "\n let x") + (let ((r (test-flan-fln--sending (flan-fln-eval-last)))) + (test-flan--check "C-x C-e at a line's end sends the statement ending there" + (and (equal (plist-get r :op) "eval-expr") + (equal (test-flan-fln--sent-code r) "twice(4)") + (equal (plist-get r :line) 8) + (equal (plist-get r :col) 3))))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "\n else\n 0") + (let ((r (test-flan-fln--sending (flan-fln-eval-last)))) + (test-flan--check "the innermost one: the last line of a block, not the if" + (equal (test-flan-fln--sent-code r) "twice(x)")))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "(4)") + (let ((r (test-flan-fln--sending (flan-fln-eval-last)))) + (test-flan--check "C-x C-e inside a line sends the term before point" + (and (equal (test-flan-fln--sent-code r) "twice") + (equal (plist-get r :col) 3))))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "\n\ncomment") + (let ((r (test-flan-fln--sending (flan-fln-eval-last)))) + (test-flan--check "at the end of a fn's last line, the innermost statement, not the fn" + (equal (test-flan-fln--sent-code r) "fib(n - 1) + fib(n - 2)")))) + +(test-flan-fln--in test-flan-fln--prog + (goto-char (point-max)) + (skip-chars-backward "\n") + (let ((r (test-flan-fln--sending (flan-fln-eval-last)))) + (test-flan--check "a column-0 one-line fn at its end is installed" + (and (equal (plist-get r :op) "eval") + (string-suffix-p "fn twice(n: i64) -> i64 = n * 2" + (test-flan-fln--sent-code r)))))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "else\n 0") + (let ((r (test-flan-fln--sending (flan-fln-eval-statement)))) + (test-flan--check "C-c C-e on a clause sends its whole statement" + (and (equal (test-flan-fln--sent-code r) + "if x > 2\n twice(x)\n else\n 0") + (equal (plist-get r :line) 10) + (equal (plist-get r :col) 3))))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "let x = 3") + (let ((r (test-flan-fln--sending (flan-fln-eval-statement)))) + (test-flan--check "C-c C-e on a bare let sends it with the rest of its block" + (equal (test-flan-fln--sent-code r) + "let x = 3\n if x > 2\n twice(x)\n else\n 0")))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "twice(4)") + (let ((r (test-flan-fln--sending (flan-fln-eval-statement-and-next)))) + (test-flan--check "C-c C-n sends the statement" + (equal (test-flan-fln--sent-code r) "twice(4)")) + (test-flan--check "and moves to the next" (looking-at "let x = 3")))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "twice(4)") + (transient-mark-mode 1) + (set-mark (point)) + (search-forward "twice(x)") + (forward-char -3) + (let ((r (test-flan-fln--sending (flan-fln-eval-statement)))) + (test-flan--check "C-c C-e sends the region's whole lines" + (equal (test-flan-fln--sent-code r) + "twice(4)\n let x = 3\n if x > 2\n twice(x)")))) + +;; The pause target. The position sent is where the reader starts the form, +;; which for a call is its name and not its parenthesis; the live test checks +;; the daemon finds a form there. +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "n - 1)") + (let ((r (test-flan-fln--sending (flan-fln-eval-defun '(4))))) + (test-flan-fln--is "C-u C-c C-c in a call marks the call, from its name" + (plist-get r :pause) '(5 5)))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "< 2") + (let ((r (test-flan-fln--sending (flan-fln-eval-defun '(4))))) + (test-flan-fln--is "outside a bracket, the statement on point's line" + (plist-get r :pause) '(2 3)))) + +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "n < 2") + (let ((r (test-flan-fln--sending (flan-fln-eval-defun '(16))))) + (test-flan-fln--is "C-u C-u, the fn: stop on entry" + (plist-get r :pause) '(1 1)))) + +(test-flan-fln--in "fn f(x: i64) -> i64\n g((x| + 1), [x 2])\n" + (let ((r (test-flan-fln--sending (flan-fln-eval-defun '(4))))) + (test-flan-fln--is "a free parenthesis marks the value inside it" + (plist-get r :pause) '(2 6)))) + +;;; Indentation + +(defun test-flan-fln--tabs (text n) + "The column TEXT's `|' line reaches after N TABs." + (test-flan-fln--in text + (let ((last-command nil) (this-command 'indent-for-tab-command)) + (dotimes (_ n) + (indent-for-tab-command) + (setq last-command 'indent-for-tab-command))) + (current-indentation))) + +(defconst test-flan-fln--nest + "fn f() -> () + while a + if b + c() +|") + +(test-flan-fln--is "the first TAB after a block goes to its column" + (test-flan-fln--tabs test-flan-fln--nest 1) 6) +(test-flan-fln--is "each TAB after that steps out one" + (list (test-flan-fln--tabs test-flan-fln--nest 2) + (test-flan-fln--tabs test-flan-fln--nest 3) + (test-flan-fln--tabs test-flan-fln--nest 4) + (test-flan-fln--tabs test-flan-fln--nest 5)) + '(4 2 0 6)) +(test-flan-fln--is "after a header, one level deeper first" + (test-flan-fln--tabs "fn f() -> ()\n while a\n|" 1) 4) +(test-flan-fln--is "after a trailing colon too" + (test-flan-fln--tabs "rl/with-drawing():\n|" 1) 2) +(test-flan-fln--is "and after let x =" + (test-flan-fln--tabs "def colors =\n|" 1) 2) +(test-flan-fln--is "but not after a one-line fn" + (test-flan-fln--tabs "fn f() -> i32 = 1\n|" 1) 0) +(test-flan-fln--is "else goes to its if's column, whatever the depth" + (test-flan-fln--tabs "if a\n if b\n c\n |else" 1) 2) +(test-flan-fln--is "and a second TAB to the outer if's" + (test-flan-fln--tabs "if a\n if b\n c\n |else" 2) 0) +(test-flan-fln--is "on goes to its handler-case's" + (test-flan-fln--tabs " handler-case\n f()\n |on E(c)" 1) 2) +(test-flan-fln--is "inside a call, under its first argument" + (test-flan-fln--tabs " paint-at(i32(m.y) / cell-size,\n|i32(m.x))" 1) 11) +(test-flan-fln--is "inside a bracket with nothing after it, one level in" + (test-flan-fln--tabs " let v = [\n|1 2]" 1) 4) +(test-flan-fln--is "a closing bracket, at its opening line's column" + (test-flan-fln--tabs " let v = [\n 1 2\n|]" 1) 2) +(test-flan-fln--is "after a line ending in an operator, deeper than its statement" + (test-flan-fln--tabs " if a and\n|b" 1) 4) + +(test-flan-fln--in "fn f() -> ()\n while a\n b()\n |" + (flan-fln-dedent-or-delete 1) + (test-flan-fln--is "backspace in the indentation drops one level" + (current-indentation) 2) + (flan-fln-dedent-or-delete 1) + (test-flan-fln--is "and another" (current-indentation) 0)) + +(test-flan-fln--in "fn f() -> ()\n ab|" + (flan-fln-dedent-or-delete 1) + (test-flan-fln--is "backspace after text deletes a character" + (buffer-substring (line-beginning-position) (point)) " a")) + +(test-flan-fln--in "if a\n if b\n c\n els|" + (let ((last-command-event ?e)) + (insert "e") + (run-hooks 'post-self-insert-hook)) + (let ((last-command-event ?\s)) + (insert " ") + (run-hooks 'post-self-insert-hook)) + (test-flan-fln--is "else snaps to its if as it is typed" + (current-indentation) 2)) + +(test-flan-fln--in "fn f() -> ()\n if a\n b\n| c\n d\n" + (indent-region (point) (point-max)) + (test-flan-fln--is "indent-region moves a block rigidly" + (buffer-substring (point) (point-max)) + " c\n d\n")) + +(test-flan-fln--in "fn f() -> ()\n if a\n b\n |c\n" + (indent-region (point-min) (point-max)) + (test-flan-fln--is "and leaves lines at valid columns alone" + (buffer-string) "fn f() -> ()\n if a\n b\n c\n")) + +(test-flan-fln--in "fn f() -> ()\n if a\n b\n |\n" + (kill-new "if x\n y\n else\n z") + (flan-fln-yank) + (test-flan-fln--is "a statement cut from its first character yanks as one block" + (buffer-string) + "fn f() -> ()\n if a\n b\n if x\n y\n else\n z\n")) + +(test-flan-fln--in "fn f() -> ()\n if a\n |\n" + (kill-new " while x\n y\n") + (flan-fln-yank) + (test-flan-fln--is "whole lines yank at point's column" + (buffer-string) + "fn f() -> ()\n if a\n while x\n y\n\n")) + +;;; Block editing + +(test-flan-fln--in "fn f() -> ()\n if a\n |b()\n c()\n d()\n" + (flan-fln-slurp) + (test-flan-fln--is "slurp pulls the next statement into the block" + (buffer-string) "fn f() -> ()\n if a\n b()\n c()\n d()\n") + (flan-fln-barf) + (test-flan-fln--is "barf pushes the last one out again" + (buffer-string) "fn f() -> ()\n if a\n b()\n c()\n d()\n")) + +(test-flan-fln--in "fn f() -> ()\n |a()\n if x\n y\n b()\n" + (flan-fln-move-statement-down) + (test-flan-fln--is "a statement moves down past its sibling's whole block" + (buffer-string) "fn f() -> ()\n if x\n y\n a()\n b()\n") + (test-flan--check "and point moves with it" (looking-at "a()")) + (flan-fln-move-statement-up) + (test-flan-fln--is "and back up" + (buffer-string) "fn f() -> ()\n a()\n if x\n y\n b()\n")) + +(test-flan-fln--in "fn f() -> ()\n when(c):\n if x\n |y\n" + (flan-fln-raise-statement) + (test-flan-fln--is "raise replaces the owner with the statement" + (buffer-string) "fn f() -> ()\n when(c):\n y\n")) + +(test-flan-fln--in "fn f() -> ()\n |if x\n y\n else\n z\n b()\n" + (flan-fln-kill-statement) + (test-flan-fln--is "kill takes the whole statement's lines" + (buffer-string) "fn f() -> ()\n b()\n") + (test-flan-fln--is "into the kill ring" (current-kill 0) + " if x\n y\n else\n z\n")) + +;;; expand-region, where it is installed + +(let* ((dirs (append (file-expand-wildcards "~/.config/emacs/elpa/expand-region-[0-9]*") + (file-expand-wildcards "~/.emacs.d/elpa/expand-region-[0-9]*"))) + (load-path (append dirs load-path))) + (if (not (require 'expand-region nil t)) + (message " skip expand-region (not installed)") + (test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "right?\n -1") + (transient-mark-mode 1) + (let ((steps nil)) + (dotimes (_ 6) + (er/expand-region 1) + (push (buffer-substring-no-properties (region-beginning) (region-end)) steps)) + (setq steps (nreverse steps)) + (test-flan-fln--is "term, then statement's clause, then statement, then out" + (mapcar (lambda (s) (car (split-string s "\n"))) steps) + '("right?" "elif not right?" "if not left?" "let side =" + "if left? or right?" "let left? = col > 0")))))) + +;;; smartparens, where it is installed + +(let* ((dirs (append (file-expand-wildcards "~/.config/emacs/elpa/smartparens-[0-9]*") + (file-expand-wildcards "~/.emacs.d/elpa/smartparens-[0-9]*") + (file-expand-wildcards "~/.config/emacs/elpa/dash-[0-9]*") + (file-expand-wildcards "~/.emacs.d/elpa/dash-[0-9]*"))) + (load-path (append dirs load-path))) + (if (not (require 'smartparens nil t)) + (message " skip smartparens (not installed)") + ;; A setup that puts sexp commands on the top-level keys, as the + ;; author's does. + (define-key smartparens-mode-map (kbd "C-M-a") 'sp-backward-down-sexp) + (define-key smartparens-mode-map (kbd "C-M-u") 'sp-backward-up-sexp) + (let ((b (generate-new-buffer "sp.fln"))) + (switch-to-buffer b) + (flan-fln-mode) + (test-flan--check "smartparens is on in a .fln buffer" smartparens-mode) + (test-flan--check "and C-M-a and C-M-u stay the mode's" + (and (eq (key-binding (kbd "C-M-a")) 'beginning-of-defun) + (eq (key-binding (kbd "C-M-u")) 'flan-fln-up))) + (execute-kbd-macro "f(") + (test-flan-fln--is "it pairs a bracket" (buffer-string) "f()") + (erase-buffer) + (execute-kbd-macro "'a") + (test-flan-fln--is "and not a quote" (buffer-string) "'a") + (set-buffer-modified-p nil) + (kill-buffer b)) + (define-key smartparens-mode-map (kbd "C-M-a") nil) + (define-key smartparens-mode-map (kbd "C-M-u") nil))) + +;;; Under Evil + +(let* ((dirs (append (file-expand-wildcards "~/.config/emacs/elpa/evil-[0-9]*") + (file-expand-wildcards "~/.emacs.d/elpa/evil-[0-9]*") + (file-expand-wildcards "~/.config/emacs/elpa/goto-chg-*") + (file-expand-wildcards "~/.emacs.d/elpa/goto-chg-*"))) + (load-path (append dirs load-path))) + (if (not (require 'evil nil t)) + (message " skip the .fln text objects (Evil is not installed)") + (evil-mode 1) + (unwind-protect + (let ((yanked + (lambda (text keys) + (let ((b (generate-new-buffer "objects.fln"))) + (switch-to-buffer b) + (insert text) + (flan-fln-mode) + (evil-initialize-state) + (evil-normal-state) + (goto-char (point-min)) + (search-forward "|") + (delete-char -1) + (execute-kbd-macro keys) + (prog1 (substring-no-properties (current-kill 0)) + (set-buffer-modified-p nil) + (kill-buffer b)))))) + (dolist (c `(("yiw" ,(test-flan-fln--at test-flan-fln--settle "settle(") + "settle") + ("yie" ,(test-flan-fln--at test-flan-fln--settle "i32(m.x)") + "i32(m.x)") + ("yis" ,(test-flan-fln--at test-flan-fln--settle "and c >= 0") + "if r >= 0 and r < rows - 1\n and c >= 0\n grid[r, c] = 1") + ("yas" ,(test-flan-fln--at test-flan-fln--settle "and c >= 0") + " if r >= 0 and r < rows - 1\n and c >= 0\n grid[r, c] = 1\n") + ("yii" ,(test-flan-fln--at test-flan-fln--settle "if not left") + " 1\n") + ("yik" ,(test-flan-fln--at test-flan-fln--settle "if f32(rand())") + " if f32(rand()) < 0.5 then 1 else -1\n") + ("yak" ,(test-flan-fln--at test-flan-fln--settle "if f32(rand())") + " else\n if f32(rand()) < 0.5 then 1 else -1\n") + ("yid" ,(test-flan-fln--at test-flan-fln--settle "paint-at") + ,(substring test-flan-fln--settle + (string-search "fn step" test-flan-fln--settle))))) + (test-flan-fln--is (format "under Evil, %s" (car c)) + (funcall yanked (nth 1 c) (car c)) (nth 2 c))) + (let ((b (generate-new-buffer "keys.fln"))) + (switch-to-buffer b) + (insert "fn f() -> i32 = 1\n") + (flan-fln-mode) + (evil-initialize-state) + (test-flan--check "under Evil, C-x C-e is still the mode's" + (eq (key-binding (kbd "C-x C-e")) 'flan-fln-eval-last)) + (goto-char (point-min)) + (end-of-line) + (backward-char) + (test-flan--check "under Evil, C-x C-e counts the cursor's character" + (= (flan-fln--point-for-last) (line-end-position))) + (kill-buffer b))) + (evil-mode -1)))) + +;;; test-flan-fln.el ends here diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 74853a05..86982546 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -2455,6 +2455,13 @@ already rely on it — so nothing here is a stand-in for the real thing." (ignore-errors (delete-file socket6)) (ignore-errors (delete-file scratch))) + ;; ── The .fln keys, against daemons of their own ──────────────────────── + (setq test-flan-fln-live-dir (file-name-directory file) + test-flan-fln-live-socket socket) + (load (expand-file-name "test-flan-fln-live.el" + (file-name-directory load-file-name)) + nil t) + (if (zerop test-flan--failures) (message "flan.el: all tests passed") (message "\n%d failure(s)" test-flan--failures) diff --git a/spec-syntax.md b/spec-syntax.md index c62dcd24..5f7fc527 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -356,6 +356,10 @@ Each step lands on its own, with `dune test --root .` green. `flan--pause-bounds` at `flan.el:2637-2660`) must equal the start location the reader gave that form. `Ast.mark_pause` matches exactly (`ast.ml:491-492`). + + **Built** (`emacs/flan-fln-mode.el`; keys and objects in `emacs/MANUAL.md`, + "Indented files"). A line ending in `=` or `fn(…)` also opens a block for + TAB, and a body is its statement's own block, up to its first clause. 6. **Return-type inference** in `Check`, with the recursion refusal and the stale-caller cause. This is independent of steps 1-5 once the marker exists. From ff8b61e44ce8212e558e758c06418a4163e75d07 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 19:57:58 +0700 Subject: [PATCH 08/20] A self-containing or runaway generic struct and a where clause over a length are each one error among the file's others, and a literal that does not fit a variable a typed field decided names that field --- lib/check.ml | 102 +++++++++++++++++++++++++++++++++++++++++----- test/test_flan.ml | 41 +++++++++++++++++++ 2 files changed, 133 insertions(+), 10 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 25f7018e..670a5f8d 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -251,6 +251,15 @@ type env = { (* The struct copies this env made, by key, and whether each is one at variables — those are left out of the program. *) copies : (string, bool) Hashtbl.t; + (* Templates whose own check was refused while [deferred] was collecting: + a use of one is a copy with no fields, so the refusal is said once, at + the defstruct, and nothing downstream repeats it. *) + broken : (string, unit) Hashtbl.t; + (* While a whole-file check collects every error, the refusals [collect] + can go on past — a generic struct's template, a where clause over a + length — are kept here instead of ending the pass. [None] everywhere + else, where they raise as before. *) + mutable deferred : Loc.diag list option; (* A generic defn's length variables, by name: the ones of its [gsigs] variables that are lengths. *) glens : (string, string list) Hashtbl.t; @@ -329,6 +338,8 @@ let new_env () = { refused_generics = Hashtbl.create 4; gstructs = Hashtbl.create 4; copies = Hashtbl.create 8; + broken = Hashtbl.create 2; + deferred = None; glens = Hashtbl.create 8; lenvars = []; len_placeholder = false; @@ -343,6 +354,13 @@ let new_env () = { guard_next = false; } +(* A refusal [collect] can go on past: kept while a whole-file check is + collecting, in the order found, and raised otherwise. *) +let defer_or_raise env (d : Loc.diag) = + match env.deferred with + | Some l -> env.deferred <- Some (d :: l) + | None -> Loc.raise_diag d + (* Where a named type was declared, and what it has, as a note. This is the second half of the two-place messages: a refusal that says @@ -1599,9 +1617,14 @@ and struct_len_arg env name p (a : Ast.texpr) = (* The copy of generic struct [name] at [targs], made on first use and registered as an ordinary struct under its key. *) -and struct_copy env loc name targs = +and struct_copy ?(at_definition = false) env loc name targs = let key = struct_app name targs in if Hashtbl.mem env.copies key then key + else if Hashtbl.mem env.broken name then begin + Hashtbl.replace env.copies key (List.exists generic_arg targs); + Hashtbl.replace env.structs key { Tast.sname = key; fields = [] }; + key + end else begin if Hashtbl.mem env.structs key || Hashtbl.mem env.datas key || Hashtbl.mem env.unions key then @@ -1673,7 +1696,7 @@ and struct_copy env loc name targs = (* A field refused inside the template says nothing about which use asked for this copy; the note names it, one per level of copies. *) (match e with - | Loc.Error d when d.Loc.dloc <> loc -> + | Loc.Error d when d.Loc.dloc <> loc && not at_definition -> Loc.raise_diag { d with Loc.notes = @@ -6810,9 +6833,37 @@ and generic_ctor ctx ~want loc name given = them, as a generic call's literal arguments meet at the wider type — [(Pair 1 2.5)] is a [(Pair f64)]. *) let lit_only = ref [] in + (* Which field's value decided each variable, for the refusal of a + literal that does not fit what it decided. *) + let decided_by = ref [] in List.iter (fun ((f : Tast.field), (a : Ast.expr)) -> match f.Tast.fty with + (* A literal at a variable a typed field already decided: it has to + be usable at that type, and when it is not the refusal names the + field that decided it. *) + | Types.Var v + when literal a && List.mem_assoc v !subst + && not (List.mem v !lit_only) -> + let b = List.assoc v !subst in + (match a.Ast.e, b with + | Ast.Float x, Types.Int _ -> + let notes = + match List.assoc_opt v !decided_by with + | Some (fname, at) -> + [ Loc.note at + (Printf.sprintf ".%s is %s here, which decides $%s" fname + (Types.to_string b) v) ] + | None -> [] + in + Loc.failk "check/generic-struct-field" a.Ast.loc ~notes + "%s's .%s is $%s, which is %s here, and %g is a float literal. \ + Write .%s as an integer, or give .%s a float type" + name f.Tast.fname v (Types.to_string b) x f.Tast.fname + (match List.assoc_opt v !decided_by with + | Some (fname, _) -> fname + | None -> f.Tast.fname) + | _ -> ()) | Types.Var v when literal a && not (List.mem_assoc v !subst && not (List.mem v !lit_only)) -> let t = (literal_type a) in (match List.assoc_opt v !subst with @@ -6841,7 +6892,14 @@ and generic_ctor ctx ~want loc name given = nothing. *) | None -> Option.iter (fun d -> unsure := d :: !unsure) refusal | Some t -> - if not (bind_ty subst f.Tast.fty t) then + let before = !subst in + if bind_ty subst f.Tast.fty t then + List.iter + (fun (v, _) -> + if not (List.mem_assoc v before) then + decided_by := (v, (f.Tast.fname, a.Ast.loc)) :: !decided_by) + !subst + else fail a.Ast.loc "%s's .%s is %s here, and this is %s" (Types.to_string (Types.Named open_key)) f.Tast.fname (Types.to_string (subst_ty !subst f.Tast.fty)) @@ -13370,9 +13428,14 @@ let collect env (decls : Ast.decl list) = type in a field is refused at the defstruct rather than at the first use of it. *) let g = Hashtbl.find env.gstructs n in - ignore - (struct_copy env loc n - (List.map (fun (p, _) -> Types.Var p) g.gparams)) + (match + struct_copy ~at_definition:true env loc n + (List.map (fun (p, _) -> Types.Var p) g.gparams) + with + | _ -> () + | exception Loc.Error d -> + Hashtbl.replace env.broken n (); + defer_or_raise env d) | Ast.Defstruct (n, fs, parent) -> let names = List.map (fun (f : Ast.field) -> f.Ast.fname) fs in if List.length (List.sort_uniq compare names) <> List.length names then @@ -13517,10 +13580,22 @@ let collect env (decls : Ast.decl list) = an open question in TODO.org, not an accident to fall out of this. *) if List.mem p.Ast.pvar lens then - Loc.failk "check/length-predicate" p.Ast.ploc - "$%s is a length, and a where clause takes type predicates \ - only — %s is about a type" p.Ast.pvar p.Ast.pname) + defer_or_raise env + (Loc.diag ~kind:"check/length-predicate" p.Ast.ploc + (Printf.sprintf + "$%s is a length, and a where clause takes type \ + predicates only — %s is about a type" + p.Ast.pvar p.Ast.pname))) fn.Ast.fwhere; + (* A predicate over a length was refused above; what is left is the + clause every copy is judged against. *) + let fn = + { fn with + Ast.fwhere = + List.filter + (fun (p : Ast.pred) -> not (List.mem p.Ast.pvar lens)) + fn.Ast.fwhere } + in env.tyvars <- vars; env.lenvars <- lens; env.tvpreds <- fn.Ast.fwhere; @@ -13623,7 +13698,10 @@ let collect env (decls : Ast.decl list) = out or a zero value is built for it — which would not fail, it would hang. *) let check_finite env = let walk _ n = finite_from env n in - Hashtbl.iter (fun n _ -> walk [] n) env.structs; + (* A generic struct's copy was asked this when it was made. *) + Hashtbl.iter + (fun n _ -> if not (Hashtbl.mem env.copies n) then walk [] n) + env.structs; Hashtbl.iter (fun n _ -> walk [] n) env.datas; Hashtbl.iter (fun n _ -> walk [] n) env.unions @@ -14978,10 +15056,14 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : time it runs every signature is sound, so a body that fails to check cannot make the next body fail — which is what makes a declaration a resync point that needs no resynchronising. *) + if keep_going then env.deferred <- Some []; let decls = collect env decls in check_finite env; check_union_members env; let s = Loc.sink ~on:keep_going in + (match env.deferred with + | Some ds -> s.Loc.found <- ds; env.deferred <- None + | None -> ()); ignore (Loc.caught s (fun () -> check_main env decls)); (* Every generic body, checked once with its variables left abstract, and the result thrown away. This is the pass plan.org's rule needs and Odin diff --git a/test/test_flan.ml b/test/test_flan.ml index ed62a56b..6aca6d1e 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6017,6 +6017,47 @@ let () = = [ "show is instantiated at $t = (CFn [] i32) here"; "outer is instantiated at $t = (CFn [] i32) here" ])); + (* A refusal made while collecting declarations — a generic struct that + holds itself, one that grows without end, a where clause over a length — + is one error among the rest of the file's, not the end of the check. *) + let all_lines src = + match Check.program_all (Parse.program_all (read src)) with + | _ -> [] + | exception Loc.Errors ds -> + List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds + in + check "a self-containing generic struct is one error of several" + (all_lines + "(defstruct Loop [next (Loop $t)])\n\ + (defn g [] i32 (let [p (the (Loop i32) (zeroed))] nope1))\n\ + (defn h [] i32 nope2)\n" + = [ 1; 2; 3 ]); + check "a generic struct that grows without end is one error of several" + (all_lines + "(defstruct Grow [next (Ptr (Grow [$t]))])\n\ + (defn g [] i32 (let [p (the (Grow i32) (zeroed))] nope1))\n\ + (defn h [] i32 nope2)\n" + = [ 1; 2; 3 ]); + check "a where clause over a length is one error of several" + (all_lines + "(defn f [a [$n i32]] i32 {:where (numeric? $n)} nope1)\n\ + (defn h [] i32 nope2)\n" + = [ 1; 1; 2 ]); + (* A literal that does not fit what a typed field decided names that field. *) + (match + checked + "(defstruct Pair [a $t b $t]) \ + (defn main [] i32 (let [p (Pair (the i32 1) 2.5)] 0))" + with + | _ -> check "a float literal where a typed field decided i32" false + | exception Loc.Error d -> + check "the refusal names the field that decided the variable" + (contains d.Loc.dmsg "Pair's .b is $t, which is i32 here" + && List.exists + (fun (n : Loc.note) -> + contains n.Loc.nmsg ".a is i32 here, which decides $t") + d.Loc.notes)); + (* A copy that cannot be built at a closure's type: the zeroed value in the body is refused there, and the call that asked is named. *) (match From df00848910234e2c638c4319b91972d6bf8ef4f8 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:00:51 +0700 Subject: [PATCH 09/20] A struct value's printed head comes from Render.head, which every renderer shares --- lib/render.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/lib/render.ml b/lib/render.ml index 1f16802c..5cf3f33f 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -103,6 +103,12 @@ let print_refusal _loc t = Printf.sprintf "no printer for %s — print the values you want out of it" (Types.to_string t) +(* The head a struct value prints under: its name, or for a generic struct's + copy the template and its arguments, [Pair i32], so the value reads + [(Pair i32 {.a 1 .b 2})] the way its type is written. Every renderer of a + struct value goes through this, so they all print the same text. *) +let head n = Types.struct_head n + let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr list = let render c depth e = render ~refuse c depth e in let loc = e.Tast.loc in @@ -333,7 +339,7 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis @ render c (depth + 1) v) shown) in - [ do_ ((lit ("(" ^ Types.struct_head n ^ " {") :: parts) + [ do_ ((lit ("(" ^ head n ^ " {") :: parts) @ (if List.length fields > max_span then [ lit " ..." ] else []) @ [ lit "})" ]) ]) (* A fixed array's length is in its type, so it unrolls — capped, because From 5d3a0fc316d1ea1eacd2f1fc139f3941eec445af Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:14:22 +0700 Subject: [PATCH 10/20] Inferring a closure return and recompiling a _ caller after its callee changes wait behind .fln --- TODO.org | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/TODO.org b/TODO.org index 91b6fb73..87fae9fa 100644 --- a/TODO.org +++ b/TODO.org @@ -637,6 +637,10 @@ of !=. * Checker +** WAIT A _ body that returns an fn literal +Refused today; allowing it when the literal writes its parameter types is the +proposal. Postponed 2026-09-25 while .fln takes priority. + ** DONE The ownership flow analysis is repealed CLOSED: [2026-09-18] Static use-after-move and double-free checking is gone; types, allocators and the @@ -1426,6 +1430,11 @@ out the first element typing the rest. * Dev loop +** WAIT A _ caller whose type follows a redefined callee +Its signature changes in the session but its body is not recompiled, so every call +stops on StaleCall naming a type nobody wrote. Proposal: recompile such callers. +Postponed 2026-09-25 while .fln takes priority. + ** TODO A prelude function shadowed live is reached by the prelude's own calls A defn of a prelude function's name sent to a running =flan dev= installs into the host's cell for that name, so the prelude's calls compiled into the host follow it; From 267e84badab03140b076b48cac069334c2638948 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:14:51 +0700 Subject: [PATCH 11/20] In a .fln buffer numbers are coloured, a colon is not part of a name, TAB keeps a line at a valid column, evil line objects take their newline, and C-x C-e and C-u C-c C-c understand match arms, conditions, clauses and comments --- emacs/MANUAL.md | 6 +- emacs/flan-fln-mode.el | 169 +++++++++++++++++++++++++++++------- emacs/test-flan-fln-live.el | 33 +++++++ emacs/test-flan-fln.el | 142 ++++++++++++++++++++++++++++++ 4 files changed, 318 insertions(+), 32 deletions(-) diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 872c6199..987fc20d 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -1186,8 +1186,8 @@ Use `C-c C-g` if you need frames. | Holy | Evil | Does | |---|---|---| | `C-c C-c`, `C-M-x` | same | the top-level form: a declaration installed, anything else evaluated | -| `C-u C-c C-c` | same | ...and stop at the innermost bracket group, else the statement on point's line (`C-u C-u`: on entry) | -| `C-x C-e` | same, cursor on the line's last character | at a line's end, the innermost statement ending there; elsewhere, the term before point | +| `C-u C-c C-c` | same | ...and stop at the innermost bracket group, else the statement on point's line: an elif's condition, an else's block, a match arm's value (`C-u C-u`: on entry) | +| `C-x C-e` | same, cursor on the line's last character | at a line's end, the innermost statement ending there: a match arm's value, an if/elif/while condition, or the whole statement a header or clause line opens; elsewhere, the term before point | | `C-c C-e` | same | the statement at point with its body and clauses, or the region's whole lines; on a bare `let x = v`, the `let` and the rest of its block | | `C-c C-n` | same | `C-c C-e`, then move to the next statement | | `C-c C-k` | same | the whole buffer | @@ -1195,7 +1195,7 @@ Use `C-c C-g` if you need frames. | `M-a` / `M-e` | `(` / `)` | statement: start / end (`)`: start of the next) | | `C-M-u` | same | up to the enclosing bracket, or the line that owns the block | | `C-M-f` / `C-M-b` | same | brackets and terms, as everywhere | -| `TAB` | same | deepest valid column first; each repeat steps out a level | +| `TAB` | same | a line at a valid column stays; an empty or misplaced line goes deepest; each repeat steps out a level | | `DEL` in indentation | same | drop one level | | `C-c <` / `C-c >` | `<` / `>` | shift the region's lines a level | | `M-` / `M-` | same | move the statement past its neighbour | diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el index d9182a64..56a43d0b 100644 --- a/emacs/flan-fln-mode.el +++ b/emacs/flan-fln-mode.el @@ -117,10 +117,13 @@ fine here. Brackets and strings are still paired." (let ((table (make-syntax-table))) ;; Name characters: a name is anything up to a delimiter (`is_delimiter' ;; in lib/reader.ml), so `key-pressed?', `dyn->f64' and `rl/draw-fps' are - ;; one symbol each. `:' too, so `:key-r' is one; the colon of `x: T' is - ;; glued to the name and is trimmed off a term where it matters. - (dolist (c '(?- ?_ ?? ?! ?/ ?. ?$ ?& ?* ?+ ?< ?> ?= ?% ?: ?@ ?# ?^ ?| ?~)) + ;; one symbol each. + (dolist (c '(?- ?_ ?? ?! ?/ ?. ?$ ?& ?* ?+ ?< ?> ?= ?% ?@ ?# ?^ ?| ?~)) (modify-syntax-entry c "_" table)) + ;; Not `:', which ends `x: T' and `comment:': a name glued to it would + ;; otherwise read as `x:', a name nothing defines. A `:key' keyword is + ;; drawn by its own font-lock rule instead. + (modify-syntax-entry ?: "." table) (modify-syntax-entry ?\; "<" table) (modify-syntax-entry ?\n ">" table) (modify-syntax-entry ?\" "\"" table) @@ -473,9 +476,12 @@ For `end-of-defun-function'." (and (< beg end) (cons beg end)))))) (defun flan-fln--term-before (pos) - "Bounds of the term that ends at POS, spaces before POS skipped, or nil." + "Bounds of the term that ends at POS, spaces before POS skipped, or nil. +A comment is skipped too: nothing in one is a term." (save-excursion (goto-char pos) + (let ((s (syntax-ppss pos))) + (when (nth 4 s) (goto-char (nth 8 s)))) (skip-chars-backward " \t,") (let* ((end (point)) (beg (flan-fln--term-back end)) @@ -560,11 +566,82 @@ Two: B itself, which stops on entry." (t (or (flan-fln--pause-target (point) b) b)))) (defun flan-fln--pause-target (pos b) - (let ((g (flan-fln--group-bounds pos))) - (if (and g (cdr g) (> (car g) (car b))) - (cons (flan-fln--group-form-start (car g)) (cdr g)) - (let ((s (flan-fln--statement-start-at pos))) - (and s (flan-fln--statement-bounds s)))))) + "The form to stop at for point at POS inside the top-level form B. +Its start is where the reader starts that form, which is all the daemon +matches on: a match arm's value or block, not its pattern, which is no +form; an elif's condition and an else's, on's or restart's block, which are +forms, where the clause line itself is not." + (let* ((l (flan-fln--line-statement pos)) + (arm (and l (flan-fln--arm l))) + (g (flan-fln--group-bounds pos))) + (cond + ((and arm (< pos (plist-get arm :arrow))) (plist-get arm :value)) + ((and g (cdr g) (> (car g) (car b))) + (cons (flan-fln--group-form-start (car g)) (cdr g))) + (arm (plist-get arm :value)) + ((and l (flan-fln--clause-line-p l)) (flan-fln--clause-target l)) + (t (let ((s (flan-fln--statement-start-at pos))) + (and s (flan-fln--statement-bounds s))))))) + +(defun flan-fln--clause-target (l) + "What a clause line L stops at: an elif's condition, else its block." + (save-excursion + (goto-char (flan-fln--first-char l)) + (if (looking-at "elif[ \t]+") + (cons (match-end 0) (flan-fln--code-end (flan-fln--logical-end l))) + (flan-fln--body-bounds l)))) + +(defun flan-fln--condition (l) + "Bounds of the condition on the if, elif, while or until line L, or nil. +A loop's label, `while :outer c', is not part of it." + (save-excursion + (goto-char (flan-fln--first-char l)) + (when (looking-at "\\(?:if\\|elif\\|while\\|until\\)[ \t]+\\(?::[^ \t]+[ \t]+\\)?") + (let ((beg (match-end 0)) + (end (flan-fln--code-end (flan-fln--logical-end l)))) + (and (< beg end) (cons beg end)))))) + +(defun flan-fln--arm (l) + "The match arm whose joined line starts at L, or nil. +A plist: :arrow, where its ` -> ' starts; :value, the bounds of what follows +the arrow on the line, or of the block under it; :binds, non-nil when the +pattern names something, so the value cannot be evaluated alone." + (let ((parent (flan-fln--parent l))) + (when (and parent + (string-match-p "\\(?:\\`\\|[ \t]=[ \t]+\\)match\\(?:[ \t]\\|\\'\\)" + (buffer-substring-no-properties + (flan-fln--first-char parent) + (flan-fln--code-end parent)))) + (save-excursion + (let* ((start (flan-fln--first-char l)) + (last (flan-fln--code-end (flan-fln--logical-end l))) + (depth (car (syntax-ppss start))) + arrow) + (goto-char start) + (while (and (not arrow) + (re-search-forward "[ \t]\\(->\\)\\(?:[ \t]\\|$\\)" last t)) + (let ((ps (save-excursion (syntax-ppss (match-beginning 1))))) + (when (and (= (car ps) depth) (not (nth 8 ps))) + (setq arrow (match-beginning 1))))) + (when arrow + (let* ((pat (string-trim (buffer-substring-no-properties start arrow))) + (vbeg (save-excursion (goto-char (+ arrow 2)) + (skip-chars-forward " \t") (point))) + (value (if (< vbeg last) (cons vbeg last) + (flan-fln--body-bounds l)))) + (and value + (list :arrow arrow :value value + :binds (or (string-match-p "[([{]" pat) + (and (string-match-p "\\`[a-z][^ \t]*\\'" pat) + (not (member pat flan--constants))))))))))))) + +(defun flan-fln--arm-to-send (l arm) + "What evaluating the match arm at L sends: its value, or, when its pattern +binds a name the value uses, the whole match." + (if (plist-get arm :binds) + (flan-fln--statement-bounds + (flan-fln--statement-start-at (flan-fln--parent l))) + (plist-get arm :value))) ;;;###autoload (defun flan-fln-eval-defun (&optional arg) @@ -609,13 +686,34 @@ before point. With ARG, stop there instead, as \\[flan-eval-last-sexp] does." (interactive "P") (flan-fln--client) (let* ((end (flan-fln--point-for-last)) - (st (and (>= end (flan-fln--code-end end)) - (flan-fln--statement-ending-at end)))) - (if st - (flan-fln--send (car st) (cdr st) arg flan--declaration-heads) + (at-end (and (>= end (flan-fln--code-end end)) + (not (flan-fln--blank-p end)))) + (l (and at-end (flan-fln--line-statement end))) + ;; Point ends the line L starts, joined lines included. + (l-end (and l (= (flan-fln--bol end) (flan-fln--logical-end l)))) + (arm (and l-end (flan-fln--arm l))) + (st (and at-end (not arm) (flan-fln--statement-ending-at end))) + (opens (and l-end (not st) (not arm) + (or (flan-fln--clause-line-p l) + (/= (flan-fln--statement-last l) + (flan-fln--logical-end l)))))) + (cond + (arm (let ((b (flan-fln--arm-to-send l arm))) + (flan-fln--send (car b) (cdr b) arg flan--declaration-heads))) + (st (flan-fln--send (car st) (cdr st) arg flan--declaration-heads)) + ;; The end of a line that opens a block: its last word is not what was + ;; meant. A condition is a value of its own; anything else is sent + ;; with its block, a clause with the statement it belongs to. + ((and opens (flan-fln--condition l)) + (let ((c (flan-fln--condition l))) + (flan--eval-expression (car c) (cdr c) arg))) + (opens + (let ((b (flan-fln--statement-bounds (flan-fln--clause-header l)))) + (flan-fln--send (car b) (cdr b) arg flan--declaration-heads))) + (t (let ((tb (flan-fln--term-before end))) (unless tb (user-error "flan: no form before point to evaluate")) - (flan--eval-expression (car tb) (cdr tb) arg))))) + (flan--eval-expression (car tb) (cdr tb) arg)))))) (defun flan-fln--snap-lines (beg end) "BEG..END widened to whole lines, less leading blank lines and trailing space." @@ -650,10 +748,13 @@ before point. With ARG, stop there instead, as \\[flan-eval-last-sexp] does." (defun flan-fln--statement-to-send (pos) "The statement at POS as sent by `C-c C-e': with its body and clauses, and for a bare `let x = v', with the rest of its block, which is its scope." - (let ((s (flan-fln--statement-start-at pos))) - (and s (if (flan-fln--bare-let-p s) - (flan-fln--block-rest s) - (flan-fln--statement-bounds s))))) + (let* ((l (flan-fln--line-statement pos)) + (arm (and l (flan-fln--arm l))) + (s (flan-fln--statement-start-at pos))) + (cond (arm (flan-fln--arm-to-send l arm)) + ((null s) nil) + ((flan-fln--bare-let-p s) (flan-fln--block-rest s)) + (t (flan-fln--statement-bounds s))))) ;;;###autoload (defun flan-fln-eval-statement (&optional arg) @@ -936,7 +1037,10 @@ opening line's column." (t (flan-fln--levels (point)))))))))) (defun flan-fln-indent-line () - "Indent the line to a block column: the deepest first, then out one per TAB." + "Indent the line to a block column. +A line with text at a valid column stays there: its column is its meaning, +and a TAB pressed to see where it goes must not change it. An empty line +goes to the deepest column. Each repeated TAB then steps out one." (let* ((cands (flan-fln--indent-candidates (point))) (cur (current-indentation)) (target @@ -945,6 +1049,10 @@ opening line's column." (eq last-command 'indent-for-tab-command) (memq cur cands)) (or (cadr (memq cur cands)) (car cands))) + ((and (memq cur cands) + (not (save-excursion (beginning-of-line) + (looking-at-p "[ \t]*$")))) + cur) (t (car cands))))) (if (null target) 'noindent @@ -1231,7 +1339,7 @@ it, so a block pasted at another depth stays one block." (,(concat "\\_<" (regexp-opt flan--constants t) "\\_>") 1 font-lock-constant-face) ;; A keyword. `x:' is a name with a colon glued on, not one. - ("\\_<:[^][ \t\n(){},;\":]+" . font-lock-constant-face) + ("\\(?:^\\|[][ \t(){},]\\)\\(:[^][ \t\n(){},;\":]+\\)" 1 font-lock-constant-face) ;; A type: after the `: ' of an annotation and after `-> '. ("[^ \t\n:]:[ \t]+\\([$a-zA-Z][^][ \t\n(){},;\"=]*\\)" 1 font-lock-type-face) ("[ \t]->[ \t]+\\([$a-zA-Z][^][ \t\n(){},;\"=]*\\)" 1 font-lock-type-face) @@ -1242,7 +1350,7 @@ it, so a block pasted at another depth stays one block." ("\\_<\\$[^][ \t\n(){},;\":]*" . font-lock-type-face) ;; A character literal, `\c' or `\space'. ("\\\\\\(?:space\\|newline\\|tab\\|return\\|[^ \t\n]\\)" . font-lock-string-face) - ("\\_<-?[0-9][0-9a-fA-FxX_.]*\\_>" . font-lock-number-face)) + ("\\_<-?[0-9][0-9a-fA-FxX_.]*\\_>" . 'font-lock-number-face)) "Font lock for `flan-fln-mode'.") (defvar flan-fln-imenu-generic-expression @@ -1350,18 +1458,21 @@ that says so and otherwise is its own." ;;; Evil (defun flan-fln--evil (b type) - (if b (evil-range (car b) (cdr b) type) (error "No object here"))) + ;; A line range is handed over already whole -- from a line's start to the + ;; start of the line after it -- and marked expanded, so Evil neither + ;; stretches it to one more line nor leaves the last newline behind. + (cond ((null b) (error "No object here")) + ((eq type 'line) (evil-range (car b) (cdr b) 'line :expanded t)) + (t (evil-range (car b) (cdr b) type)))) (defun flan-fln--whole-lines (b) - (and b (cons (flan-fln--bol (car b)) (flan-fln--code-end (cdr b))))) + "B's lines, from the start of the first to the start of the line after." + (and b (flan-fln--lines (flan-fln--bol (car b)) (flan-fln--bol (cdr b))))) (defun flan-fln--with-trailing-blanks (b) - "B's lines and the blank lines after them." - (and b (let ((n (flan-fln--next-code (cdr b)))) - (cons (car b) (if n - (save-excursion (goto-char n) (forward-line -1) - (line-end-position)) - (point-max)))))) + "B's whole lines and the blank lines after them." + (and b (let ((n (flan-fln--next-code (1- (cdr b))))) + (cons (car b) (or n (point-max)))))) (defun flan-fln--term-around (b) "B and the spaces after it, or before it when none follow." diff --git a/emacs/test-flan-fln-live.el b/emacs/test-flan-fln-live.el index baa55f00..e1ce594e 100644 --- a/emacs/test-flan-fln-live.el +++ b/emacs/test-flan-fln-live.el @@ -30,6 +30,26 @@ fn total(n: i32) -> i32 t = t + i t +fn sign(n: i64) -> i64 + if n < 0 + -1 + elif n == 0 + 0 + else + 1 + +enum Dir + north + south + east + +fn pick(d: Dir) -> i64 + match d + :north -> 10 + :south -> 20 + _ -> + twice(3) + comment(): twice(4) if 2 > 1 @@ -134,7 +154,20 @@ comment(): ;; answers `:pause' only when a form the reader made starts exactly ;; there (`Ast.mark_pause'). Each kind of target once, and one position ;; a column off to show the answer can be no. + ;; C-x C-e on an arm's value, and on a condition line. + (funcall goto ":south -> 20" t) + (flan-fln-eval-last) + (test-flan--check (funcall name "C-x C-e at the end of a match arm evaluates its value") + (funcall shows "20")) + (funcall goto "if 2 > 1" t) + (flan-fln-eval-last) + (test-flan--check (funcall name "C-x C-e at the end of an if line evaluates the condition") + (funcall shows "true")) (dolist (c '(("n - 1)" "a call, from its name") + ("elif n" "an elif, at its condition") + ("else\n 1" "an else, at its block") + (":south -> 20" "a match arm, at its value") + ("_ ->" "a match arm, at its block") ("n < 2" "an if statement") ("t = 0" "a let") ("i in range" "a for") diff --git a/emacs/test-flan-fln.el b/emacs/test-flan-fln.el index bd3ef497..dbc8fc67 100644 --- a/emacs/test-flan-fln.el +++ b/emacs/test-flan-fln.el @@ -408,6 +408,118 @@ fn twice(n: i64) -> i64 = n * 2 (test-flan-fln--is "a free parenthesis marks the value inside it" (plist-get r :pause) '(2 6)))) +;;; Match arms, header lines, clauses, comments + +(defconst test-flan-fln--arms + "fn pick(n: i64) -> i64 + let r = match n + 0 -> 10 + 1 -> + twice(1) + twice(2) + k -> k + 1 + if n < 0 + -1 + elif n == 0 + or n == 1 + 0 + else + r + handler-case + f() + on Error(e) + nil + ; a comment, twice(9) + r + +comment: + twice(4) +") + +(defun test-flan-fln--last-at (needle &optional fn) + "What FN, C-x C-e by default, sends with point at the end of NEEDLE's line." + (test-flan-fln--in (test-flan-fln--at test-flan-fln--arms needle) + (end-of-line) + (let ((r (test-flan-fln--sending (funcall (or fn #'flan-fln-eval-last))))) + (and r (list (plist-get r :op) (test-flan-fln--sent-code r)))))) + +(test-flan-fln--is "C-x C-e at the end of a match arm sends its value" + (test-flan-fln--last-at "0 -> 10") '("eval-expr" "10")) +(test-flan-fln--is "at the end of an arm with a block, the block" + (test-flan-fln--last-at "1 ->") + '("eval-expr" "twice(1)\n twice(2)")) +(test-flan-fln--is "an arm whose pattern binds a name sends the whole match" + (cadr (test-flan-fln--last-at "k -> k")) + (substring test-flan-fln--arms (string-search "let r" test-flan-fln--arms) + (+ (string-search "k + 1" test-flan-fln--arms) 5))) +(test-flan-fln--in (test-flan-fln--at test-flan-fln--arms "twice(2)") + (test-flan-fln--is "C-c C-e on an arm's block sends the block, not the arm" + (test-flan-fln--sent-code + (test-flan-fln--sending + (search-backward "1 ->") (flan-fln-eval-statement))) + "twice(1)\n twice(2)")) +(test-flan-fln--is "C-x C-e at the end of an if line sends its condition" + (test-flan-fln--last-at "if n < 0") '("eval-expr" "n < 0")) +(test-flan-fln--is "and of an elif, all of its condition" + (test-flan-fln--last-at "or n == 1") + '("eval-expr" "n == 0\n or n == 1")) +(test-flan-fln--is "at the end of an else line, the whole if" + (cadr (test-flan-fln--last-at "else\n r")) + "if n < 0\n -1\n elif n == 0\n or n == 1\n 0\n else\n r") +(test-flan-fln--is "at the end of an on line, the whole handler-case" + (cadr (test-flan-fln--last-at "on Error")) + "handler-case\n f()\n on Error(e)\n nil") +(test-flan-fln--is "at the end of a fn header, the fn, installed" + (car (test-flan-fln--last-at "fn pick")) "eval") +(test-flan-fln--is "at the end of comment:, the whole block" + (test-flan-fln--last-at "comment:") + '("eval-expr" "comment:\n twice(4)")) +(test-flan-fln--in (test-flan-fln--at test-flan-fln--arms "; a comment") + (end-of-line) + (let ((r (test-flan-fln--sending + (condition-case nil (flan-fln-eval-last) (user-error nil))))) + (test-flan--check "C-x C-e on a comment line sends nothing from the comment" + (null r)))) + +(defun test-flan-fln--pause-at (needle) + (test-flan-fln--in (test-flan-fln--at test-flan-fln--arms needle) + (plist-get (test-flan-fln--sending (flan-fln-eval-defun '(4))) :pause))) + +(test-flan-fln--is "C-u C-c C-c on an arm's pattern stops at its value" + (test-flan-fln--pause-at "0 -> 10") '(3 10)) +(test-flan-fln--is "on an arm with a block, at the block" + (test-flan-fln--pause-at "1 ->") '(5 7)) +(test-flan-fln--is "on an elif line, at its condition" + (test-flan-fln--pause-at "elif") '(10 8)) +(test-flan-fln--is "and from its condition's continuation line too" + (test-flan-fln--pause-at "or n == 1") '(10 8)) +(test-flan-fln--is "on an else line, at its block" + (test-flan-fln--pause-at "else\n r") '(14 5)) +(test-flan-fln--is "on an on line, at its block" + (test-flan-fln--pause-at "on Error") '(18 5)) + +;;; Names and colours + +(test-flan-fln--in "fn f(x: i64) -> i64\n comment:\n g(:key-r, x)\n 0x1F + 12\n" + (search-forward "x:") + (backward-char 1) + (test-flan-fln--is "a colon glued to a name is not part of it" + (thing-at-point 'symbol t) "x") + (search-forward "comment") + (test-flan-fln--is "nor to a name that takes a block" + (thing-at-point 'symbol t) "comment") + (test-flan--check "font-lock draws the buffer without an error" + (condition-case nil (progn (font-lock-ensure) t) (error nil))) + (let ((face (lambda (needle) + (save-excursion (goto-char (point-min)) (search-forward needle) + (get-text-property (match-beginning 0) 'face))))) + (test-flan-fln--is "a number is drawn as one" (funcall face "12") 'font-lock-number-face) + (test-flan-fln--is "a keyword as a constant" (funcall face ":key-r") 'font-lock-constant-face) + (test-flan-fln--is "a header word as a keyword" (funcall face "fn") 'font-lock-keyword-face) + (test-flan-fln--is "a type after its colon" (funcall face "i64") 'font-lock-type-face) + (test-flan--check "and the name before the colon is not a keyword" + (null (funcall face "x:"))))) + ;;; Indentation (defun test-flan-fln--tabs (text n) @@ -434,6 +546,12 @@ fn twice(n: i64) -> i64 = n * 2 (test-flan-fln--tabs test-flan-fln--nest 4) (test-flan-fln--tabs test-flan-fln--nest 5)) '(4 2 0 6)) +(test-flan-fln--is "a line of code already at a valid column stays there" + (test-flan-fln--tabs "fn f() -> ()\n if a\n b\n| let b = 2" 1) 2) +(test-flan-fln--is "and a second TAB steps it out" + (test-flan-fln--tabs "fn f() -> ()\n if a\n b\n| let b = 2" 2) 0) +(test-flan-fln--is "a line of code at no valid column goes to the deepest" + (test-flan-fln--tabs "fn f() -> ()\n if a\n b\n| let b = 2" 1) 4) (test-flan-fln--is "after a header, one level deeper first" (test-flan-fln--tabs "fn f() -> ()\n while a\n|" 1) 4) (test-flan-fln--is "after a trailing colon too" @@ -629,6 +747,30 @@ fn twice(n: i64) -> i64 = n * 2 (string-search "fn step" test-flan-fln--settle))))) (test-flan-fln--is (format "under Evil, %s" (car c)) (funcall yanked (nth 1 c) (car c)) (nth 2 c))) + (let ((deleted + (lambda (keys needle) + (let ((b (generate-new-buffer "delete.fln"))) + (switch-to-buffer b) + (insert "fn f(x: i64) -> i64\n if x > 0\n a\n else\n 3\n x\n\nfn g() -> i32 = 1\n") + (flan-fln-mode) + (evil-initialize-state) + (evil-normal-state) + (goto-char (point-min)) + (search-forward needle) + (goto-char (match-beginning 0)) + (execute-kbd-macro keys) + (prog1 (buffer-string) + (set-buffer-modified-p nil) + (kill-buffer b)))))) + (dolist (c '(("dak" "else" + "fn f(x: i64) -> i64\n if x > 0\n a\n x\n\nfn g() -> i32 = 1\n") + ("das" "else" + "fn f(x: i64) -> i64\n x\n\nfn g() -> i32 = 1\n") + ("dii" "if x" + "fn f(x: i64) -> i64\n if x > 0\n else\n 3\n x\n\nfn g() -> i32 = 1\n") + ("dad" "else" "fn g() -> i32 = 1\n"))) + (test-flan-fln--is (format "under Evil, %s leaves no blank line" (car c)) + (funcall deleted (car c) (nth 1 c)) (nth 2 c)))) (let ((b (generate-new-buffer "keys.fln"))) (switch-to-buffer b) (insert "fn f() -> i32 = 1\n") From c3ba4c9e08608da485c37f609484b09f23be2bfd Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:29:06 +0700 Subject: [PATCH 12/20] A wrapped condition or arm value is sent whole and reads as it does in the file, an arm whose value uses nothing its pattern binds sends that value, a match arm is a clause object, and dad on the last form takes the blank lines before it --- emacs/flan-fln-mode.el | 108 +++++++++++++++++++++++++++++++----- emacs/test-flan-fln-live.el | 13 +++++ emacs/test-flan-fln.el | 60 +++++++++++++++++++- 3 files changed, 165 insertions(+), 16 deletions(-) diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el index 56a43d0b..881a8265 100644 --- a/emacs/flan-fln-mode.el +++ b/emacs/flan-fln-mode.el @@ -42,6 +42,9 @@ (declare-function flan--eval "flan" (code what &optional start end pause)) (declare-function flan--eval-expression "flan" (start end arg)) (declare-function flan--text "flan" (start end)) +(declare-function flan--text-at "flan" (start end)) +(declare-function flan--report "flan" (reply what &optional at)) +(declare-function flan--request "flan" (form)) (defvar flan--declaration-heads) (defvar flan--defun-heads) ;; Set buffer-locally when the packages are there; declared so the setq-local @@ -331,7 +334,8 @@ A clause line owns its own block, so it can be the answer." (flan-fln--span first (flan-fln--statement-last start t))))) (defun flan-fln--clause-at (pos) - "The clause line whose clause holds POS, the innermost one, or nil." + "The clause line whose clause holds POS, the innermost one, or nil. +A match arm is a clause too: its pattern line and its value or block." (let* ((line (flan-fln--line-statement pos)) (p line) (limit (and line (1+ (flan-fln--indent-at line)))) @@ -339,7 +343,7 @@ A clause line owns its own block, so it can be the answer." (while (and p (not hit)) (let ((i (flan-fln--indent-at p))) (when (< i limit) - (if (flan-fln--clause-line-p p) + (if (or (flan-fln--clause-line-p p) (flan-fln--arm p)) (setq hit p) (setq limit i))) (setq p (and (> limit 0) @@ -544,6 +548,36 @@ or the fallback call's name, `defmethod(', must read as one of HEADS, (defun flan-fln--client () (require 'flan)) +(defun flan-fln--cut-text (beg end) + "The text BEG..END, as the reader must see it when BEG is mid-line. +A condition or an arm's value starts after `elif ' or `-> ', and a line that +continues it is indented past the statement's start in the file but perhaps +not past the value's own column, which the reader, seeded at that column, +requires. So every line after the first moves right by the width of what +was cut off in front of the first; errors on the first line keep their +exact column." + (let* ((text (buffer-substring-no-properties beg end)) + (delta (save-excursion + (goto-char beg) + (- (current-column) (current-indentation))))) + (if (<= delta 0) + text + (replace-regexp-in-string "\n" (concat "\n" (make-string delta ?\s)) + text t t)))) + +(defun flan-fln--eval-expression (beg end arg) + "Evaluate BEG..END as an expression, as `flan--eval-expression' does, with +the text shaped by `flan-fln--cut-text'." + (flan--report + (flan--request + (let ((at (flan--text-at beg end))) + (append (list :op "eval-expr" :code (flan-fln--cut-text beg end) + :file (or buffer-file-name "")) + (cdr at) + (when arg (list :pause t))))) + "expression" + end)) + (defun flan-fln--send (beg end arg heads) "Send BEG..END: installed when it is a declaration at column 0, else run. HEADS says which heads count as declarations. ARG is a prefix: on a @@ -552,7 +586,7 @@ the stop-here flag." (let ((head (flan-fln--declaration-head-at beg heads))) (if head (flan--eval (flan--text beg end) head beg end (and arg (cons beg end))) - (prog1 (flan--eval-expression beg end arg) + (prog1 (flan-fln--eval-expression beg end arg) (pulse-momentary-highlight-region beg end))))) (defun flan-fln--pause-bounds (b arg) @@ -631,9 +665,36 @@ pattern names something, so the value cannot be evaluated alone." (flan-fln--body-bounds l)))) (and value (list :arrow arrow :value value - :binds (or (string-match-p "[([{]" pat) - (and (string-match-p "\\`[a-z][^ \t]*\\'" pat) - (not (member pat flan--constants))))))))))))) + :binds (flan-fln--uses-any-p + (flan-fln--pattern-names pat) + (buffer-substring-no-properties + (car value) (cdr value)))))))))))) + +(defconst flan-fln--name-char "[:alnum:]_?!*/$<>=%+-" + "The characters a name is made of, for a character class.") + +(defun flan-fln--pattern-names (pat) + "The names pattern PAT binds: its lowercase words that are not constants, +fields, keywords, constructors or `_'." + (let ((re (concat "\\(?:\\`\\|[^" flan-fln--name-char ".:]\\)" + "\\([a-z][" flan-fln--name-char "]*\\)")) + (start 0) names) + (while (string-match re pat start) + (let ((n (match-string 1 pat))) + (setq start (match-end 1)) + (unless (or (member n flan--constants) + (and (< start (length pat)) (memq (aref pat start) '(?\( ?.)))) + (push n names)))) + names)) + +(defun flan-fln--uses-any-p (names text) + "Non-nil if TEXT has any of NAMES as a whole name." + (seq-some (lambda (n) + (string-match-p (concat "\\(?:\\`\\|[^" flan-fln--name-char ".]\\)" + (regexp-quote n) + "\\(?:\\'\\|[^" flan-fln--name-char "]\\)") + text)) + names)) (defun flan-fln--arm-to-send (l arm) "What evaluating the match arm at L sends: its value, or, when its pattern @@ -686,6 +747,16 @@ before point. With ARG, stop there instead, as \\[flan-eval-last-sexp] does." (interactive "P") (flan-fln--client) (let* ((end (flan-fln--point-for-last)) + ;; A line the next one continues -- an operator at either side of + ;; the break, or a bracket left open -- ends where the whole joined + ;; line does, not at its last word. + (end (if (and (>= end (flan-fln--code-end end)) + (not (flan-fln--blank-p end)) + (let ((n (flan-fln--next-code end))) + (and n (flan-fln--continuation-p n)))) + (flan-fln--code-end + (flan-fln--logical-end (flan-fln--logical-start end))) + end)) (at-end (and (>= end (flan-fln--code-end end)) (not (flan-fln--blank-p end)))) (l (and at-end (flan-fln--line-statement end))) @@ -706,7 +777,7 @@ before point. With ARG, stop there instead, as \\[flan-eval-last-sexp] does." ;; with its block, a clause with the statement it belongs to. ((and opens (flan-fln--condition l)) (let ((c (flan-fln--condition l))) - (flan--eval-expression (car c) (cdr c) arg))) + (flan-fln--eval-expression (car c) (cdr c) arg))) (opens (let ((b (flan-fln--statement-bounds (flan-fln--clause-header l)))) (flan-fln--send (car b) (cdr b) arg flan--declaration-heads))) @@ -1470,9 +1541,16 @@ that says so and otherwise is its own." (and b (flan-fln--lines (flan-fln--bol (car b)) (flan-fln--bol (cdr b))))) (defun flan-fln--with-trailing-blanks (b) - "B's whole lines and the blank lines after them." + "B's whole lines and the blank lines after them. +With none after -- the last form -- the blank lines before it instead, as +Vim's `dap' does, so the buffer does not end in empty lines." (and b (let ((n (flan-fln--next-code (1- (cdr b))))) - (cons (car b) (or n (point-max)))))) + (if n + (cons (car b) n) + (let ((p (flan-fln--prev-code (car b)))) + (cons (if p (save-excursion (goto-char p) (line-beginning-position 2)) + (car b)) + (point-max))))))) (defun flan-fln--term-around (b) "B and the spaces after it, or before it when none follow." @@ -1516,10 +1594,14 @@ that says so and otherwise is its own." (bounds-of-thing-at-point 'flan-fln-statement)) 'line)) (evil-define-text-object flan-fln-inner-clause (count &optional _beg _end _type) - "A clause's block, its lines." - (flan-fln--evil (let ((c (flan-fln--clause-at (point)))) - (flan-fln--whole-lines (and c (flan-fln--body-bounds c)))) - 'line)) + "A clause's block, its lines; a match arm's value when it is on the line." + (let* ((c (flan-fln--clause-at (point))) + (arm (and c (flan-fln--arm c))) + (v (and arm (plist-get arm :value)))) + (if (and v (= (flan-fln--bol (car v)) c)) + (flan-fln--evil v 'exclusive) + (flan-fln--evil (flan-fln--whole-lines (and c (flan-fln--body-bounds c))) + 'line)))) (evil-define-text-object flan-fln-a-clause (count &optional _beg _end _type) "A clause: its line and its block." (flan-fln--evil (flan-fln--whole-lines diff --git a/emacs/test-flan-fln-live.el b/emacs/test-flan-fln-live.el index e1ce594e..33e3cbae 100644 --- a/emacs/test-flan-fln-live.el +++ b/emacs/test-flan-fln-live.el @@ -47,10 +47,15 @@ fn pick(d: Dir) -> i64 match d :north -> 10 :south -> 20 + :east -> 1 + + 2 _ -> twice(3) comment(): + if 1 < 2 and + 3 < 4 + twice(1) twice(4) if 2 > 1 twice(2) @@ -159,6 +164,14 @@ comment(): (flan-fln-eval-last) (test-flan--check (funcall name "C-x C-e at the end of a match arm evaluates its value") (funcall shows "20")) + (funcall goto ":east -> 1 +" t) + (flan-fln-eval-last) + (test-flan--check (funcall name "C-x C-e on an arm's wrapped value evaluates all of it") + (funcall shows "3")) + (funcall goto "if 1 < 2 and" t) + (flan-fln-eval-last) + (test-flan--check (funcall name "C-x C-e on a wrapped condition evaluates all of it") + (funcall shows "true")) (funcall goto "if 2 > 1" t) (flan-fln-eval-last) (test-flan--check (funcall name "C-x C-e at the end of an if line evaluates the condition") diff --git a/emacs/test-flan-fln.el b/emacs/test-flan-fln.el index dbc8fc67..d1b0ff17 100644 --- a/emacs/test-flan-fln.el +++ b/emacs/test-flan-fln.el @@ -460,9 +460,58 @@ comment: "twice(1)\n twice(2)")) (test-flan-fln--is "C-x C-e at the end of an if line sends its condition" (test-flan-fln--last-at "if n < 0") '("eval-expr" "n < 0")) -(test-flan-fln--is "and of an elif, all of its condition" +(test-flan-fln--is "and of an elif, all of its condition, the wrapped line moved right by what was cut off" (test-flan-fln--last-at "or n == 1") - '("eval-expr" "n == 0\n or n == 1")) + '("eval-expr" "n == 0\n or n == 1")) +(test-flan-fln--is "and the same from the end of the condition's first line" + (test-flan-fln--last-at "elif n == 0") + '("eval-expr" "n == 0\n or n == 1")) + +(defconst test-flan-fln--wrapped + "fn f(o: Option(i64)) -> i64 + match o + Some(_) -> 5 + Some(n) -> n + 1 + Some(m) -> 7 + None -> 1 + + 2 + if 1 < 2 and + 3 < 4 + x = 1 + + 2 +") + +(defun test-flan-fln--wrapped-at (needle fn) + (test-flan-fln--in (test-flan-fln--at test-flan-fln--wrapped needle) + (end-of-line) + (let ((r (test-flan-fln--sending (funcall fn)))) + (and r (test-flan-fln--sent-code r))))) + +(test-flan-fln--is "an arm's value wrapped onto a second line goes whole, moved right" + (test-flan-fln--wrapped-at "None" #'flan-fln-eval-last) + "1 +\n 2") +(test-flan-fln--is "from its second line too" + (test-flan-fln--wrapped-at " 2\n if" #'flan-fln-eval-last) + "1 +\n 2") +(test-flan-fln--is "and C-c C-e on it sends the same" + (test-flan-fln--wrapped-at "None" #'flan-fln-eval-statement) + "1 +\n 2") +(test-flan-fln--is "a wrapped if condition, from the end of its first line" + (test-flan-fln--wrapped-at "if 1 < 2" #'flan-fln-eval-last) + "1 < 2 and\n 3 < 4") +(test-flan-fln--is "a statement wrapped by an operator, from the end of its first line" + (test-flan-fln--wrapped-at "x = 1 +" #'flan-fln-eval-last) + "x = 1 +\n 2") +(test-flan-fln--is "an arm whose pattern binds nothing sends its value" + (test-flan-fln--wrapped-at "Some(_)" #'flan-fln-eval-last) "5") +(test-flan-fln--is "nor one whose value does not use what it binds" + (test-flan-fln--wrapped-at "Some(m)" #'flan-fln-eval-last) "7") +(test-flan--check "one whose value uses its binding sends the match" + (string-prefix-p "match o" + (test-flan-fln--wrapped-at "Some(n)" #'flan-fln-eval-last))) +(test-flan-fln--in (test-flan-fln--at test-flan-fln--wrapped "5") + (test-flan-fln--is "a match arm is a clause" + (test-flan-fln--thing 'flan-fln-clause) "Some(_) -> 5")) (test-flan-fln--is "at the end of an else line, the whole if" (cadr (test-flan-fln--last-at "else\n r")) "if n < 0\n -1\n elif n == 0\n or n == 1\n 0\n else\n r") @@ -742,6 +791,10 @@ comment: " if f32(rand()) < 0.5 then 1 else -1\n") ("yak" ,(test-flan-fln--at test-flan-fln--settle "if f32(rand())") " else\n if f32(rand()) < 0.5 then 1 else -1\n") + ("yik" ,(test-flan-fln--at test-flan-fln--wrapped "Some(_)") + "5") + ("yak" ,(test-flan-fln--at test-flan-fln--wrapped "Some(_)") + " Some(_) -> 5\n") ("yid" ,(test-flan-fln--at test-flan-fln--settle "paint-at") ,(substring test-flan-fln--settle (string-search "fn step" test-flan-fln--settle))))) @@ -768,7 +821,8 @@ comment: "fn f(x: i64) -> i64\n x\n\nfn g() -> i32 = 1\n") ("dii" "if x" "fn f(x: i64) -> i64\n if x > 0\n else\n 3\n x\n\nfn g() -> i32 = 1\n") - ("dad" "else" "fn g() -> i32 = 1\n"))) + ("dad" "else" "fn g() -> i32 = 1\n") + ("dad" "fn g" "fn f(x: i64) -> i64\n if x > 0\n a\n else\n 3\n x\n"))) (test-flan-fln--is (format "under Evil, %s leaves no blank line" (car c)) (funcall deleted (car c) (nth 1 c)) (nth 2 c)))) (let ((b (generate-new-buffer "keys.fln"))) From e7d82cb64031c49c9f6b5d0aef904649a7b2283b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:30:31 +0700 Subject: [PATCH 13/20] A match arm can match a number or string literal, queued --- TODO.org | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/TODO.org b/TODO.org index 87fae9fa..262eec92 100644 --- a/TODO.org +++ b/TODO.org @@ -296,6 +296,10 @@ keyword resolves against the expected type and against nothing else, so two enum could always share a member spelling. What the prefix buys is the call site read on its own. +** NEXT match over numbers and strings +Decided 2026-09-25: a match arm's pattern can be an integer, a float, a char or a +string literal, compared as =(= t lit)=; a match over such a type needs a =_= arm. + ** DONE match over enums CLOSED: [2026-09-25] =Ast.Pkw= is the keyword pattern; =Check.check_match= resolves it against the From 25911d7c9d70703ed9633cdb1fb1da0dcec0fab2 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:31:57 +0700 Subject: [PATCH 14/20] Nested ML-style patterns are wanted --- TODO.org | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/TODO.org b/TODO.org index 262eec92..cee24e7a 100644 --- a/TODO.org +++ b/TODO.org @@ -296,6 +296,10 @@ keyword resolves against the expected type and against nothing else, so two enum could always share a member spelling. What the prefix buys is the call site read on its own. +** TODO ML-style patterns +Wanted: nested destructuring (data cases, structs, arrays, slices), guards, or-patterns, +literals at any depth, and exhaustiveness checked over the nesting. Needs a design pass. + ** NEXT match over numbers and strings Decided 2026-09-25: a match arm's pattern can be an integer, a float, a char or a string literal, compared as =(= t lit)=; a match over such a type needs a =_= arm. From db7f703c0e4fdeeb6f1e16f11cd838eca276ea65 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:33:26 +0700 Subject: [PATCH 15/20] ML-style patterns are held as a future direction --- TODO.org | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/TODO.org b/TODO.org index cee24e7a..45c6a7bc 100644 --- a/TODO.org +++ b/TODO.org @@ -296,9 +296,9 @@ keyword resolves against the expected type and against nothing else, so two enum could always share a member spelling. What the prefix buys is the call site read on its own. -** TODO ML-style patterns -Wanted: nested destructuring (data cases, structs, arrays, slices), guards, or-patterns, -literals at any depth, and exhaustiveness checked over the nesting. Needs a design pass. +** WAIT ML-style patterns +Held 2026-09-25 as a future direction, like the JS backend: nested destructuring, +guards, or-patterns, literals at any depth, exhaustiveness over the nesting. ** NEXT match over numbers and strings Decided 2026-09-25: a match arm's pattern can be an integer, a float, a char or a From f1bdcc8840e2f1724413f5b75ee8a3e3a69264f5 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:35:33 +0700 Subject: [PATCH 16/20] Editor code cut out mid-line carries :indent, the column its statement starts at, so the reader accepts its wrapped lines as the file does and reports every location where it is in the buffer --- emacs/flan-fln-mode.el | 37 ++++++++++++++++++------------------- emacs/test-flan-fln-live.el | 33 +++++++++++++++++++++++++++++++++ emacs/test-flan-fln.el | 24 +++++++++++++++++------- lib/dev.ml | 3 ++- lib/indent_reader.ml | 23 +++++++++++++++++------ lib/source.ml | 14 ++++++++++---- test/test_syntax.ml | 16 ++++++++++++++++ 7 files changed, 113 insertions(+), 37 deletions(-) diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el index 881a8265..af056b46 100644 --- a/emacs/flan-fln-mode.el +++ b/emacs/flan-fln-mode.el @@ -548,32 +548,31 @@ or the fallback call's name, `defmethod(', must read as one of HEADS, (defun flan-fln--client () (require 'flan)) -(defun flan-fln--cut-text (beg end) - "The text BEG..END, as the reader must see it when BEG is mid-line. +(defun flan-fln--cut-indent (beg) + "The byte column of the statement BEG was cut out of, when BEG is mid-line. A condition or an arm's value starts after `elif ' or `-> ', and a line that -continues it is indented past the statement's start in the file but perhaps -not past the value's own column, which the reader, seeded at that column, -requires. So every line after the first moves right by the width of what -was cut off in front of the first; errors on the first line keep their -exact column." - (let* ((text (buffer-substring-no-properties beg end)) - (delta (save-excursion - (goto-char beg) - (- (current-column) (current-indentation))))) - (if (<= delta 0) - text - (replace-regexp-in-string "\n" (concat "\n" (make-string delta ?\s)) - text t t)))) +continues it is indented past the statement's start, perhaps not past the +cut. The reader is told where the statement starts (`:indent'), so it +reads the text as the file has it, and every location it reports is still +the buffer's own." + (save-excursion + (goto-char beg) + (when (> (current-column) (current-indentation)) + (back-to-indentation) + (1+ (- (position-bytes (point)) + (position-bytes (line-beginning-position))))))) (defun flan-fln--eval-expression (beg end arg) - "Evaluate BEG..END as an expression, as `flan--eval-expression' does, with -the text shaped by `flan-fln--cut-text'." + "Evaluate BEG..END as an expression, as `flan--eval-expression' does, and +with `:indent' when BEG is mid-line." (flan--report (flan--request - (let ((at (flan--text-at beg end))) - (append (list :op "eval-expr" :code (flan-fln--cut-text beg end) + (let ((at (flan--text-at beg end)) + (indent (flan-fln--cut-indent beg))) + (append (list :op "eval-expr" :code (car at) :file (or buffer-file-name "")) (cdr at) + (when indent (list :indent indent)) (when arg (list :pause t))))) "expression" end)) diff --git a/emacs/test-flan-fln-live.el b/emacs/test-flan-fln-live.el index 33e3cbae..078ded7c 100644 --- a/emacs/test-flan-fln-live.el +++ b/emacs/test-flan-fln-live.el @@ -56,6 +56,9 @@ comment(): if 1 < 2 and 3 < 4 twice(1) + elif 1 > 2 or + 3 > 4 + 0 twice(4) if 2 > 1 twice(2) @@ -172,6 +175,36 @@ comment(): (flan-fln-eval-last) (test-flan--check (funcall name "C-x C-e on a wrapped condition evaluates all of it") (funcall shows "true")) + ;; An error on the wrapped line of a condition or value cut out + ;; mid-line is reported where it is in the buffer, column and all. + (let ((refused + (lambda (needle bad fix) + (funcall goto needle t) + (let ((line (1+ (line-number-at-pos))) col) + (save-excursion + (forward-line 1) + (search-forward fix (line-end-position)) + (replace-match bad t t) + (setq col (1+ (- (point) (line-beginning-position) + (length (car (last (split-string bad " ")))))))) + (prog1 (list (condition-case err (progn (flan-fln-eval-last) nil) + (user-error (error-message-string err))) + (format ":%d:%d)" line col)) + (save-excursion + (goto-char (point-min)) + (search-forward bad) + (replace-match fix t t))))))) + (pcase-dolist (`(,what ,needle ,bad ,fix) + '(("an if condition" "if 1 < 2 and" "3 < 4 4" "3 < 4") + ("an elif condition" "elif 1 > 2 or" "3 > 4 4" "3 > 4") + ("an arm's value" ":east -> 1 +" "2 2" "2"))) + (let ((r (funcall refused needle bad fix))) + (test-flan--check + (funcall name (format "an error on the wrapped line of %s is reported at its column" what)) + (and (car r) (string-suffix-p (cadr r) (car r)))) + (unless (and (car r) (string-suffix-p (cadr r) (car r))) + (message " want ...%s\n got %S" (cadr r) (car r)))))) + (flan-clear-errors) (funcall goto "if 2 > 1" t) (flan-fln-eval-last) (test-flan--check (funcall name "C-x C-e at the end of an if line evaluates the condition") diff --git a/emacs/test-flan-fln.el b/emacs/test-flan-fln.el index d1b0ff17..c92e05c2 100644 --- a/emacs/test-flan-fln.el +++ b/emacs/test-flan-fln.el @@ -460,12 +460,12 @@ comment: "twice(1)\n twice(2)")) (test-flan-fln--is "C-x C-e at the end of an if line sends its condition" (test-flan-fln--last-at "if n < 0") '("eval-expr" "n < 0")) -(test-flan-fln--is "and of an elif, all of its condition, the wrapped line moved right by what was cut off" +(test-flan-fln--is "and of an elif, all of its condition" (test-flan-fln--last-at "or n == 1") - '("eval-expr" "n == 0\n or n == 1")) + '("eval-expr" "n == 0\n or n == 1")) (test-flan-fln--is "and the same from the end of the condition's first line" (test-flan-fln--last-at "elif n == 0") - '("eval-expr" "n == 0\n or n == 1")) + '("eval-expr" "n == 0\n or n == 1")) (defconst test-flan-fln--wrapped "fn f(o: Option(i64)) -> i64 @@ -489,19 +489,29 @@ comment: (test-flan-fln--is "an arm's value wrapped onto a second line goes whole, moved right" (test-flan-fln--wrapped-at "None" #'flan-fln-eval-last) - "1 +\n 2") + "1 +\n 2") (test-flan-fln--is "from its second line too" (test-flan-fln--wrapped-at " 2\n if" #'flan-fln-eval-last) - "1 +\n 2") + "1 +\n 2") (test-flan-fln--is "and C-c C-e on it sends the same" (test-flan-fln--wrapped-at "None" #'flan-fln-eval-statement) - "1 +\n 2") + "1 +\n 2") (test-flan-fln--is "a wrapped if condition, from the end of its first line" (test-flan-fln--wrapped-at "if 1 < 2" #'flan-fln-eval-last) - "1 < 2 and\n 3 < 4") + "1 < 2 and\n 3 < 4") (test-flan-fln--is "a statement wrapped by an operator, from the end of its first line" (test-flan-fln--wrapped-at "x = 1 +" #'flan-fln-eval-last) "x = 1 +\n 2") +(test-flan-fln--in (test-flan-fln--at test-flan-fln--wrapped "None") + (end-of-line) + (let ((r (test-flan-fln--sending (flan-fln-eval-last)))) + (test-flan-fln--is "a value cut mid-line says where its statement starts" + (list (plist-get r :line) (plist-get r :col) (plist-get r :indent)) + '(6 13 5)))) +(test-flan-fln--in (test-flan-fln--at test-flan-fln--wrapped "x = 1") + (end-of-line) + (let ((r (test-flan-fln--sending (flan-fln-eval-last)))) + (test-flan--check "a whole statement does not" (null (plist-member r :indent))))) (test-flan-fln--is "an arm whose pattern binds nothing sends its value" (test-flan-fln--wrapped-at "Some(_)" #'flan-fln-eval-last) "5") (test-flan-fln--is "nor one whose value does not use what it binds" diff --git a/lib/dev.ml b/lib/dev.ml index 0f4e7e86..f51ad7ac 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -4371,7 +4371,8 @@ let rec handle t req = | Some l, None -> Some (l, 1) | _ -> None in - Source.with_code ~syntax ~at (fun () -> handle_op t req) + let indent = Wire.int_field req "indent" in + Source.with_code ?indent ~syntax ~at (fun () -> handle_op t req) and handle_op t req = match Wire.string_field req "op" with diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index a5ea3a81..436bba59 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -220,7 +220,7 @@ let point (l : Loc.t) = { l with Loc.line = l.Loc.eline; col = l.Loc.ecol } (* NEWLINE, INDENT and DEDENT, at bracket depth zero only: inside ( [ { a line break is whitespace. A line continues the one before it when either side of the break is a spaced binary operator (spec §2 "Continuation"). *) -let layout ?(snippet = false) ?(base = 1) (toks : token list) : token array = +let layout ?(snippet = false) ?(base = 1) ?indent (toks : token list) : token array = let arr = Array.of_list toks in let n = Array.length arr in (* A snippet from the editor starts wherever it was written, and its first @@ -229,6 +229,11 @@ let layout ?(snippet = false) ?(base = 1) (toks : token list) : token array = let out = ref [] in let add tok loc = out := { tok; loc; sp = true } :: !out in let stack = ref [ base ] in + (* [indent] is the column of the statement a snippet was cut out of, when + the snippet starts after that statement's first word (an elif's + condition, an arm's value). Its first joined line continues as it does + in the file: deeper than the statement, not than the cut. *) + let first_line = ref true in let depth = ref 0 in let binop t = match t.tok with NAME s -> is_binop s | _ -> false in for i = 0 to n - 1 do @@ -248,11 +253,16 @@ let layout ?(snippet = false) ?(base = 1) (toks : token list) : token array = && arr.(i + 1).sp in let continues = (binop p && p.sp) || (binop t && spaced_after) in + let top = + match indent with + | Some c when !first_line && List.length !stack = 1 -> min c (List.hd !stack) + | _ -> List.hd !stack + in (* A continuation line sits deeper than the statement it continues. One at or left of that statement's column is not read as joining it: that would pull a line into a block it was written outside of, silently. *) - if continues && t.loc.Loc.col <= List.hd !stack then + if continues && t.loc.Loc.col <= top then failk "continuation" t.loc "%s" (if binop t then @@ -261,15 +271,16 @@ let layout ?(snippet = false) ?(base = 1) (toks : token list) : token array = line above, but it is not indented past the start of that \ line (column %d). Indent it further to continue the line, \ or give %s a value on its left" - (show t.tok) (List.hd !stack) (show t.tok) + (show t.tok) top (show t.tok) else Printf.sprintf "the line above ends with the operator %s, so this line \ continues it, but it is not indented past the start of \ that line (column %d). Indent it further, or finish the \ line above" - (show p.tok) (List.hd !stack)); + (show p.tok) top); if not continues then begin + first_line := false; let at = point p.loc in add NEWLINE at; let col = t.loc.Loc.col in @@ -1556,7 +1567,7 @@ and lines (s : st) (one : unit -> Form.t list) : Form.t list = (** All top-level forms in a [.fln] source string. [col] is the column the text's top level starts at, 1 for a file. *) -let read_all ?(line = 1) ?col ~file src = +let read_all ?(line = 1) ?col ?indent ~file src = let snippet = col <> None in let col = Option.value col ~default:1 in let saved = !source in @@ -1566,7 +1577,7 @@ let read_all ?(line = 1) ?col ~file src = (file, Array.of_list (String.split_on_char '\n' (String.make (line - 1) '\n' ^ String.make (col - 1) ' ' ^ src))); Fun.protect ~finally:(fun () -> source := saved) (fun () -> - let toks = layout ~snippet ~base:col (lex ~line ~col ~file src) in + let toks = layout ~snippet ~base:col ?indent (lex ~line ~col ~file src) in let s = { p = { toks; i = 0 }; lets = [] } in let fs = stmts s in (match (peek s.p).tok with diff --git a/lib/source.ml b/lib/source.ml index 102da4fd..d6429e19 100644 --- a/lib/source.ml +++ b/lib/source.ml @@ -33,15 +33,21 @@ type syntax = Paren | Indented let code_syntax = ref Paren let code_at : (int * int) option ref = ref None +(* The column of the statement editor code was cut out of, when the code + starts after that statement's first word: see [Indent_reader.layout]. *) +let code_indent : int option ref = ref None + let syntax_of_field = function | Some ("indented" | "fln") -> Indented | _ -> Paren -let with_code ~syntax ~at f = - let s = !code_syntax and a = !code_at in +let with_code ?indent ~syntax ~at f = + let s = !code_syntax and a = !code_at and i = !code_indent in code_syntax := syntax; code_at := at; - Fun.protect ~finally:(fun () -> code_syntax := s; code_at := a) f + code_indent := indent; + Fun.protect + ~finally:(fun () -> code_syntax := s; code_at := a; code_indent := i) f (* The paren reader started at a line and column: [Reader.read_all] always starts at 1:1. *) @@ -65,7 +71,7 @@ let read_code ?(expr = false) ~file code = match !code_syntax with | Paren -> read_paren ~line ~col ~file code | Indented -> - (match Indent_reader.read_all ~line ~col ~file code with + (match Indent_reader.read_all ~line ~col ?indent:!code_indent ~file code with | (first :: _ :: _ as forms) when expr -> let last = List.nth forms (List.length forms - 1) in let loc = diff --git a/test/test_syntax.ml b/test/test_syntax.ml index d8dc6426..e9c7fe03 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -488,6 +488,22 @@ let () = | [ _; _ ] -> () | _ -> fail "a snippet with leading spaces" | exception e -> fail "a snippet with leading spaces: %s" (diag_text e)); + (* A condition cut out from after [elif ] at column 3: its wrapped line at + column 8 is deeper than the elif, which is what the file says, though not + deeper than the cut. [:indent] says where the statement starts; every + location stays the buffer's own. *) + Source.with_code ~indent:3 ~syntax:Source.Indented ~at:(Some (10, 8)) (fun () -> + (match Source.read_code ~expr:true ~file:"" "x == 0 or\n x == 1" with + | [ f ] -> span_is "a wrapped condition, cut mid-line" f (10, 8, 11, 14) + | _ -> fail "a wrapped condition read as more than one form" + | exception e -> fail "a wrapped condition: %s" (diag_text e)); + match Source.read_code ~expr:true ~file:"" "x == 0 or\n x == 1" with + | _ -> fail "a continuation left of its statement was read" + | exception Loc.Error _ -> ()); + Source.with_code ~syntax:Source.Indented ~at:(Some (10, 8)) (fun () -> + match Source.read_code ~expr:true ~file:"" "x == 0 or\n x == 1" with + | _ -> fail "without :indent, a wrapped line is measured from the cut" + | exception Loc.Error _ -> ()); Source.with_code ~syntax:Source.Paren ~at:(Some (7, 3)) (fun () -> match Source.read_code ~file:"" "(f 1)" with | [ f ] -> span_is "a paren snippet" f (7, 3, 7, 8) From 111ee66a4b1c5891818d01b6c2c49b03d29b99dd Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:47:53 +0700 Subject: [PATCH 17/20] A match arm can be a number, char or string literal compared with =, over a number, a string or a dyn, with a _ arm required --- TODO.org | 7 +- lib/ast.ml | 4 + lib/check.ml | 156 +++++++++++++++++++++++++++++-- lib/load.ml | 2 +- lib/parse.ml | 1 + spec-syntax.md | 10 +- test/programs/match-literal.flan | 71 ++++++++++++++ test/test_acceptance.ml | 13 +++ test/test_flan.ml | 66 ++++++++++++- test/test_syntax.ml | 2 + web/index.html | 7 +- 11 files changed, 320 insertions(+), 19 deletions(-) create mode 100644 test/programs/match-literal.flan diff --git a/TODO.org b/TODO.org index 262eec92..68db3b8d 100644 --- a/TODO.org +++ b/TODO.org @@ -296,9 +296,10 @@ keyword resolves against the expected type and against nothing else, so two enum could always share a member spelling. What the prefix buys is the call site read on its own. -** NEXT match over numbers and strings -Decided 2026-09-25: a match arm's pattern can be an integer, a float, a char or a -string literal, compared as =(= t lit)=; a match over such a type needs a =_= arm. +** DONE match over numbers and strings +CLOSED: [2026-09-25] +Rules out a literal the scrutinee's type cannot hold (refused, not widened as =(=)= +would), keyword arms over a dyn, and a bare-name catch-all: a bare name is a nullary case. ** DONE match over enums CLOSED: [2026-09-25] diff --git a/lib/ast.ml b/lib/ast.ml index 824d743d..7ab6b16e 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -222,6 +222,10 @@ and arm = { pat : pattern; body : expr list; aloc : Loc.t } and pattern = | Pctor of string * string list (* (Some e) (Rect w h) None *) | Pkw of string (* :north — an enum member *) + (* 5 -2.5 \a "go" — an Int, UInt, Float, Byte or Str expr, compared as + (= t lit). An expr and not a literal type of its own, so the checker + types it against the scrutinee as any literal is typed against its site. *) + | Plit of expr | Pwild (* _ :else *) (* ── Declarations ──────────────────────────────────────────────────── *) diff --git a/lib/check.ml b/lib/check.ml index 3aa48fab..bd8ab9e8 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -3801,6 +3801,11 @@ let box_option ctx loc (t : Types.t) (got : Tast.expr) : Tast.expr = (Tast.Let ([ (s, got) ], [ mk loc Types.Dyn (Tast.If (is_some, some_dyn, none_dyn)) ])) +(* [=] over a dyn pair, answering a bool. Shared by the [=] builtin and a + literal [match] over a dyn, which is (= t lit) by definition. *) +let dyn_eq loc u v = + unbox loc Types.Bool (rt loc Types.Dyn "flan_dyn_eq" [ box loc u; box loc v ]) + let unbox_option ctx loc (t : Types.t) (got : Tast.expr) : Tast.expr = let oty = Types.Option t in match t with @@ -8089,10 +8094,44 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = "%s is a union, and nothing in one records which member was written, \ so there is nothing to match on. Read the member you mean with \ (.member u), or use a defdata" n + (* A number, a string or a dyn: the arms are literals, and each is the + test (= t lit) over one temporary — the enum's chain, with [=]'s own + two lowerings for the test, so a match over a dyn means what [=] over + it means. [is_equatable]'s set minus the enums, which are above. *) + | (Types.Int _ | Types.Float _ | Types.String | Types.Dyn) as t -> `Lit t | other -> - fail loc "match works on an Option, a data type or an enum, not on %s" + fail loc + "match works on an Option, a data type, an enum, a number, a string \ + or a dyn, not on %s" (Types.to_string other) in + (* A literal arm, spelled as it was written, for the refusals that name one. *) + let spell (e : Ast.expr) = + match e.Ast.e with + | Ast.Int n -> Int64.to_string n + | Ast.UInt (_, t) -> t + | Ast.Float x when Float.is_integer x -> Printf.sprintf "%.1f" x + | Ast.Float x -> Printf.sprintf "%g" x + | Ast.Byte b when b > 32 && b < 127 -> Printf.sprintf "\\%c" (Char.chr b) + | Ast.Byte b -> string_of_int b + | Ast.Str t -> Printf.sprintf "%S" t + | _ -> "this literal" + in + let what_ty t = match t with Types.Dyn -> "a dyn" | t -> Types.to_string t in + (* A literal match that compiles, over the scrutinee's own name where it + has one, for the refusals that need to show the shape. *) + let lit_arms_fix t = + let name = + match scrutinee.Ast.e with Ast.Var n -> n | _ -> "t" + in + Printf.sprintf "(match %s %s)" name + (match t with + | Types.String -> "\"yes\" 1 _ 0" + | Types.Float _ -> "0.5 1 _ 0" + | _ -> "5 1 _ 0") + in + (* The checked literal of each literal arm, by the key [resolve_pat] gave it. *) + let lits : (string, Tast.expr) Hashtbl.t = Hashtbl.create 8 in (* Which case each arm names, and the type of each name it binds. This is the whole of what differs between the two subjects; everything below it is shared. *) @@ -8124,6 +8163,81 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = "this match is over the enum %s, and %s is not one of its members. An \ arm names a member as a keyword: %s" n c (String.concat " " (List.map (fun (m, _) -> ":" ^ m) members)) + | `Lit t, Ast.Plit e -> + let v = + match t with + (* [=]'s dyn pair checks its literal at dyn, which boxes it. *) + | Types.Dyn -> check ctx ~want:Types.Dyn e + | t -> + (match trial ctx (fun () -> check ctx ~want:t e) with + | Ok v -> v + | Error _ -> + (* A literal that does not fit is refused, where [=] would widen + the pair and let the arm quietly never match. The literal's + own refusal is not repeated: its fixes are casts, and a cast + is not a pattern. *) + let tn = Types.to_string t in + let an = + match tn.[0] with + | 'a' | 'e' | 'f' | 'i' | 'o' -> "an " ^ tn + | _ -> "a " ^ tn + in + let why = + match e.Ast.e, t with + | Ast.Str _, _ -> "is a string" + | _, Types.String -> "is a number" + | Ast.Float x, Types.Int _ when not (Float.is_integer x) -> + "is not a whole number" + | Ast.Float _, Types.Int _ -> "is a float" + | _ -> "does not fit in one" + in + fail a.Ast.aloc + "this match is over %s, so each arm has to be %s, and %s %s. \ + Change the arm to a value %s holds, or remove it" + tn an (spell e) why an) + in + (* One key per value [=] cannot tell apart, so a second arm that could + never be reached is refused: 97 and \\a are one u8, and over a dyn + 1 and 1.0 are equal, as they are over a float. *) + let key = + let num x = + if Float.is_integer x && Float.abs x < 0x1p62 then + Printf.sprintf "i%Ld" (Int64.of_float x) + else Printf.sprintf "f%h" x + in + match e.Ast.e with + | Ast.Int n -> Printf.sprintf "i%Ld" n + | Ast.Byte b -> Printf.sprintf "i%d" b + | Ast.UInt (n, _) -> Printf.sprintf "u%Lu" n + | Ast.Float x -> num x + | Ast.Str t -> "s" ^ t + | _ -> assert false + in + Hashtbl.replace lits key v; + Some key, [] + | `Lit t, Ast.Pkw k -> + fail a.Ast.aloc + ":%s is an enum member, and this match is over %s, whose arms are \ + literals, as in %s" k (what_ty t) (lit_arms_fix t) + | `Lit t, Ast.Pctor (c, _) -> + fail a.Ast.aloc + "%s names a case, and this match is over %s, whose arms are \ + literals, as in %s" c (what_ty t) (lit_arms_fix t) + | `Option _, Ast.Plit e -> + fail a.Ast.aloc + "%s is a literal, and this match is over an Option, whose arms are \ + (Some x) and None" (spell e) + | `Enum (n, members), Ast.Plit e -> + fail a.Ast.aloc + "%s is a literal, and this match is over the enum %s, whose arms \ + name its members as keywords: %s" (spell e) n + (String.concat " " (List.map (fun (m, _) -> ":" ^ m) members)) + | `Data u, Ast.Plit e -> + fail a.Ast.aloc + "%s is a literal, and this match is over the data type %s, whose \ + arms name its cases: %s" (spell e) u.Tast.dname + (String.concat ", " + (List.map (fun (v : Tast.variant) -> v.Tast.vname) u.Tast.cases)) | `Option _, Ast.Pkw k -> fail a.Ast.aloc ":%s is an enum member, and this match is over an Option, whose arms \ @@ -8184,7 +8298,10 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = | Some c -> if Hashtbl.mem seen c then fail a.Ast.aloc "this match has two %s arms" - (match subject with `Enum _ -> ":" ^ c | _ -> c); + (match subject, a.Ast.pat with + | `Enum _, _ -> ":" ^ c + | _, Ast.Plit e -> spell e + | _ -> c); Hashtbl.add seen c ()); (a, ctor, binds)) arms @@ -8286,7 +8403,19 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = List.filter_map (fun (m, _) -> if Hashtbl.mem seen m then None else Some (":" ^ m)) members + | `Lit _ -> [] in + (* No list of literals covers a number, a string or a dyn, so a literal + match always needs its [_]. Refused here, before the chain below, which + would otherwise run a lone last arm untested as the enum's does. *) + (match subject with + | `Lit t when not !saw_wild -> + Loc.failk "check/non-exhaustive-match" loc + "this match is not exhaustive — its arms are literals, and no list of \ + them covers every %s. Add a _ arm for the rest, as in %s" + (match t with Types.Dyn -> "dyn value" | t -> Types.to_string t) + (lit_arms_fix t) + | _ -> ()); if not !saw_wild && missing <> [] then (* The data type's declaration, because that is where the case list this match failed to cover actually lives, and because adding a case there is what @@ -8295,7 +8424,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = ~notes:(match subject with | `Data u -> declared_note ctx.env u.Tast.dname | `Enum (n, _) -> declared_note ctx.env n - | `Option _ -> []) + | `Option _ | `Lit _ -> []) "this match is not exhaustive — %s %s no arm. Add %s, or a _ arm for \ the rest" (String.concat ", " missing) @@ -8304,7 +8433,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = let ty = match !want with Some t -> t | None -> Types.Never in match subject with | `Option _ | `Data _ -> mk loc ty (Tast.Match (s, arms)) - | `Enum (_, members) -> + | `Enum _ | `Lit _ -> (* The scrutinee once, into a temporary, and then an [if] per arm in the order written. A [_] arm ends the chain, and so does the last arm of a match with none: it is exhaustive by the check above, so the last @@ -8320,10 +8449,18 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = | ({ Tast.acase = None; _ } as a) :: _ -> body a | [ a ] -> body a | ({ Tast.acase = Some m; _ } as a) :: rest -> - let v = mk loc s.Tast.ty (Tast.Int (List.assoc m members, Types.I32)) in - mk loc ty - (Tast.If (mk loc Types.Bool (Tast.Prim (Tast.Eq, [ local; v ])), - body a, chain rest)) + let test = + match subject with + | `Enum (_, members) -> + let v = + mk loc s.Tast.ty (Tast.Int (List.assoc m members, Types.I32)) + in + mk loc Types.Bool (Tast.Prim (Tast.Eq, [ local; v ])) + | `Lit Types.Dyn -> dyn_eq loc local (Hashtbl.find lits m) + | _ -> + mk loc Types.Bool (Tast.Prim (Tast.Eq, [ local; Hashtbl.find lits m ])) + in + mk loc ty (Tast.If (test, body a, chain rest)) in mk loc ty (Tast.Let ([ (slot, s) ], [ chain arms ])) @@ -9698,7 +9835,8 @@ and named_call ?(qualified = false) ctx ~want loc name args = and the negation is an [i1] flip the backend folds away. *) let link u v = let cmp = - unbox loc Types.Bool (rt loc Types.Dyn sym ([ u; v ] @ site)) + if String.equal sym "flan_dyn_eq" then dyn_eq loc u v + else unbox loc Types.Bool (rt loc Types.Dyn sym ([ u; v ] @ site)) in if String.equal name "!=" then mk loc Types.Bool (Tast.Prim (Tast.Not, [ cmp ])) diff --git a/lib/load.ml b/lib/load.ml index 9b5688b5..930fdda8 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -274,7 +274,7 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr = let bound = match a.Ast.pat with | Ast.Pctor (_, ns) -> ns @ bound - | Ast.Pkw _ | Ast.Pwild -> bound + | Ast.Pkw _ | Ast.Plit _ | Ast.Pwild -> bound in { a with Ast.body = List.map (rename_expr owned alias bound) a.Ast.body }) arms) diff --git a/lib/parse.ml b/lib/parse.ml index a9aa6e0c..b325e03a 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -1402,6 +1402,7 @@ and pattern (f : Form.t) : Ast.pattern = (* An enum member. Which enum is the scrutinee's type, so [Check] resolves it, as it resolves a keyword anywhere an enum is expected. *) | Kw member -> Ast.Pkw member + | Int _ | UInt _ | Float _ | Byte _ | Str _ -> Ast.Plit (expr f) | List ({ v = Sym ctor; _ } :: binds) -> List.iter no_pattern binds; Ast.Pctor (ctor, List.map dname binds) diff --git a/spec-syntax.md b/spec-syntax.md index c43bebb5..2d075b65 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -202,9 +202,17 @@ Each item: the proposal, then the reason in one line. Rect(w, h) -> w * h :north -> 0 _ -> 0 + + match code + 404 -> "missing" + -1 -> "none" + "ok" -> "fine" + \a -> "a" + _ -> "other" ``` An arm's body can be an indented block, which reads as `(do …)`. **Built** (a - one-line block reads as that line). + one-line block reads as that line). A number, char or string pattern is the + literal as written, compared as `(= t lit)`. - **Conditions**, clauses at the header's column: ``` diff --git a/test/programs/match-literal.flan b/test/programs/match-literal.flan new file mode 100644 index 00000000..9253b7aa --- /dev/null +++ b/test/programs/match-literal.flan @@ -0,0 +1,71 @@ +;;;; match over numbers, chars, strings and dyn values: each arm is (= t lit) +;;;; over one temporary, and a _ arm is the rest. + +(defn small [n i16] string + (match n + 5 "five" + -3 "minus three" + _ "other")) + +(defn half [x f32] i32 + (match x + 0.5 1 + 2 2 + _ 0)) + +(defn letter [c u8] i32 + (match c + \a 1 + 98 2 + _ 0)) + +(defn command [s string] i32 + (match s + "go" 1 + "stop" 2 + "" 3 + _ 0)) + +(defn big [n u64] i32 + (match n + 18446744073709551615 1 + _ 0)) + +;; Over a dyn the test is dyn =, so 1 matches 1.0 and "go" matches only a +;; string. +(defn kind [d dyn] string + (match d + 1 "one" + 2.5 "two and a half" + "go" "go" + _ "other")) + +(defn calls [] i32 + (print "(called) ") + 7) + +;; recur from inside an arm: the arm is the loop's tail. +(defn count-down [from i32] i32 + (loop [n from steps 0] + (match n + 0 steps + _ (recur (- n 1) (+ steps 1))))) + +(defn main [] i32 + (println (small 5)) + (println (small -3)) + (println (small 4)) + (print (half 0.5)) (print (half 2.0)) (print (half 3.0)) (println "") + (print (letter 97)) (print (letter 98)) (print (letter 99)) (println "") + (print (command "go")) (print (command "stop")) (print (command "")) + (print (command "gone")) (println "") + (print (big 18446744073709551615)) (print (big 1)) (println "") + (println (kind 1)) + (println (kind 1.0)) + (println (kind 2.5)) + (println (kind "go")) + (println (kind "1")) + ;; The scrutinee is evaluated once, however many arms test it. + (println (match (calls) 1 "a" 2 "b" 7 "seven" _ "c")) + (print (count-down 4)) (println "") + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 29f9a0b3..1c703e47 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -432,6 +432,19 @@ let () = match_enum_out; outputs ~dev:true "match over an enum, dev" "programs/match-enum.flan" match_enum_out; + (* A literal match is the same chain with (= t lit) as each test, so the + dyn rows (1 and 1.0 both "one") are dyn ='s answer. *) + let match_lit_out = + "five\nminus three\nother\n120\n120\n1230\n10\none\none\n\ + two and a half\ngo\nother\n(called) seven\n4\n" + in + outputs "match over literals" "programs/match-literal.flan" match_lit_out; + outputs ~opt:"-O0" "match over literals, -O0" "programs/match-literal.flan" + match_lit_out; + outputs ~x86:true "match over literals, --x86" "programs/match-literal.flan" + match_lit_out; + outputs ~dev:true "match over literals, dev" "programs/match-literal.flan" + match_lit_out; (* update, ++ and -- evaluate their place's subexpressions once: the counts are the number of calls an index or a key function got. *) let update_out = "3\n11 20 90\n1 1 3\n16\n2\n7 1\n32\n2 50\n" in diff --git a/test/test_flan.ml b/test/test_flan.ml index 1e151779..69dadbed 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -2690,7 +2690,7 @@ let () = accepts "a wildcard arm is exhaustive" "(defn g [] (Option i32) None) (defn f [] i32 (match (g) (Some v) v _ 0))"; rejects_check "match on a non-Option" - "(defn f [x i32] i32 (match x _ 0))" ~needle:"match works on an Option"; + "(defn f [x bool] i32 (match x _ 0))" ~needle:"match works on an Option"; (* ── Names, order-independence, entry point ────────────────────── *) accepts "mutually recursive, no forward declaration" @@ -4582,8 +4582,68 @@ let () = (k ^ "(defn f [k K] i32 (match k :lo 1 _ \"x\"))") ~needle:"expected i32, found string"; rejects_check "match over something that is none of them" - "(defn f [n i32] i32 (match n _ 2))" - ~needle:"match works on an Option, a data type or an enum, not on i32"; + "(defn f [n bool] i32 (match n _ 2))" + ~needle:"match works on an Option, a data type, an enum, a number, a \ + string or a dyn, not on bool"; + + (* ── match over literals ───────────────────────────────────────── *) + + (* Each arm is (= t lit) with the literal built at the scrutinee's type, so + a literal that type cannot hold is refused rather than widened into an + arm that never matches. *) + accepts "match over an i16, a literal arm built at i16" + "(defn f [n i16] i32 (match n 5 1 -3 2 _ 0))"; + accepts "match over a string" "(defn f [s string] i32 (match s \"go\" 1 _ 0))"; + accepts "match over a dyn, arms of several kinds" + "(defn f [d dyn] i32 (match d 1 1 2.5 2 \"go\" 3 \\a 4 _ 0))"; + accepts "match over a number, :else for the rest" + "(defn f [n i32] i32 (match n 5 1 :else 0))"; + rejects_check "a literal arm the scrutinee cannot hold" + "(defn f [n i8] i32 (match n 300 1 _ 0))" + ~needle:"this match is over i8, so each arm has to be an i8, and 300 does \ + not fit in one. Change the arm to a value an i8 holds, or remove it"; + rejects_check "a float arm over an integer" + "(defn f [n i32] i32 (match n 1.5 1 _ 0))" + ~needle:"and 1.5 is not a whole number"; + rejects_check "a string arm over a number" + "(defn f [n i32] i32 (match n \"a\" 1 _ 0))" + ~needle:"and \"a\" is a string"; + rejects_check "a number arm over a string" + "(defn f [s string] i32 (match s 5 1 _ 0))" + ~needle:"so each arm has to be a string, and 5 is a number"; + rejects_check "a literal match with no _ arm" + "(defn f [n i32] i32 (match n 5 1 6 2))" + ~needle:"this match is not exhaustive — its arms are literals, and no list \ + of them covers every i32. Add a _ arm for the rest, as in (match \ + n 5 1 _ 0)"; + rejects_check "a literal match over a dyn with no _ arm" + "(defn f [d dyn] i32 (match d 5 1))" + ~needle:"covers every dyn value"; + rejects_check "a literal named twice" + "(defn f [n i32] i32 (match n 5 1 5 2 _ 0))" + ~needle:"this match has two 5 arms"; + rejects_check "a char and a number that are one u8" + "(defn f [c u8] i32 (match c \\a 1 97 2 _ 0))" + ~needle:"this match has two 97 arms"; + rejects_check "1 and 1.0 are one arm over a dyn, as dyn = says" + "(defn f [d dyn] i32 (match d 1 1 1.0 2 _ 0))" + ~needle:"this match has two 1.0 arms"; + rejects_check "a keyword arm among literal arms" + "(defn f [n i32] i32 (match n 5 1 :lo 2 _ 0))" + ~needle:":lo is an enum member, and this match is over i32, whose arms are \ + literals, as in (match n 5 1 _ 0)"; + rejects_check "a case arm among literal arms" + "(defn f [n i32] i32 (match n 5 1 (Some x) 2 _ 0))" + ~needle:"Some names a case, and this match is over i32"; + rejects_check "a literal arm among keyword arms" + (k ^ "(defn f [k K] i32 (match k :lo 1 5 2 _ 0))") + ~needle:"5 is a literal, and this match is over the enum K"; + rejects_check "a literal arm over an Option" + "(defn f [o (Option i32)] i32 (match o 5 1 _ 0))" + ~needle:"5 is a literal, and this match is over an Option"; + rejects_check "a literal match over a byte slice, which = does not compare" + "(defn f [b [u8]] i32 (match b \"a\" 1 _ 0))" + ~needle:"not on [u8]"; (* A destructuring pattern in an arm's binds is a name position like any other. *) rejects_check "a pattern inside a match arm's binds" diff --git a/test/test_syntax.ml b/test/test_syntax.ml index ab4fb6a3..e1a17e11 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -362,6 +362,8 @@ let () = "(restart-case (f) (continue [] (do)))"; reads "match" "match s\n Circle(r) -> r\n _ ->\n a()\n b()" "(match s (Circle r) r _ (do (a) (b)))"; + reads "match over literals" "match n\n 5 -> a\n -2.5 -> b\n \"go\" -> c\n \\a -> d\n _ -> e" + "(match n 5 a -2.5 b \"go\" c \\a d _ e)"; reads "handler-bind moves the clauses" "handler-bind\n f()\non E(c)\n g(c)" "(handler-bind [(E [c] (g c))] (f))"; reads "quote block" diff --git a/web/index.html b/web/index.html index ea18a0de..a8a8a6e8 100644 --- a/web/index.html +++ b/web/index.html @@ -1096,8 +1096,11 @@ as first-even does above.

Option, match and some

(Option T) is how absence is spelled: a lookup miss, an empty -collection, the end of a stream. match works on an Option and -on a defdata, and on nothing else. some unwraps +collection, the end of a stream. match works on an Option, a +defdata and an enum, whose arms name cases; and on a number, a string or a +dyn, whose arms are literals — (match n 0 "zero" -1 "none" _ "some") +— each compared with =, with a _ arm required for the rest. +some unwraps Some and early-returns None from the enclosing function.

(defconst nums [4 i32] [4 8 15 16])

From 76b2ab31139fe07846d2f43bb2750c2a4b7471d3 Mon Sep 17 00:00:00 2001
From: Joseph Ferano 
Date: Fri, 25 Sep 2026 21:01:15 +0700
Subject: [PATCH 18/20] A duplicate literal arm is one whose value equals an
 earlier arm's at the scrutinee's type, and a literal no dyn holds is refused
 with a pattern fix

---
 lib/check.ml      | 127 ++++++++++++++++++++++++++++++----------------
 test/test_flan.ml |  21 +++++++-
 2 files changed, 103 insertions(+), 45 deletions(-)

diff --git a/lib/check.ml b/lib/check.ml
index bd8ab9e8..6b340ded 100644
--- a/lib/check.ml
+++ b/lib/check.ml
@@ -8110,8 +8110,15 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
     match e.Ast.e with
     | Ast.Int n -> Int64.to_string n
     | Ast.UInt (_, t) -> t
-    | Ast.Float x when Float.is_integer x -> Printf.sprintf "%.1f" x
-    | Ast.Float x -> Printf.sprintf "%g" x
+    | Ast.Float x when Float.is_integer x && Float.abs x < 1e15 ->
+      Printf.sprintf "%.1f" x
+    | Ast.Float x ->
+      (* The shortest spelling that reads back as the same float. *)
+      let rec go p =
+        let t = Printf.sprintf "%.*g" p x in
+        if p >= 17 || float_of_string t = x then t else go (p + 1)
+      in
+      go 1
     | Ast.Byte b when b > 32 && b < 127 -> Printf.sprintf "\\%c" (Char.chr b)
     | Ast.Byte b -> string_of_int b
     | Ast.Str t -> Printf.sprintf "%S" t
@@ -8132,6 +8139,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
   in
   (* The checked literal of each literal arm, by the key [resolve_pat] gave it. *)
   let lits : (string, Tast.expr) Hashtbl.t = Hashtbl.create 8 in
+  let lit_values = ref [] in
   (* Which case each arm names, and the type of each name it binds. This is the
      whole of what differs between the two subjects; everything below it is
      shared. *)
@@ -8165,54 +8173,87 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
         (String.concat " " (List.map (fun (m, _) -> ":" ^ m) members))
     | `Lit t, Ast.Plit e ->
       let v =
-        match t with
         (* [=]'s dyn pair checks its literal at dyn, which boxes it. *)
-        | Types.Dyn -> check ctx ~want:Types.Dyn e
-        | t ->
-          (match trial ctx (fun () -> check ctx ~want:t e) with
-           | Ok v -> v
-           | Error _ ->
-             (* A literal that does not fit is refused, where [=] would widen
-                the pair and let the arm quietly never match. The literal's
-                own refusal is not repeated: its fixes are casts, and a cast
-                is not a pattern. *)
-             let tn = Types.to_string t in
-             let an =
-               match tn.[0] with
-               | 'a' | 'e' | 'f' | 'i' | 'o' -> "an " ^ tn
-               | _ -> "a " ^ tn
-             in
-             let why =
-               match e.Ast.e, t with
-               | Ast.Str _, _ -> "is a string"
-               | _, Types.String -> "is a number"
-               | Ast.Float x, Types.Int _ when not (Float.is_integer x) ->
-                 "is not a whole number"
-               | Ast.Float _, Types.Int _ -> "is a float"
-               | _ -> "does not fit in one"
-             in
+        match trial ctx (fun () -> check ctx ~want:t e) with
+        | Ok v -> v
+        | Error _ ->
+          (* A literal that does not fit is refused, where [=] would widen
+             the pair and let the arm quietly never match. The literal's
+             own refusal is not repeated: its fixes are casts, and a cast
+             is not a pattern. *)
+          (match t with
+           | Types.Dyn ->
              fail a.Ast.aloc
-               "this match is over %s, so each arm has to be %s, and %s %s. \
-                Change the arm to a value %s holds, or remove it"
-               tn an (spell e) why an)
+               "this match is over a dyn, which holds a number as an i64 or \
+                an f64, and %s fits in neither. Change the arm to a value an \
+                i64 holds, or remove it" (spell e)
+           | _ -> ());
+          let tn = Types.to_string t in
+          let an =
+            match tn.[0] with
+            | 'a' | 'e' | 'f' | 'i' | 'o' -> "an " ^ tn
+            | _ -> "a " ^ tn
+          in
+          let why =
+            match e.Ast.e, t with
+            | Ast.Str _, _ -> "is a string"
+            | _, Types.String -> "is a number"
+            | Ast.Float x, Types.Int _ when not (Float.is_integer x) ->
+              "is not a whole number"
+            | Ast.Float _, Types.Int _ -> "is a float"
+            | _ -> "does not fit in one"
+          in
+          fail a.Ast.aloc
+            "this match is over %s, so each arm has to be %s, and %s %s. \
+             Change the arm to a value %s holds, or remove it"
+            tn an (spell e) why an
       in
-      (* One key per value [=] cannot tell apart, so a second arm that could
-         never be reached is refused: 97 and \\a are one u8, and over a dyn
-         1 and 1.0 are equal, as they are over a float. *)
-      let key =
+      (* The arm's value at the scrutinee's type, and a second arm [=] could
+         not tell from an earlier one is refused, since it can never be
+         reached: 97 and \a are one u8, 0.1 and 0.10000000001 are one f32,
+         and over a dyn 1 and 1.0 are equal. Compared pairwise rather than
+         hashed, because dyn = between an integer and a float goes through
+         the float and is not transitive past 2^53. *)
+      let value =
+        let f32 x = Int32.float_of_bits (Int32.bits_of_float x) in
         let num x =
-          if Float.is_integer x && Float.abs x < 0x1p62 then
-            Printf.sprintf "i%Ld" (Int64.of_float x)
-          else Printf.sprintf "f%h" x
+          match t with Types.Float Types.F32 -> `F (f32 x) | _ -> `F x
         in
-        match e.Ast.e with
-        | Ast.Int n -> Printf.sprintf "i%Ld" n
-        | Ast.Byte b -> Printf.sprintf "i%d" b
-        | Ast.UInt (n, _) -> Printf.sprintf "u%Lu" n
-        | Ast.Float x -> num x
-        | Ast.Str t -> "s" ^ t
+        match e.Ast.e, t with
+        | Ast.Str s, _ -> `S s
+        | (Ast.Int n | Ast.UInt (n, _)), Types.Float _ -> num (Int64.to_float n)
+        | Ast.Byte b, Types.Float _ -> num (float_of_int b)
+        | (Ast.Int n | Ast.UInt (n, _)), _ -> `I n
+        | Ast.Byte b, _ -> `I (Int64.of_int b)
+        | Ast.Float x, _ -> num x
         | _ -> assert false
       in
+      let same x y =
+        match x, y with
+        | `I a, `I b -> Int64.equal a b
+        | `F a, `F b -> a = b
+        | `I a, `F b | `F b, `I a -> Int64.to_float a = b
+        | `S a, `S b -> String.equal a b
+        | _ -> false
+      in
+      (match List.find_opt (fun (w, _) -> same value w) !lit_values with
+       | Some (_, earlier) when earlier = spell e ->
+         fail a.Ast.aloc "this match has two %s arms" earlier
+       | Some (_, earlier) ->
+         fail a.Ast.aloc
+           "this match has two %s arms — %s equals it as %s, so this arm is \
+            never reached. Remove it"
+           earlier (spell e)
+           (match t with
+            | Types.Dyn -> "a dyn"
+            | t ->
+              let tn = Types.to_string t in
+              (match tn.[0] with
+               | 'a' | 'e' | 'f' | 'i' | 'o' -> "an " ^ tn
+               | _ -> "a " ^ tn))
+       | None -> ());
+      lit_values := (value, spell e) :: !lit_values;
+      let key = string_of_int (Hashtbl.length lits) in
       Hashtbl.replace lits key v;
       Some key, []
     | `Lit t, Ast.Pkw k ->
diff --git a/test/test_flan.ml b/test/test_flan.ml
index 69dadbed..5a85d2b4 100644
--- a/test/test_flan.ml
+++ b/test/test_flan.ml
@@ -4624,10 +4624,27 @@ let () =
     ~needle:"this match has two 5 arms";
   rejects_check "a char and a number that are one u8"
     "(defn f [c u8] i32 (match c \\a 1 97 2 _ 0))"
-    ~needle:"this match has two 97 arms";
+    ~needle:"this match has two \\a arms — 97 equals it as a u8";
   rejects_check "1 and 1.0 are one arm over a dyn, as dyn = says"
     "(defn f [d dyn] i32 (match d 1 1 1.0 2 _ 0))"
-    ~needle:"this match has two 1.0 arms";
+    ~needle:"this match has two 1 arms — 1.0 equals it as a dyn";
+  rejects_check "two literals that round to one f32"
+    "(defn f [x f32] i32 (match x 0.1 1 0.10000000001 2 _ 0))"
+    ~needle:"this match has two 0.1 arms — 0.10000000001 equals it as an f32";
+  rejects_check "two integers that round to one f32"
+    "(defn f [x f32] i32 (match x 16777216 1 16777217 2 _ 0))"
+    ~needle:"two 16777216 arms — 16777217 equals it as an f32";
+  rejects_check "an integer and a float that are one f64"
+    "(defn f [x f64] i32 \
+     (match x 4611686018427387904 1 4611686018427387904.0 2 _ 0))"
+    ~needle:"equals it as an f64";
+  accepts "two f64 literals that differ"
+    "(defn f [x f64] i32 (match x 0.1 1 0.10000000001 2 _ 0))";
+  rejects_check "a literal no dyn holds"
+    "(defn f [x dyn] i32 (match x 18446744073709551615 1 _ 0))"
+    ~needle:"this match is over a dyn, which holds a number as an i64 or an \
+             f64, and 18446744073709551615 fits in neither. Change the arm to \
+             a value an i64 holds, or remove it";
   rejects_check "a keyword arm among literal arms"
     "(defn f [n i32] i32 (match n 5 1 :lo 2 _ 0))"
     ~needle:":lo is an enum member, and this match is over i32, whose arms are \

From 095701b29b9cbc287d10e34620b4d55eb58994fd Mon Sep 17 00:00:00 2001
From: Joseph Ferano 
Date: Fri, 25 Sep 2026 21:02:19 +0700
Subject: [PATCH 19/20] A negated name counts as the name an arm's pattern
 binds, and a comment belongs to the form or block whose column it sits at

---
 emacs/flan-fln-mode.el | 30 +++++++++++++++++++++++-------
 emacs/test-flan-fln.el | 30 ++++++++++++++++++++++++++++--
 2 files changed, 51 insertions(+), 9 deletions(-)

diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el
index 9c69e88c..e34cf308 100644
--- a/emacs/flan-fln-mode.el
+++ b/emacs/flan-fln-mode.el
@@ -680,6 +680,10 @@ a `(' -- a pattern's constructor, which binds nothing."
     (let (names)
       (while (re-search-forward "\\(?:\\sw\\|\\s_\\)+" nil t)
         (let ((n (match-string-no-properties 0)))
+          ;; A `-' glued to a letter, `$', `_' or `*' is negation, not part
+          ;; of the name (`is_neg_char' in lib/indent_reader.ml): `-n' is n.
+          (when (string-match "\\`-[a-zA-Z$_*]" n)
+            (setq n (substring n 1)))
           (unless (and skip-heads (eq (char-after) ?\())
             (push n names)
             (dolist (part (split-string n "\\." t))
@@ -1563,14 +1567,25 @@ that says so and otherwise is its own."
   (and (flan-fln--blank-p pos) (not (flan-fln--empty-line-p pos))))
 
 (defun flan-fln--with-comments (b)
-  "Whole lines B, and the comment lines directly above them: a comment block
-with no blank line under it belongs to what it sits on."
+  "Whole lines B, and the comments that belong to them.
+Above: a comment block at B's own column with no blank line under it.
+Below: comment lines deeper than B's column straight after it, which close
+its block.  A comment at another column belongs to the block it lines up
+with."
   (and b (save-excursion
-           (goto-char (car b))
-           (while (and (zerop (forward-line -1))
-                       (flan-fln--comment-line-p (point)))
-             (setq b (cons (point) (cdr b))))
-           b)))
+           (let ((col (flan-fln--indent-at (car b))))
+             (goto-char (car b))
+             (while (and (zerop (forward-line -1))
+                         (flan-fln--comment-line-p (point))
+                         (= (current-indentation) col))
+               (setq b (cons (point) (cdr b))))
+             (goto-char (cdr b))
+             (while (and (not (eobp))
+                         (flan-fln--comment-line-p (point))
+                         (> (current-indentation) col))
+               (forward-line 1)
+               (setq b (cons (car b) (point))))
+             b))))
 
 (defun flan-fln--commented-toplevel (pos)
   "The top-level form at POS, whole lines with its comment block.
@@ -1579,6 +1594,7 @@ On a comment block that sits directly on a form, that form."
                (goto-char pos)
                (beginning-of-line)
                (while (and (flan-fln--comment-line-p (point))
+                           (zerop (current-indentation))
                            (zerop (forward-line 1))))
                (if (flan-fln--toplevel-start-p (point)) (point) pos))))
     (flan-fln--with-comments
diff --git a/emacs/test-flan-fln.el b/emacs/test-flan-fln.el
index eb1c7b51..0dbb9014 100644
--- a/emacs/test-flan-fln.el
+++ b/emacs/test-flan-fln.el
@@ -533,7 +533,9 @@ comment:
 (dolist (c '(("Some(_v) -> _v + 1" "a name starting with _")
              ("Some(éé) -> éé" "a name that is not ASCII")
              ("Some(N) -> N" "a capitalised name")
-             ("Some(p) -> p.x" "a name used as a field's base")))
+             ("Some(p) -> p.x" "a name used as a field's base")
+             ("Some(n) -> -n" "a name its value negates")
+             ("Some(p) -> -p.x" "a name whose field its value negates")))
   (test-flan-fln--in (concat "fn f(o: Option(i64)) -> i64\n  match o\n    " (car c) "\n")
     (goto-char (point-max))
     (skip-chars-backward "\n")
@@ -888,7 +890,31 @@ comment:
                           "; loose\n\n; on f\nfn f() -> ()\n  a()\n; after f\n\n; on g\nfn g() -> ()\n")))
               (test-flan-fln--is (format "under Evil, %s on %s keeps comments with their forms"
                                          (car c) (nth 1 c))
-                                 (funcall deleted (car c) (nth 1 c)) (nth 2 c))))
+                                 (funcall deleted (car c) (nth 1 c)) (nth 2 c)))
+            ;; A comment deeper than a form, at the end of its block, is
+            ;; that block's, not the next form's.
+            (dolist (c '(("dad" "fn a" "fn a() -> i64\n  1\n  ; end of a\nfn b() -> i64\n  2\n"
+                          "fn b() -> i64\n  2\n")
+                         ("dad" "fn b" "fn a() -> i64\n  1\n  ; end of a\nfn b() -> i64\n  2\n"
+                          "fn a() -> i64\n  1\n  ; end of a\n")
+                         ("das" "let y"
+                          "fn a(x: i64) -> i64\n  if x > 0\n    1\n    ; end of the if\n  let y = 2\n  y\n"
+                          "fn a(x: i64) -> i64\n  if x > 0\n    1\n    ; end of the if\n  y\n")))
+              (let ((b (generate-new-buffer "owned.fln")))
+                (switch-to-buffer b)
+                (insert (nth 2 c))
+                (flan-fln-mode)
+                (evil-initialize-state)
+                (evil-normal-state)
+                (goto-char (point-min))
+                (search-forward (nth 1 c))
+                (goto-char (match-beginning 0))
+                (execute-kbd-macro (car c))
+                (test-flan-fln--is (format "under Evil, %s on %s: a deeper comment stays with the block above"
+                                           (car c) (nth 1 c))
+                                   (buffer-string) (nth 3 c))
+                (set-buffer-modified-p nil)
+                (kill-buffer b))))
           (let ((b (generate-new-buffer "keys.fln")))
             (switch-to-buffer b)
             (insert "fn f() -> i32 = 1\n")

From 5c044a7b406e6ba986da5bcd3df96ef84d28d991 Mon Sep 17 00:00:00 2001
From: Joseph Ferano 
Date: Fri, 25 Sep 2026 21:05:02 +0700
Subject: [PATCH 20/20] id and ad on a comment that belongs to no form find no
 object

---
 emacs/flan-fln-mode.el | 13 ++++++++++---
 emacs/test-flan-fln.el | 19 +++++++++++++++++++
 2 files changed, 29 insertions(+), 3 deletions(-)

diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el
index e34cf308..dfd90147 100644
--- a/emacs/flan-fln-mode.el
+++ b/emacs/flan-fln-mode.el
@@ -1596,9 +1596,16 @@ On a comment block that sits directly on a form, that form."
                (while (and (flan-fln--comment-line-p (point))
                            (zerop (current-indentation))
                            (zerop (forward-line 1))))
-               (if (flan-fln--toplevel-start-p (point)) (point) pos))))
-    (flan-fln--with-comments
-     (flan-fln--whole-lines (flan-fln--toplevel-bounds pos)))))
+               (if (flan-fln--toplevel-start-p (point)) (point) pos)))
+        (orig pos))
+    ;; A lone comment -- a blank line away from every form -- belongs to
+    ;; none, and the form above it is not what was pointed at.
+    (let ((b (flan-fln--with-comments
+              (flan-fln--whole-lines (flan-fln--toplevel-bounds pos)))))
+      (and b
+           (or (not (flan-fln--comment-line-p orig))
+               (and (<= (car b) orig) (< orig (cdr b))))
+           b))))
 
 (defun flan-fln--with-trailing-blanks (b)
   "Whole lines B and the empty lines after them.
diff --git a/emacs/test-flan-fln.el b/emacs/test-flan-fln.el
index 0dbb9014..cd114184 100644
--- a/emacs/test-flan-fln.el
+++ b/emacs/test-flan-fln.el
@@ -891,6 +891,25 @@ comment:
               (test-flan-fln--is (format "under Evil, %s on %s keeps comments with their forms"
                                          (car c) (nth 1 c))
                                  (funcall deleted (car c) (nth 1 c)) (nth 2 c)))
+            ;; A lone comment belongs to no form: id and ad find nothing.
+            (dolist (text '("fn a() -> i64\n  1\n\n; lone\n\nfn b() -> i64\n  2\n"
+                            "fn a() -> i64\n  1\n\n; lone\n"))
+              (dolist (keys '("did" "dad"))
+                (let ((b (generate-new-buffer "lone.fln")))
+                  (switch-to-buffer b)
+                  (insert text)
+                  (flan-fln-mode)
+                  (evil-initialize-state)
+                  (evil-normal-state)
+                  (goto-char (point-min))
+                  (search-forward "; lone")
+                  (goto-char (match-beginning 0))
+                  (ignore-errors (execute-kbd-macro keys))
+                  (test-flan-fln--is (format "under Evil, %s on a lone comment%s changes nothing"
+                                             keys (if (string-suffix-p "lone\n" text) " at the end" ""))
+                                     (buffer-string) text)
+                  (set-buffer-modified-p nil)
+                  (kill-buffer b))))
             ;; A comment deeper than a form, at the end of its block, is
             ;; that block's, not the next form's.
             (dolist (c '(("dad" "fn a" "fn a() -> i64\n  1\n  ; end of a\nfn b() -> i64\n  2\n"