diff --git a/test/dune b/test/dune index 446f9ba..89f7b30 100644 --- a/test/dune +++ b/test/dune @@ -31,6 +31,11 @@ ; examples/digits.flan, so the directory has to be here whole. (glob_files %{workspace_root}/examples/*) (glob_files programs/*.flan) + ; The synthetic C header the importer's table reads. Committed rather than + ; reached for on the machine: the raylib case needs raylib installed, at the + ; right version, with a variable set, so it skips everywhere and covers + ; nothing. This one does not move. + (glob_files headers/*.h) ; The files programs/embed.flan bakes in. An embed reads them at *compile* ; time, so they are a dependency of the checker run and not of the program. (glob_files programs/assets/*) diff --git a/test/programs/raylib-imported.flan b/test/programs/raylib-imported.flan new file mode 100644 index 0000000..0d8087c --- /dev/null +++ b/test/programs/raylib-imported.flan @@ -0,0 +1,36 @@ +;;;; Every binding called here came out of raylib's header, not out of +;;;; raylib.flan. The package binds none of these four by hand, so if this +;;;; program runs at all the importer produced working declarations — and +;;;; what it prints pins rather more than that. +;;;; +;;;; Needs FLAN_RAYLIB_H pointing at a raylib 5.5 header; the acceptance case +;;;; skips without it. + +(import rl "vendor:raylib") + +(defn main [] i32 + ;; A scalar in, a scalar out. Seeded, and a range of one, so the answer is + ;; the bound rather than anything random. + (rl/set-random-seed 12345) + (println (rl/get-random-value 10 10)) + + ;; A string parameter. A Flan string is ptr+len and never NUL-terminated, so + ;; this only answers 5 if the generated wrapper made the terminated copy. + (println (rl/text-length "hello")) + + ;; A struct by value in, a scalar out. 0x11223344 is 287454020, and it is + ;; the four fields read in r,g,b,a order — swap any two and the number + ;; changes, which a round trip could not have told us. + (println (rl/color-to-int (rl/Color {.r 17 .g 34 .b 51 .a 68}))) + + ;; A struct in and a struct out, which is the whole flattening path: the + ;; argument goes by pointer and the result comes back through an + ;; out-parameter. Tinting by white is the identity, so the four bytes come + ;; back separately and in order. + (let [t (rl/color-tint (rl/Color {.r 255 .g 255 .b 255 .a 255}) + (rl/Color {.r 17 .g 34 .b 51 .a 68}))] + (println (.r t)) + (println (.g t)) + (println (.b t)) + (println (.a t))) + 0) diff --git a/test/test_flan.ml b/test/test_flan.ml index 191f879..52c7ae1 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1091,6 +1091,231 @@ let () = "(defn f [] i32 (let [xs [1 2]] (destructure~nth xs 0 2 1)))" ~needle:"means nothing outside a quasiquote"; + (* ── Reading a C header (cimport.ml, cjson.ml) ─────────────────── *) + + (* Against test/headers/sample.h, which is one function per decision the + importer makes and is committed so that it cannot move. The raylib case + is better evidence and worse coverage: it needs raylib installed, at the + version whose .so is linked, with FLAN_RAYLIB_H set, so as the only test + of this it would skip everywhere. + + The assertions are on the *reasons*, not on the counts, for the reason the + acceptance table gives: a refusal that fires for the wrong cause still + refuses, and a count still matches. *) + let imported, dump, env, fixture_ds = + let fixture = + "(defstruct Pair [x f32 y f32])\n\ + (defstruct Shade [r u8 g u8 b u8 a u8])\n\ + (defenum Mood [calm 0 cross 1])\n" + in + let ds = program fixture in + let taken = Hashtbl.create 16 in + List.iter + (fun d -> + match Ast.declared_name d with + | Some n -> Hashtbl.replace taken n () + | None -> ()) + ds; + let known_structs = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defstruct (n, _) -> Some n | _ -> None) + ds + and known_enums = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defenum (n, _) -> Some n | _ -> None) + ds + in + let i, d, e = + Cimport.header ~loc:Loc.unknown ~header:"headers/sample.h" ~flags:[] + ~known_structs ~known_enums ~taken ~bound_syms:[] + in + (i, d, e, ds) + in + + (* What came out, as source, so a wrong type is visible as the line somebody + would otherwise have had to write by hand. *) + let produced = List.map Cimport.decl_source imported.Cimport.decls in + let emits name line = + check ("import-c emits " ^ name) (List.mem line produced) + in + emits "a scalar signature" "(declare-c set-seed [seed u32] \"set_seed\")"; + emits "two scalars and a return" + "(declare-c add-ints [a i32 b i32] i32 \"add_ints\")"; + (* An aggregate return is the flattening path: Shim turns it into an + out-pointer, and the declaration it starts from has to say the struct. *) + emits "an aggregate return" + "(declare-c make-pair [x f32 y f32] Pair \"make_pair\")"; + emits "an aggregate parameter" "(declare-c pair-len [p Pair] f32 \"pair_len\")"; + (* const char * is a string going in — the one C spelling that means + something different in a parameter than it does anywhere else. *) + emits "const char * as a string parameter" + "(declare-c name-length [text string] i32 \"name_length\")"; + emits "a pointer parameter" + "(declare-c count-at [values (Ptr i32) n i32] i32 \"count_at\")"; + (* struct Pair is both Pair and Point in the header and the package + describes it once, so both names have to land on the one defstruct — + raylib does exactly this with Texture2D and TextureCubemap. *) + emits "a second typedef name for a described record" + "(declare-c point-of [p Pair] Pair \"point_of\")"; + (* A C enum is an int, and so is a Flan defenum at the boundary; matching by + name is what keeps the nicer face. *) + emits "a C enum against a defenum of the same name" + "(declare-c mood-value [m Mood] i32 \"mood_value\")"; + emits "a function of no arguments" "(declare-c take-nothing [] \"take_nothing\")"; + + (* And the refusals, each by its reason rather than by a count. *) + let refused name needle = + check + ("import-c refuses " ^ name ^ ": " ^ needle) + (List.exists + (fun (n, why) -> n = name && contains why needle) + imported.Cimport.hidden) + in + refused "name-of" "returns char *"; + refused "fill-buffer" "C may write through"; + refused "printf-like" "is variadic"; + refused "on-event" "is a function pointer"; + refused "file-time" "width that differs"; + refused "make-undescribed" "the package does not describe"; + (* The order-dependent one. Spin2D and spin2d both kebab to spin-2d, so + neither may have it: whichever won would depend on the order the header + declares them in, and moving two lines in somebody else's header would + rebind a name a program is already calling. *) + refused "spin-2d" "would depend on the order"; + check "a colliding name is not imported after all" + (not (List.exists (fun l -> contains l "\"Spin2D\"") produced)); + check "nor is the other half of the collision" + (not (List.exists (fun l -> contains l "\"spin2d\"") produced)); + + (* A refused name is a name that exists and cannot be had — Zig's failDecl, + which Load.refuse_hidden already implements for main. Nothing may be in + both lists, or asking for a name that works would report that it does + not. *) + check "nothing is both imported and refused" + (not + (List.exists + (fun (d : Ast.decl) -> + match Ast.declared_name d with + | Some n -> List.mem_assoc n imported.Cimport.hidden + | None -> false) + imported.Cimport.decls)); + + (* The struct check, which is the point of reading a header the generator + does not otherwise need: the defstruct and the header's record have + different authors, so a disagreement is real information. A + _Static_assert was rejected in BUILT.md as circular for want of exactly + that. *) + let structs_of ds = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defstruct (n, fs) -> Some (n, fs) | _ -> None) + ds + in + check "a defstruct that matches the header is not reported" + (Cimport.check_structs ~env ~structs:(structs_of fixture_ds) dump = []); + (* Permuted: the failure BUILT.md says only a test can catch, because every + field still reads as a plausible number. *) + check "a permuted defstruct is reported" + (match + Cimport.check_structs ~env + ~structs:(structs_of (program "(defstruct Pair [y f32 x f32])\n")) dump + with + | [ ("Pair", why) ] -> contains why "field order" + | _ -> false); + (* Widened: the other half of the same hazard and the one BUILT.md names — + f64 where the library says float lays out eight bytes where there are + four, and every field after it moves. *) + check "a widened field is reported" + (match + Cimport.check_structs ~env + ~structs:(structs_of (program "(defstruct Pair [x f32 y f64])\n")) dump + with + | [ ("Pair", why) ] -> contains why "f64" && contains why "f32" + | _ -> false); + (* A struct the header says nothing about is not a disagreement: a package + may describe something the library does not name. *) + check "a struct the header does not describe is left alone" + (Cimport.check_structs ~env + ~structs:(structs_of (program "(defstruct Nowhere [q i32])\n")) dump + = []); + + (* diff_bound: a hand-written declare-c against the header's own signature. + This is the check with no other source — a wrong declare-c is wrong in the + generated prototype too, so the two halves agree with each other and only + the library knows better. *) + let bound_of src = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.DeclareC (fn, sym) -> Some (fn, sym) | _ -> None) + (program src) + in + let differs name src needle = + check ("declare-c against the header: " ^ name) + (match Cimport.diff_bound ~env ~bound:(bound_of src) dump with + | [ d ] -> contains d.Cimport.dwhy needle + | _ -> false) + in + check "a declare-c that matches the header is not reported" + (Cimport.diff_bound ~env + ~bound:(bound_of "(declare-c add [a i32 b i32] i32 \"add_ints\")") dump + = []); + differs "a wrong parameter width" + "(declare-c add [a f64 b i32] i32 \"add_ints\")" "parameter a is f64"; + differs "a wrong arity" "(declare-c add [a i32] i32 \"add_ints\")" + "the header says 2"; + differs "a wrong return type" + "(declare-c add [a i32 b i32] f32 \"add_ints\")" "returns f32"; + (* A symbol the header does not have at all is the version-drift case, and + it is how a package pinned to the wrong release announces itself. *) + differs "a symbol the header does not declare" + "(declare-c gone [] \"no_such_function\")" "does not declare"; + (* An enum face against a plain int is the expected difference and not a + finding: that is what a defenum is at the boundary. *) + check "an enum face against the header's int is not a difference" + (Cimport.diff_bound ~env + ~bound:(bound_of "(declare-c mv [m Mood] i32 \"mood_value\")") dump + = []); + + (* The name rule. Reversibility is by storage — the C symbol is kept verbatim + in the declaration — so what the rule has to be is injective over one + header, which the collision case above asserts. These pin its shape. *) + List.iter + (fun (c, flan) -> + check + (Printf.sprintf "kebab %s -> %s" c flan) + (String.equal (Cimport.kebab c) flan)) + [ ("InitWindow", "init-window"); + (* An acronym stays one word rather than becoming separate letters. *) + ("SetTargetFPS", "set-target-fps"); + ("ColorToHSV", "color-to-hsv"); + ("UnloadUTF8", "unload-utf8"); + (* A digit run takes the uppercase after it, so 2D is one word. *) + ("BeginMode2D", "begin-mode-2d"); + ("GetScreenToWorld2D", "get-screen-to-world-2d"); + ("snake_case_already", "snake-case-already") ]; + + (* cjson.ml, on the shapes clang's dump actually contains. *) + check "json: an escaped string" + (match Cjson.parse "{\"a\":\"x\\ny\"}" with + | Cjson.Obj [ ("a", Cjson.Str "x\ny") ] -> true + | _ -> false); + check "json: nesting, numbers, booleans and null" + (match Cjson.parse "{\"i\":[1,-2,3.5e2],\"b\":true,\"n\":null}" with + | Cjson.Obj + [ ("i", Cjson.Arr [ _; _; _ ]); ("b", Cjson.Bool true); + ("n", Cjson.Null) ] -> true + | _ -> false); + check "json: empty containers" + (match Cjson.parse "{\"a\":{},\"b\":[]}" with + | Cjson.Obj [ ("a", Cjson.Obj []); ("b", Cjson.Arr []) ] -> true + | _ -> false); + check "json: trailing bytes are refused" + (match Cjson.parse "{} x" with + | _ -> false + | exception Cjson.Bad _ -> true); + (* ── The acceptance program checks end to end ──────────────────── *) accepts "calc-me.flan type checks" (In_channel.with_open_bin "../calc-me.flan" In_channel.input_all);