shoney/writeonce
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 1

feat(compiler): Tasks 1-4 — scaffold, diagnostics, lexer, declaration parser

Browse source 
- Task 1: OCaml/dune scaffold with woc CLI (exit codes 0/1/2), just woc-build/woc-test
- Task 2: Diagnostics module — WO-E coded diagnostics with excerpts, related sites, ordered dedup collector, exit-code decision
- Task 3: Newline-significant lexer mirroring rt conventions (self/me/subscribe/insert stay idents), --dump-tokens, golden test framework with bless mode
- Task 4: Declaration parser — class/type/interface/fn signatures, @gc/@table annotations, brace-depth skip-on-block (service/policy/on), decl-level recovery, --dump-ast goldens
- 13 golden fixtures (tokens + AST) with WOC_BLESS=1 support
- just woc-test green (14 diag + 93 runner checks)
This commit is contained in:
shoney.arickathil 2026-08-10 09:00:08 +02:00
parent ad806c415d
commit 012562290d
27 changed files with 2277 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
compiler/README.md Normal file
View file

@ -0,0 +1,30 @@
# compiler/ — the OCaml `woc` compiler
Lexer → parser → typechecker → ownership pass → bytecode emitter for `.wo`. OCaml stdlib only (no Menhir, no ppx); dune is the build runner. Sibling of the C `wovm` bytecode VM (`runtime/`) — the two halves of the OOP track's spec (`docs/superpowers/specs/2026-08-01-oop-compiler-vm-design.md`) meet at plan 3 (`.wob` emission).
**Stage: Task 1 scaffold.** `src/` is currently an empty library and `bin/main.ml` is a CLI stub that only wires the exit-code contract below — no lexing, parsing, or checking happens yet. Tasks 2–8 (`compiler/plan/2026-08-01-woc-compiler-front.md`) fill in diagnostics, lexer, parser, typechecker, and the ownership pass in that order.
## Requirements
OCaml 4.14.1, dune 3.14.0 — Ubuntu 24.04 apt packages (`sudo apt install ocaml dune`), the version floor. Confirm with `ocaml -version` / `dune --version`. No opam packages, no Menhir, no ppx — stdlib only.
## Build, test
```bash
cd compiler && dune build # -> _build/default/bin/woc
cd compiler && dune runtest # golden suite (empty until Task 3 adds test/dune)
just woc-build # same, from the repo root
just woc-test # same, from the repo root
```
`woc` with no arguments (or the wrong number of arguments) prints usage to stderr and exits 2; given one path argument it exits 0 if the path exists, 2 if it doesn't. Exit-code contract, established now and enforced fully once diagnostics land in Task 2: **0** clean compile, **1** diagnostics reported, **2** usage/IO failure.
## Layout
- `src/` — one module per stage, added as each task lands: diag, token, lexer, ast, parser, types, owner, dump
- `bin/` — the `woc` executable (check / emit / build modes land in later tasks)
- `test/` — golden runner; `test/golden/` holds fixtures per stage (Task 3 onward)
- `plan/` — compiler-track docs: [`architecture.md`](plan/architecture.md) (pipeline, module contracts, reference-study map) + plans 2, 3, 8
Governing docs: spec `docs/superpowers/specs/2026-08-01-oop-compiler-vm-design.md`; plans 2, 3, 8 in `compiler/plan/`. Format contract: `docs/plan/oop-vm/00-wob-format.md`.

17
compiler/bin/dune Normal file
View file

@ -0,0 +1,17 @@
(executable
(name main)
(libraries woc_lib))
; dune names the built executable after its main module (Main, from
; main.ml), which lands in the build directory as main.exe. Copy it to
; the plain "woc" name and fold that into this directory's default
; alias so a bare `dune build` produces the woc binary directly.
(rule
(target woc)
(deps main.exe)
(action
(copy main.exe woc)))
(alias
(name default)
(deps woc))

110
compiler/bin/main.ml Normal file
View file

@ -0,0 +1,110 @@
(* woc — the writeonce OCaml compiler front end.
Task 1 scaffolded the CLI's exit-code contract with no compiler
stage behind it. Task 2 added diagnostics (compiler/src/diag.ml).
Task 3 added the lexer (compiler/src/{token,lexer}.ml) behind
--dump-tokens. Task 4 adds the declaration parser
(compiler/src/{ast,parser}.ml) behind --dump-ast, printing a stable,
golden-diffed AST dump (compiler/src/dump.ml) to stdout. Tasks 5-7
add statement/expression parsing, the typechecker, and the ownership
pass behind their own --dump-* flags; Task 8 adds directory
discovery and multi-file programs, at which point the bare
`woc <path>` form below starts actually compiling instead of just
checking existence.
0 = clean compile
1 = diagnostics reported (reachable now: --dump-tokens on source
with an unknown character, or --dump-ast on source with a
broken declaration, reports WO-E0xx/WO-E1xx and exits 1)
2 = usage or IO failure
With no arguments, this prints usage to stderr and exits 2. Given a
single path argument (no flag), it exits 0 if the path exists and 2
(with a stderr message) if it does not — this bare-path form
predates any real compilation and stays as-is until Task 8. *)
let usage_msg =
"usage: woc <path>\n\
usage: woc --dump-tokens <file.wo>\n\
usage: woc --dump-ast <file.wo>\n\
\n\
Compiles writeonce (.wo) source. <path> is a single .wo file or a\n\
directory to discover .wo files under (directory discovery lands in\n\
a later task; compilation itself has not landed yet either).\n\
\n\
--dump-tokens prints one line per lexed token to stdout, in source\n\
order (\"LINE:COL KIND\" or \"LINE:COL KIND(payload)\"), ending with\n\
EOF; lexing diagnostics, if any, print to stderr.\n\
\n\
--dump-ast prints the declaration- and body-level AST as an indented\n\
tree to stdout (class/type/interface/fn declarations, with real\n\
statement/expression parsing inside method and free-fn bodies);\n\
parsing diagnostics, if any, print to stderr.\n\
\n\
Exit codes: 0 clean, 1 diagnostics reported, 2 usage/IO failure.\n"
let read_source path =
try
let ic = open_in_bin path in
let n = in_channel_length ic in
let s = really_input_string ic n in
close_in ic;
Ok s
with Sys_error msg -> Error msg
let dump_tokens path =
if not (Sys.file_exists path) then begin
Printf.eprintf "woc: no such file or directory: %s\n" path;
exit 2
end;
match read_source path with
| Error msg ->
Printf.eprintf "woc: %s\n" msg;
exit 2
| Ok src ->
let collector = Woc_lib.Diag.Collector.create () in
let toks = Woc_lib.Lexer.tokenize collector ~file:path src in
print_string (Woc_lib.Dump.dump_tokens toks);
if Woc_lib.Diag.Collector.has_error collector then begin
let lookup f = if f = path then Some src else None in
prerr_string (Woc_lib.Diag.Collector.render_all collector lookup);
prerr_newline ();
exit 1
end
else exit 0
let dump_ast path =
if not (Sys.file_exists path) then begin
Printf.eprintf "woc: no such file or directory: %s\n" path;
exit 2
end;
match read_source path with
| Error msg ->
Printf.eprintf "woc: %s\n" msg;
exit 2
| Ok src ->
let collector = Woc_lib.Diag.Collector.create () in
let toks = Woc_lib.Lexer.tokenize collector ~file:path src in
let prog = Woc_lib.Parser.parse collector ~file:path toks in
print_string (Woc_lib.Dump.dump_ast prog);
if Woc_lib.Diag.Collector.has_error collector then begin
let lookup f = if f = path then Some src else None in
prerr_string (Woc_lib.Diag.Collector.render_all collector lookup);
prerr_newline ();
exit 1
end
else exit 0
let () =
match Sys.argv with
| [| _; "--dump-tokens"; path |] -> dump_tokens path
| [| _; "--dump-ast"; path |] -> dump_ast path
| [| _; path |] ->
if Sys.file_exists path then exit 0
else begin
Printf.eprintf "woc: no such file or directory: %s\n" path;
exit 2
end
| _ ->
prerr_string usage_msg;
exit 2

1
compiler/dune-project Normal file
View file

@ -0,0 +1 @@
(lang dune 3.14)

205
compiler/src/diag.ml Normal file
View file

@ -0,0 +1,205 @@
(* diag.ml — the diagnostics module for woc.
Every later stage (lexer, parser, typechecker, ownership pass)
reports through this one channel. A diagnostic is:
- a stable code, e.g. "WO-E301"
- a severity: Error or Warning
- a primary site: file, 1-based line, 1-based column
- a human-readable message
- zero or more *related* sites (file/line/col + a short label),
used for two-site errors such as the ownership pass's
"moved here ... used here"
Rendering follows the rustc/OCaml convention: a single header line
("file:line:col: severity CODE: message"), the source line, and a
caret line with '^' under the reported column. Related sites render
the same way, indented beneath the primary diagnostic. Column
counting treats every character as exactly one column — including
tab — so the renderer never expands tabs: a caret's horizontal
offset in the rendered text is always (column - 1) characters,
matching how a lexer counts columns while scanning raw bytes.
Rendering needs the actual source text to build an excerpt from, but
this module never touches the filesystem itself: callers supply a
`source_lookup` (file name -> file contents option). This keeps
diag.ml usable from unit tests (in-memory fixtures) and from the
real driver (reads files) alike, and keeps IO failures a driver
concern, not a diagnostics-rendering concern.
The Collector accumulates diagnostics as stages produce them —
parser/typer/owner recovery can add several in one pass, not
necessarily in source order. For output it sorts by
(file, line, col), drops exact (code, file, line, col) duplicates
(first occurrence wins), and decides the process exit code from
that same deduped, sorted view: 1 if any diagnostic surviving
dedup is an error, 0 otherwise. exit_code always agrees with what
diagnostics/render_all would show — it never inspects the raw,
pre-dedup accumulation, so a duplicate entry that dedup drops can
never flip the exit code against what was actually reported. Exit
code 2 (usage/IO failure) is never decided here — that is
bin/main.ml's call, made before any compiler stage runs.
Code ranges are reserved per stage now, so the Task-8 catalog
(docs/plan/oop-vm/01-error-catalog.md) is an enumeration of codes
already in use, not an archaeology dig:
WO-E0xx lexing (Task 3)
WO-E1xx parsing (Task 4, 5)
WO-E2xx types (Task 6)
WO-E3xx ownership (Task 7)
No codes are minted in this module — it only reserves the ranges.
The prefixes below are the single documented source later stages
build their concrete codes from (e.g. lexing_prefix ^ "12" ->
"WO-E012"). *)
let lexing_prefix = "WO-E0"
let parsing_prefix = "WO-E1"
let types_prefix = "WO-E2"
let ownership_prefix = "WO-E3"
type severity =
| Error
| Warning
(* A single point in a source file. Both line and col are 1-based. *)
type site = {
file : string;
line : int;
col : int;
}
(* A secondary location attached to a diagnostic, with a short label
describing its role (e.g. "moved here"). *)
type related = {
site : site;
label : string;
}
type t = {
code : string;
severity : severity;
site : site;
message : string;
related : related list;
}
(* Alias used inside the nested Collector module below so it can refer
to the diagnostic type without shadowing its own state type `t`. *)
type diagnostic = t
let related_site ~file ~line ~col ~label : related =
{ site = { file; line; col }; label }
let make ~code ~severity ~file ~line ~col ~message ?(related = []) () : t =
{ code; severity; site = { file; line; col }; message; related }
let error ~code ~file ~line ~col ~message ?(related = []) () : t =
make ~code ~severity:Error ~file ~line ~col ~message ~related ()
let warning ~code ~file ~line ~col ~message ?(related = []) () : t =
make ~code ~severity:Warning ~file ~line ~col ~message ~related ()
let severity_word = function
| Error -> "error"
| Warning -> "warning"
(* Given a file name, return its full source text, or None if
unavailable (unreadable, unknown, etc). diag.ml never reads the
filesystem itself — callers own IO. *)
type source_lookup = string -> string option
let line_text (lookup : source_lookup) (site : site) : string option =
if site.line < 1 then None
else
match lookup site.file with
| None -> None
| Some contents ->
(* site.line is 1-based; String.split_on_char indices are 0-based.
List.nth_opt raises Invalid_argument (rather than returning
None) for a negative index, so the guard above is load-bearing:
without it, a diagnostic constructed with an out-of-range line
(a bug in some future stage) would crash the renderer instead
of falling back to a header-only line the way an unknown file
already does. *)
List.nth_opt (String.split_on_char '\n' contents) (site.line - 1)
let caret_line (col : int) : string =
(* Every character — tabs included — counts as one column, so the
caret's offset is simply (col - 1) plain spaces. We do not expand
tabs or otherwise inspect the source line's characters here. *)
String.make (max 0 (col - 1)) ' ' ^ "^"
(* Renders one site as [header] or [header; source-line; caret-line]
depending on whether an excerpt is available. *)
let render_block (lookup : source_lookup) (site : site) (label : string) :
string list =
let header = Printf.sprintf "%s:%d:%d: %s" site.file site.line site.col label in
match line_text lookup site with
| None -> [ header ]
| Some text -> [ header; text; caret_line site.col ]
let render (lookup : source_lookup) (d : t) : string =
let primary_label =
Printf.sprintf "%s %s: %s" (severity_word d.severity) d.code d.message
in
let primary = render_block lookup d.site primary_label in
let indent line = " " ^ line in
let related_blocks =
List.concat_map
(fun (r : related) -> List.map indent (render_block lookup r.site r.label))
d.related
in
String.concat "\n" (primary @ related_blocks)
module Collector = struct
type t = { mutable items : diagnostic list (* reverse insertion order *) }
let create () : t = { items = [] }
let add (c : t) (d : diagnostic) : unit = c.items <- d :: c.items
let site_key (d : diagnostic) = (d.site.file, d.site.line, d.site.col)
(* Diagnostics in output order: sorted by (file, line, col) — stable,
so diagnostics tied on site keep their original insertion
(source/recovery) order — with exact (code, file, line, col)
duplicates dropped (first occurrence wins). *)
let diagnostics (c : t) : diagnostic list =
let in_insertion_order = List.rev c.items in
let sorted =
List.stable_sort
(fun a b -> compare (site_key a) (site_key b))
in_insertion_order
in
let seen = Hashtbl.create 16 in
List.filter
(fun d ->
let key = (d.code, d.site.file, d.site.line, d.site.col) in
if Hashtbl.mem seen key then false
else (
Hashtbl.add seen key ();
true))
sorted
(* Deliberately scans `diagnostics c` (the sorted, deduped view),
not raw `c.items`: dedup keeps only the first-inserted occurrence
per (code, file, line, col), so if a Warning and an Error ever
land at the exact same (code, site), the surviving displayed
diagnostic is whichever was added first — and exit_code must
agree with that same survivor, not with severities dedup already
discarded. Scanning c.items here would let exit_code see a
dropped Error that the rendered report no longer shows. *)
let has_error (c : t) : bool =
List.exists (fun d -> d.severity = Error) (diagnostics c)
(* woc's exit-code contract is 0 clean / 1 diagnostics reported / 2
usage-IO failure. This module only ever returns 0 or 1 — exit
code 2 is decided by the driver (bin/main.ml) before any compiler
stage runs, never here. *)
let exit_code (c : t) : int = if has_error c then 1 else 0
let render_all (c : t) (lookup : source_lookup) : string =
diagnostics c |> List.map (render lookup) |> String.concat "\n\n"
end

335
compiler/src/lexer.ml Normal file
View file

@ -0,0 +1,335 @@
(* lexer.ml — tokenizer for `.wo` source (milestone-1 OOP subset).
Ported from crates/rt/src/lexer.rs; behavior kept identical wherever
it defines what the language literally is:
- newline tokens are emitted, never filtered, and consecutive
newlines collapse to a single Newline token — exactly rt's
`out.last() == Some(Newline) => don't push another` rule;
- `--` starts a line comment that runs to (not including) the next
newline;
- single- or double-quoted strings support the same backslash
escapes as rt: n, t, backslash, or either quote character, each
backslash-prefixed; anything else verbatim;
- integer literals are plain runs of ASCII digits;
- identifiers may contain internal dashes, exactly like rt's
read_ident_chars (crates/rt/src/lexer.rs) — so `foo-bar` lexes as
one identifier, not `foo`, Dash, `bar`. This is a faithful port of
an rt quirk, not a milestone-1 design choice: Task 5's expression
parser must therefore require whitespace around a binary minus
that immediately follows an identifier (`a - b`, not `a-b`) to
avoid the ambiguity, exactly as rt's schema layer already does.
Flagged here for whoever picks up Task 5.
Divergence from rt, deliberate: rt's `tokenize` returns
`anyhow::Result` and bails (stops the whole file) on the first bad
byte or malformed punctuation shape (a bare `!` not followed by
`=`, a `$` with no name, ...). This front end's diagnostics contract
is multi-error (compiler/src/diag.ml — every later stage accumulates
into one Collector rather than stopping at the first problem), so
every one of those cases becomes: report one WO-E001 unknown-
character diagnostic at the offending position, skip exactly that
one byte, and keep lexing. One bad byte must never stop the whole
file (Task 3 brief's Unknown character decision). *)
let unknown_char_code = Diag.lexing_prefix ^ "01" (* WO-E001 *)
(* rt's equivalent site (crates/rt/src/lexer.rs:106) bails outright: a
backslash as the very last byte of the file, with no character left
to escape, loses information silently otherwise (the intended escaped
character is simply gone, not skip-and-continue like the unknown-
character case). Ported as its own code rather than reusing WO-E001
because the shape is different (a truncated escape, not a byte the
lexer doesn't recognize at all) and diag.ml's convention is one code
per distinct lexing situation.
Deliberately NOT applied to a plain unterminated string: a string
that runs off the end of the file with no dangling backslash (say,
a quote-open let-binding with nothing after it and no closing quote)
— rt does not bail there either, its scanning loop just stops when
peek returns None and emits whatever was collected as the Str token.
Reporting nothing in that case is intentional rt parity, not an
oversight; pinned by the plain-unterminated-string-reports-nothing
assertion in compiler/test/runner.ml. *)
let unterminated_escape_code = Diag.lexing_prefix ^ "02" (* WO-E002 *)
type lexer = {
src : string;
len : int;
mutable pos : int;
mutable line : int;
mutable col : int;
}
let make src = { src; len = String.length src; pos = 0; line = 1; col = 1 }
let peek lx = if lx.pos < lx.len then Some lx.src.[lx.pos] else None
let peek_at lx n =
let i = lx.pos + n in
if i < lx.len then Some lx.src.[i] else None
let advance lx =
match peek lx with
| None -> None
| Some c ->
lx.pos <- lx.pos + 1;
if c = '\n' then begin
lx.line <- lx.line + 1;
lx.col <- 1
end
else lx.col <- lx.col + 1;
Some c
let is_digit c = c >= '0' && c <= '9'
let is_alpha c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
let is_ident_start c = is_alpha c || c = '_'
let is_ident_cont c = is_alpha c || is_digit c || c = '_' || c = '-'
(* Consumes a run of identifier characters starting at the lexer's
current position (caller has already confirmed is_ident_start on
the character at that position) and returns the collected text.
Mirrors rt's read_ident_chars, dash-continuation included (see
module doc). *)
let read_ident_chars lx =
let start = lx.pos in
let continue_ = ref true in
while !continue_ do
match peek lx with
| Some c when is_ident_cont c -> ignore (advance lx)
| _ -> continue_ := false
done;
String.sub lx.src start (lx.pos - start)
(* The milestone-1 keyword set, exact per the Task 3 brief: type class
interface fn let mut take return if else while for in true false,
plus uppercase-only INSERT/SELECT. Deliberately absent: self, me,
subscribe, receive, and lowercase insert/select — those fall
through to the `_ -> None` case below and lex as plain Ident,
matching rt and the CLAUDE.md gotcha this task exists to preserve. *)
let keyword_kind = function
| "type" -> Some Token.KwType
| "class" -> Some Token.KwClass
| "interface" -> Some Token.KwInterface
| "fn" -> Some Token.KwFn
| "let" -> Some Token.KwLet
| "mut" -> Some Token.KwMut
| "take" -> Some Token.KwTake
| "return" -> Some Token.KwReturn
| "if" -> Some Token.KwIf
| "else" -> Some Token.KwElse
| "while" -> Some Token.KwWhile
| "for" -> Some Token.KwFor
| "in" -> Some Token.KwIn
| "true" -> Some Token.KwTrue
| "false" -> Some Token.KwFalse
| "INSERT" -> Some Token.KwInsert
| "SELECT" -> Some Token.KwSelect
| _ -> None
let tokenize (collector : Diag.Collector.t) ~(file : string) (src : string) :
Token.t list =
let lx = make src in
let out = ref [] in
let emit kind line col = out := { Token.kind; line; col } :: !out in
let last_is_newline () =
match !out with
| { Token.kind = Token.Newline; _ } :: _ -> true
| _ -> false
in
let report_unknown line col c =
Diag.Collector.add collector
(Diag.error ~code:unknown_char_code ~file ~line ~col
~message:(Printf.sprintf "unknown character '%c'" c) ())
in
let report_unterminated_escape line col =
Diag.Collector.add collector
(Diag.error ~code:unterminated_escape_code ~file ~line ~col
~message:"unterminated string escape" ())
in
let running = ref true in
while !running do
match peek lx with
| None -> running := false
| Some c -> (
let line = lx.line and col = lx.col in
if c = '-' && peek_at lx 1 = Some '-' then begin
(* line comment: -- ... EOL (EOL itself is left for the next
iteration to turn into its own Newline token). *)
let scanning = ref true in
while !scanning do
match peek lx with
| Some '\n' | None -> scanning := false
| Some _ -> ignore (advance lx)
done
end
else if c = '\n' then begin
ignore (advance lx);
if not (last_is_newline ()) then emit Token.Newline line col
end
else if c = ' ' || c = '\t' || c = '\r' then ignore (advance lx)
else if c = '"' || c = '\'' then begin
let quote = c in
ignore (advance lx);
let buf = Buffer.create 16 in
let scanning = ref true in
while !scanning do
match peek lx with
| None ->
(* Plain unterminated string (ran off the end of the file
with no closing quote and no dangling backslash): rt does
not bail here either, it just stops and emits whatever was
collected. No diagnostic, deliberately — see
unterminated_escape_code's doc comment above. *)
scanning := false
| Some c when c = quote ->
ignore (advance lx);
scanning := false
| Some '\\' -> (
(* Captured before advancing: this is the backslash's own
position, so a dangling-escape diagnostic points at the
`\` itself rather than wherever the scan happens to stop. *)
let esc_line = lx.line and esc_col = lx.col in
ignore (advance lx);
match advance lx with
| Some 'n' -> Buffer.add_char buf '\n'
| Some 't' -> Buffer.add_char buf '\t'
| Some '\\' -> Buffer.add_char buf '\\'
| Some '"' -> Buffer.add_char buf '"'
| Some '\'' -> Buffer.add_char buf '\''
| Some other -> Buffer.add_char buf other
| None ->
report_unterminated_escape esc_line esc_col;
scanning := false)
| Some other ->
ignore (advance lx);
Buffer.add_char buf other
done;
emit (Token.Str (Buffer.contents buf)) line col
end
else if is_digit c then begin
let n = ref 0 in
let scanning = ref true in
while !scanning do
match peek lx with
| Some d when is_digit d ->
n := (!n * 10) + (Char.code d - Char.code '0');
ignore (advance lx)
| _ -> scanning := false
done;
emit (Token.Int !n) line col
end
else if is_ident_start c then begin
let name = read_ident_chars lx in
let kind =
match keyword_kind name with Some k -> k | None -> Token.Ident name
in
emit kind line col
end
else
match c with
| '{' ->
ignore (advance lx);
emit Token.LBrace line col
| '}' ->
ignore (advance lx);
emit Token.RBrace line col
| '(' ->
ignore (advance lx);
emit Token.LParen line col
| ')' ->
ignore (advance lx);
emit Token.RParen line col
| '[' ->
ignore (advance lx);
emit Token.LBracket line col
| ']' ->
ignore (advance lx);
emit Token.RBracket line col
| ',' ->
ignore (advance lx);
emit Token.Comma line col
| ';' ->
ignore (advance lx);
emit Token.Semicolon line col
| ':' ->
ignore (advance lx);
emit Token.Colon line col
| '.' -> (
ignore (advance lx);
match peek lx with
| Some '.' ->
ignore (advance lx);
emit Token.DotDot line col
| _ -> emit Token.Dot line col)
| '?' ->
ignore (advance lx);
emit Token.Question line col
| '@' ->
ignore (advance lx);
emit Token.At line col
| '|' ->
ignore (advance lx);
emit Token.Pipe line col
| '-' -> (
ignore (advance lx);
match peek lx with
| Some '>' ->
ignore (advance lx);
emit Token.Arrow line col
| Some '=' ->
ignore (advance lx);
emit Token.MinusEq line col
| _ -> emit Token.Dash line col)
| '+' -> (
ignore (advance lx);
match peek lx with
| Some '=' ->
ignore (advance lx);
emit Token.PlusEq line col
| _ -> emit Token.Plus line col)
| '*' ->
ignore (advance lx);
emit Token.Star line col
| '/' ->
ignore (advance lx);
emit Token.Slash line col
| '%' ->
ignore (advance lx);
emit Token.Percent line col
| '=' -> (
ignore (advance lx);
match peek lx with
| Some '=' ->
ignore (advance lx);
emit Token.EqEq line col
| Some '>' ->
ignore (advance lx);
emit Token.FatArrow line col
| _ -> emit Token.Eq line col)
| '!' -> (
ignore (advance lx);
match peek lx with
| Some '=' ->
ignore (advance lx);
emit Token.NotEq line col
| _ -> report_unknown line col '!')
| '<' -> (
ignore (advance lx);
match peek lx with
| Some '=' ->
ignore (advance lx);
emit Token.LtEq line col
| _ -> emit Token.Lt line col)
| '>' -> (
ignore (advance lx);
match peek lx with
| Some '=' ->
ignore (advance lx);
emit Token.GtEq line col
| _ -> emit Token.Gt line col)
| other ->
ignore (advance lx);
report_unknown line col other)
done;
emit Token.Eof lx.line lx.col;
List.rev !out

85
compiler/src/token.ml Normal file
View file

@ -0,0 +1,85 @@
(* token.ml — token kinds for the woc lexer.
Ported from the Rust runtime's lexer/token pair
(crates/rt/src/token.rs, crates/rt/src/lexer.rs), trimmed to the
milestone-1 OOP subset this compiler front targets (Task 3 of
compiler/plan/2026-08-01-woc-compiler-front.md). Kept from rt:
position-tracked tokens, the same literal forms (Ident/Int/Str),
newline-as-a-real-token, and a punctuation/operator set mirroring
rt's generic categories (braces, parens, brackets, comma, colon,
dot, arrow, assignment, arithmetic, comparison).
Deliberately dropped relative to rt's token.rs: the schema/query
layer keyword zoo (ref, multi, via, policy, txn, BEGIN/COMMIT/...),
the `$name` parameter token, and the `#name` / `##name` block-marker
tokens — none of those belong to the milestone-1 OOP language this
front end parses (interface/class/fn declarations and bodies), only
to rt's schema DSL. INSERT/SELECT are kept as uppercase-only keyword
stubs because Task 5 parses them into an opaque DbStub node;
lowercase `insert`/`select` fall through to Ident, exactly like rt
(CLAUDE.md gotcha — this is the whole reason Task 3 exists as a
from-scratch lexer rather than a copy of rt's). *)
type kind =
(* literals *)
| Ident of string
| Int of int
| Str of string
(* milestone-1 keywords *)
| KwType
| KwClass
| KwInterface
| KwFn
| KwLet
| KwMut
| KwTake
| KwReturn
| KwIf
| KwElse
| KwWhile
| KwFor
| KwIn
| KwTrue
| KwFalse
(* uppercase-only SQL-layer stubs (Task 5 parses these into a DbStub
span); lowercase "insert"/"select" are plain Ident, never these. *)
| KwInsert
| KwSelect
(* punctuation / operators, mirroring rt's generic set *)
| LBrace
| RBrace
| LParen
| RParen
| LBracket
| RBracket
| Comma
| Semicolon
| Colon
| Dot
| DotDot (* .. *)
| Question
| At
| Pipe
| Arrow (* -> *)
| FatArrow (* => *)
| Dash
| Plus
| Star
| Slash
| Percent
| Eq
| EqEq
| NotEq
| Lt
| LtEq
| Gt
| GtEq
| PlusEq
| MinusEq
(* meta *)
| Newline
| Eof
(* line and col are both 1-based, matching rt's Token and diag.ml's
site convention. *)
type t = { kind : kind; line : int; col : int }

31
compiler/test/dune Normal file
View file

@ -0,0 +1,31 @@
; Task 2 seam: a plain assert-and-print test executable wired into
; `dune runtest`, just enough to TDD compiler/src/diag.ml. Task 3 adds
; the golden-file runner (runner.ml + test/golden/ fixtures) alongside
; this file — keep this stanza minimal so that addition is additive,
; not a rewrite.
(test
(name test_diag)
(modules test_diag)
(libraries woc_lib))
; Task 3: golden-file runner. (deps (source_tree golden)) does two
; jobs at once: it keeps the build-directory copy of golden/ that this
; test reads from fresh on every run, and it is *why* dune notices a
; fixture edit at all -- without a declared dependency on that
; directory, dune has nothing to digest to decide this test's cached
; PASS is stale, and a changed .wo/.expected file would go unnoticed.
; WOC_BLESS=1 rewrites the real compiler/test/golden files on disk
; directly (see runner.ml's module doc for why a bare relative write
; from inside a dune test would not do that). The ../bin/woc dep is for
; the CLI smoke section: it forces the woc binary to be built before
; this test runs, and (because dune places a directory dependency's
; target at the same relative path inside the sandbox) guarantees
; "../bin/woc" resolves from this test's cwd exactly the way runner.ml
; assumes.
(test
(name runner)
(modules runner)
(libraries woc_lib)
(deps
(source_tree golden)
../bin/woc))

6
compiler/test/golden/ast/field-named-sync-keyword.expected Normal file
View file

@ -0,0 +1,6 @@
1:1 CLASS Toggle
2:3 FIELD id: Id
3:3 FIELD on: Bool
4:3 FIELD service: Text
5:3 FIELD policy: Text
6:3 FIELD name: Text

14
compiler/test/golden/ast/field-named-sync-keyword.wo Normal file
View file

@ -0,0 +1,14 @@
class Toggle {
id: Id
on: Bool
service: Text
policy: Text
name: Text
policy read anyone
on update when old.on == false and new.on == true
do set self.name = { note: "toggled", at: now() }
service rest "/api/toggles" expose list, get
}

24
compiler/test/golden/ast/pricing-demo.expected Normal file
View file

@ -0,0 +1,24 @@
1:1 INTERFACE Priced
2:3 METHOD current_price() -> Money
6:1 CLASS Product @table(name="products", index=[sku])
7:3 FIELD id: Id
8:3 FIELD sku: SKU @unique
9:3 FIELD name: Text
10:3 FIELD prices: multi Price
11:3 FIELD owner: ref Customer
13:3 METHOD current_price() -> Money
14:5 RETURN latest(self.prices).amount
17:3 METHOD rename(name: Text)
18:5 ASSIGN self.name = name
21:3 METHOD set_price(mut amount: Money)
22:5 ASSIGN self.prices = amount
25:3 METHOD adopt(take other: Product) -> Product
26:5 RETURN other
31:1 CLASS PriceCache @gc
32:3 FIELD entries: map<SKU, Money>
35:1 TYPE Note
36:3 FIELD id: Id
37:3 FIELD body: Text
38:3 FIELD created: Timestamp = now()
41:1 METHOD discount(mut amount: Money, take pct: Int) -> Money
42:3 RETURN amount

43
compiler/test/golden/ast/pricing-demo.wo Normal file
View file

@ -0,0 +1,43 @@
interface Priced {
fn current_price() -> Money
}
@table(name: "products", index: [sku])
class Product {
id: Id
sku: SKU @unique
name: Text
prices: multi Price
owner: ref Customer
fn current_price() -> Money {
return latest(self.prices).amount;
}
fn rename(name: Text) {
self.name = name;
}
fn set_price(mut amount: Money) {
self.prices = amount;
}
fn adopt(take other: Product) -> Product {
return other;
}
}
@gc
class PriceCache {
entries: map<SKU, Money>
}
type Note {
id: Id
body: Text
created: Timestamp = now()
}
fn discount(mut amount: Money, take pct: Int) -> Money {
return amount;
}

4
compiler/test/golden/ast/skip-on-block.expected Normal file
View file

@ -0,0 +1,4 @@
1:1 CLASS Article
2:3 FIELD id: Id
3:3 FIELD title: Text
13:3 FIELD published: Bool = KW_FALSE

14
compiler/test/golden/ast/skip-on-block.wo Normal file
View file

@ -0,0 +1,14 @@
class Article {
id: Id
title: Text
policy read anyone
policy write for role Admin
service rest "/api/articles" expose list, get
on update when old.published == false and new.published == true
do set self.published_at = { article_id: self.id, at: now() }
published: Bool = false
}

2
compiler/test/golden/ast/two-error-recovery.expected Normal file
View file

@ -0,0 +1,2 @@
6:1 CLASS Good
7:3 FIELD id: Id

12
compiler/test/golden/ast/two-error-recovery.wo Normal file
View file

@ -0,0 +1,12 @@
class Broken1 {
id: Id
bad_field Text
}
class Good {
id: Id
}
interface Broken2 {
fn oops(x Text) -> Money
}

5
compiler/test/golden/tokens/dangling-escape.expected Normal file
View file

@ -0,0 +1,5 @@
1:1 KW_LET
1:5 IDENT(bad)
1:9 EQ
1:11 STR(abc)
1:16 EOF

1
compiler/test/golden/tokens/dangling-escape.wo Normal file
View file

@ -0,0 +1 @@
let bad = "abc\

7
compiler/test/golden/tokens/dash-continuation.expected Normal file
View file

@ -0,0 +1,7 @@
1:1 IDENT(a-b)
1:4 NEWLINE
2:1 IDENT(a)
2:3 DASH
2:5 IDENT(b)
2:6 NEWLINE
3:1 EOF

2
compiler/test/golden/tokens/dash-continuation.wo Normal file
View file

@ -0,0 +1,2 @@
a-b
a - b

28
compiler/test/golden/tokens/gotcha.expected Normal file
View file

@ -0,0 +1,28 @@
1:58 NEWLINE
2:1 IDENT(self)
2:6 IDENT(me)
2:9 IDENT(subscribe)
2:19 IDENT(receive)
2:27 IDENT(insert)
2:34 IDENT(select)
2:40 NEWLINE
3:1 KW_TYPE
3:6 KW_CLASS
3:12 KW_INTERFACE
3:22 KW_FN
3:25 KW_LET
3:29 KW_MUT
3:33 KW_TAKE
3:38 KW_RETURN
3:45 KW_IF
3:48 KW_ELSE
3:53 KW_WHILE
3:59 KW_FOR
3:63 KW_IN
3:66 KW_TRUE
3:71 KW_FALSE
3:76 NEWLINE
4:1 KW_INSERT
4:8 KW_SELECT
4:14 NEWLINE
5:1 EOF

4
compiler/test/golden/tokens/gotcha.wo Normal file
View file

@ -0,0 +1,4 @@
-- gotcha fixture: keyword vs plain-identifier boundaries
self me subscribe receive insert select
type class interface fn let mut take return if else while for in true false
INSERT SELECT

169
compiler/test/golden/tokens/representative.expected Normal file
View file

@ -0,0 +1,169 @@
1:88 NEWLINE
2:1 AT
2:2 IDENT(table)
2:7 LPAREN
2:8 IDENT(name)
2:12 COLON
2:14 STR(products)
2:24 COMMA
2:26 IDENT(index)
2:31 COLON
2:33 LBRACKET
2:34 IDENT(name)
2:38 RBRACKET
2:39 RPAREN
2:40 NEWLINE
3:1 KW_CLASS
3:7 IDENT(Product)
3:15 LBRACE
3:16 NEWLINE
4:3 KW_LET
4:7 IDENT(name)
4:11 COLON
4:13 IDENT(Text)
4:18 EQ
4:20 STR(widget)
4:28 NEWLINE
5:3 KW_LET
5:7 IDENT(price)
5:12 COLON
5:14 IDENT(Int)
5:18 EQ
5:20 INT(42)
5:22 NEWLINE
6:3 KW_LET
6:7 IDENT(tags)
6:11 COLON
6:13 LBRACKET
6:14 IDENT(Text)
6:18 RBRACKET
6:20 EQ
6:22 LBRACKET
6:23 RBRACKET
6:24 NEWLINE
7:3 KW_LET
7:7 IDENT(in_stock)
7:15 COLON
7:17 IDENT(Bool)
7:22 EQ
7:24 KW_TRUE
7:28 NEWLINE
9:3 KW_FN
9:6 IDENT(discounted)
9:16 LPAREN
9:17 IDENT(pct)
9:20 COLON
9:22 IDENT(Int)
9:25 RPAREN
9:27 ARROW
9:30 IDENT(Int)
9:34 LBRACE
9:35 NEWLINE
10:5 KW_LET
10:9 IDENT(cut)
10:13 EQ
10:15 IDENT(self)
10:19 DOT
10:20 IDENT(price)
10:26 STAR
10:28 IDENT(pct)
10:32 SLASH
10:34 INT(100)
10:37 NEWLINE
11:5 KW_IF
11:8 IDENT(cut)
11:12 GTEQ
11:15 IDENT(self)
11:19 DOT
11:20 IDENT(price)
11:26 LBRACE
11:27 NEWLINE
12:7 KW_RETURN
12:14 INT(0)
12:15 NEWLINE
13:5 RBRACE
13:7 KW_ELSE
13:12 LBRACE
13:13 NEWLINE
14:7 KW_RETURN
14:14 IDENT(self)
14:18 DOT
14:19 IDENT(price)
14:25 DASH
14:27 IDENT(cut)
14:30 NEWLINE
15:5 RBRACE
15:6 NEWLINE
16:3 RBRACE
16:4 NEWLINE
18:3 KW_FN
18:6 IDENT(total)
18:11 LPAREN
18:12 IDENT(counts)
18:18 COLON
18:20 LBRACKET
18:21 IDENT(Int)
18:24 RBRACKET
18:25 RPAREN
18:27 ARROW
18:30 IDENT(Int)
18:34 LBRACE
18:35 NEWLINE
19:5 KW_LET
19:9 IDENT(sum)
19:13 EQ
19:15 INT(0)
19:16 NEWLINE
20:5 KW_FOR
20:9 IDENT(n)
20:11 KW_IN
20:14 IDENT(counts)
20:21 LBRACE
20:22 NEWLINE
21:7 IDENT(sum)
21:11 EQ
21:13 IDENT(sum)
21:17 PLUS
21:19 IDENT(n)
21:20 NEWLINE
22:5 RBRACE
22:6 NEWLINE
23:5 KW_RETURN
23:12 IDENT(sum)
23:15 NEWLINE
24:3 RBRACE
24:4 NEWLINE
26:3 KW_FN
26:6 IDENT(clearance)
26:15 LPAREN
26:16 RPAREN
26:18 ARROW
26:21 IDENT(Bool)
26:26 LBRACE
26:27 NEWLINE
27:5 KW_LET
27:9 IDENT(ok)
27:12 EQ
27:14 IDENT(self)
27:18 DOT
27:19 IDENT(price)
27:25 LTEQ
27:28 INT(50)
27:30 NEWLINE
28:5 KW_WHILE
28:11 IDENT(ok)
28:14 LBRACE
28:15 NEWLINE
29:7 KW_RETURN
29:14 KW_FALSE
29:19 NEWLINE
30:5 RBRACE
30:6 NEWLINE
31:5 KW_RETURN
31:12 IDENT(ok)
31:14 NEWLINE
32:3 RBRACE
32:4 NEWLINE
33:1 RBRACE
33:2 NEWLINE
34:1 EOF

33
compiler/test/golden/tokens/representative.wo Normal file
View file

@ -0,0 +1,33 @@
-- representative token fixture: comments, newlines, literals, annotations, punctuation
@table(name: "products", index: [name])
class Product {
let name: Text = "widget"
let price: Int = 42
let tags: [Text] = []
let in_stock: Bool = true
fn discounted(pct: Int) -> Int {
let cut = self.price * pct / 100
if cut >= self.price {
return 0
} else {
return self.price - cut
}
}
fn total(counts: [Int]) -> Int {
let sum = 0
for n in counts {
sum = sum + n
}
return sum
}
fn clearance() -> Bool {
let ok = self.price <= 50
while ok {
return false
}
return ok
}
}

7
compiler/test/golden/tokens/unknown-char.expected Normal file
View file

@ -0,0 +1,7 @@
1:1 KW_LET
1:5 IDENT(x)
1:7 EQ
1:9 INT(1)
1:13 INT(2)
1:14 NEWLINE
2:1 EOF

876
compiler/test/runner.ml Normal file
View file

@ -0,0 +1,876 @@
(* runner.ml — golden-file test runner (Task 3 onward).
Contract (compiler/plan/2026-08-01-woc-compiler-front.md Task 3):
walks compiler/test/golden/<stage>/ directories; for every
<name>.wo file in a stage directory, runs the pipeline stage that
directory's dump flag names and diffs the produced text against
<name>.expected. A mismatch prints a line-based diff; the run exits
nonzero if anything mismatched. WOC_BLESS=1 rewrites <name>.expected
to the freshly produced text instead of comparing — used once, by
hand, to seed or intentionally update a fixture; every commit ships
with the runner GREEN against whatever it last wrote.
Wired into `dune runtest` alongside test_diag.ml (see test/dune).
-- Why this file resolves two different "golden root" paths --
`dune runtest` runs this executable with its current directory set
to the *build* copy of test/ (e.g. ".../compiler/_build/default/test"),
not the real source directory — verified empirically: a file written
via a bare relative path while running under `dune runtest` lands
under _build/default and is silently discarded (or stale-overwritten)
on the next build. Reading fixtures from the plain relative "golden"
path is fine — test/dune declares `(deps (source_tree golden))`,
which both (a) keeps that build-directory copy fresh from the real
source on every run, since dune must digest that dependency to
decide whether to re-run this test's action at all, and (b) is
itself the reason editing a fixture actually invalidates a
previously-cached PASS. But WOC_BLESS=1 rewriting *that* copy would
vanish — the whole point of bless mode is to update the fixture git
tracks. So bless-mode writes instead go through [source_golden_dir],
which walks back out of "_build/default" to the real
compiler/test/golden on disk. *)
module Diag = Woc_lib.Diag
module Token = Woc_lib.Token
module Lexer = Woc_lib.Lexer
module Ast = Woc_lib.Ast
module Parser = Woc_lib.Parser
module Dump = Woc_lib.Dump
let read_file path =
let ic = open_in_bin path in
let n = in_channel_length ic in
let s = really_input_string ic n in
close_in ic;
s
let write_file path contents =
let oc = open_out_bin path in
output_string oc contents;
close_out oc
(* Manual substring search: no Str/Re library (this project is
stdlib-only), and this is the only place a substring search is
needed. Fine for the short, one-shot haystack (a cwd path) this is
used on. *)
let find_substring ~needle haystack =
let hlen = String.length haystack and nlen = String.length needle in
let rec go i =
if i + nlen > hlen then None
else if String.sub haystack i nlen = needle then Some i
else go (i + 1)
in
go 0
(* The real, on-disk compiler/test/golden — see module doc above. Falls
back to a short list of plausible relative paths for a manual
(non-dune) invocation, where cwd is wherever the caller's shell
already is. *)
let source_golden_dir () =
match Sys.getenv_opt "WOC_GOLDEN_DIR" with
| Some dir -> dir
| None -> (
let cwd = Sys.getcwd () in
let marker = "_build/default/" in
match find_substring ~needle:marker cwd with
| Some idx -> String.sub cwd 0 idx ^ "test/golden"
| None -> (
let candidates = [ "golden"; "test/golden"; "compiler/test/golden" ] in
match List.find_opt Sys.file_exists candidates with
| Some dir -> dir
| None ->
failwith
"runner: cannot locate compiler/test/golden (set WOC_GOLDEN_DIR)"))
let bless = Sys.getenv_opt "WOC_BLESS" = Some "1"
let checks = ref 0
let failures = ref 0
let check name cond =
incr checks;
if not cond then begin
incr failures;
Printf.printf "FAIL: %s\n" name
end
let check_eq name ~expected ~actual to_string =
incr checks;
if expected <> actual then begin
incr failures;
Printf.printf "FAIL: %s\n expected: %s\n actual: %s\n" name
(to_string expected) (to_string actual)
end
(* ---- direct lexer assertions (not golden-diffed) -------------------
golden/tokens/gotcha.wo and unknown-char.wo already pin the token
*stream* for these cases, but a token dump alone can't distinguish
"no diagnostic was raised" from "one was raised and silently
dropped" — both look identical in the dump (the bad character is
just absent either way). These assertions pin the diagnostic side
of the WO-E001 contract directly against the Collector. *)
let () =
let collector = Diag.Collector.create () in
let toks =
Lexer.tokenize collector ~file:"gotcha.wo"
"self me subscribe receive insert select"
in
let kinds = List.map (fun (t : Token.t) -> t.kind) toks in
check
"gotcha: self/me/subscribe/receive/insert/select all lex as Ident"
(kinds
= [
Token.Ident "self";
Token.Ident "me";
Token.Ident "subscribe";
Token.Ident "receive";
Token.Ident "insert";
Token.Ident "select";
Token.Eof;
])
let () =
let collector = Diag.Collector.create () in
let toks =
Lexer.tokenize collector ~file:"gotcha.wo" "INSERT SELECT type class"
in
let kinds = List.map (fun (t : Token.t) -> t.kind) toks in
check "gotcha: uppercase INSERT/SELECT and type/class lex as keywords"
(kinds = [ Token.KwInsert; Token.KwSelect; Token.KwType; Token.KwClass; Token.Eof ])
let () =
let collector = Diag.Collector.create () in
let toks = Lexer.tokenize collector ~file:"bad.wo" "let x = 1 ~ 2" in
let kinds = List.map (fun (t : Token.t) -> t.kind) toks in
check "unknown char: skipped, never appears as a token"
(kinds
= [ Token.KwLet; Token.Ident "x"; Token.Eq; Token.Int 1; Token.Int 2; Token.Eof ]);
let diags = Diag.Collector.diagnostics collector in
check_eq "unknown char: exactly one diagnostic reported" ~expected:1
~actual:(List.length diags) string_of_int;
match diags with
| [ d ] ->
check "unknown char: WO-E001 at the '~' position (line 1, col 11)"
(d.code = "WO-E001" && d.site.line = 1 && d.site.col = 11)
| _ -> check "unknown char: diagnostic shape" false
let () =
(* golden/tokens/dangling-escape.wo opens a string and ends the file
on a lone backslash, with no character left to escape it. Read
from disk rather than duplicated as a literal so this assertion
and the golden dump can never silently drift apart from the
actual fixture bytes (the file has no trailing newline on purpose
-- its very last byte must be the backslash). *)
let path = "golden/tokens/dangling-escape.wo" in
let src = read_file path in
let collector = Diag.Collector.create () in
let toks = Lexer.tokenize collector ~file:path src in
let kinds = List.map (fun (t : Token.t) -> t.kind) toks in
check
"dangling escape: string closes with whatever was collected before \
the backslash"
(kinds
= [ Token.KwLet; Token.Ident "bad"; Token.Eq; Token.Str "abc"; Token.Eof ]);
let diags = Diag.Collector.diagnostics collector in
check_eq "dangling escape: exactly one diagnostic reported" ~expected:1
~actual:(List.length diags) string_of_int;
match diags with
| [ d ] ->
check "dangling escape: WO-E002 at the backslash's position (line 1, col 15)"
(d.code = "WO-E002" && d.site.line = 1 && d.site.col = 15)
| _ -> check "dangling escape: diagnostic shape" false
let () =
(* Deliberate asymmetry with the case above (see
unterminated_escape_code's doc comment in lexer.ml): a plain
unterminated string -- no dangling backslash, it simply runs off
the end of the source with no closing quote at all -- is rt-parity
silent. Pinned inline (no fixture file needed for this half) so
nothing starts reporting a diagnostic here without this test
noticing. *)
let collector = Diag.Collector.create () in
let toks =
Lexer.tokenize collector ~file:"plain.wo" "let plain = \"never closed"
in
let kinds = List.map (fun (t : Token.t) -> t.kind) toks in
check
"plain unterminated string: closes with all collected content, no \
diagnostic"
(kinds
= [
Token.KwLet;
Token.Ident "plain";
Token.Eq;
Token.Str "never closed";
Token.Eof;
]);
check_eq "plain unterminated string: reports nothing" ~expected:0
~actual:(List.length (Diag.Collector.diagnostics collector))
string_of_int
let () =
(* Faithful rt port (crates/rt/src/lexer.rs read_ident_chars): an
identifier's continuation characters include '-', so `a-b` lexes
as one Ident, not Ident/Dash/Ident. Pinned here so nothing "fixes"
this away before Task 5 decides how its expression grammar wants
binary minus to interact with it (see lexer.ml's module doc for
the forward-looking concern this raises). golden/tokens/
dash-continuation.wo pins the same two shapes as a dump diff. *)
let collector = Diag.Collector.create () in
let toks = Lexer.tokenize collector ~file:"dash.wo" "a-b" in
let kinds = List.map (fun (t : Token.t) -> t.kind) toks in
check "dash-continuation: a-b (no spaces) lexes as one Ident"
(kinds = [ Token.Ident "a-b"; Token.Eof ])
let () =
let collector = Diag.Collector.create () in
let toks = Lexer.tokenize collector ~file:"dash.wo" "a - b" in
let kinds = List.map (fun (t : Token.t) -> t.kind) toks in
check "dash-continuation: a - b (spaced) lexes as Ident, Dash, Ident"
(kinds = [ Token.Ident "a"; Token.Dash; Token.Ident "b"; Token.Eof ])
(* ---- direct parser/AST assertions (Task 4, not golden-diffed) ------------
golden/ast/*.wo fixtures already pin the AST *shape* via --dump-ast,
but a dump alone can't distinguish "no diagnostic was raised" from
"one was raised and silently dropped" (dump.ml's spec: node ids are
deliberately never printed), and it can't see the AST's `id`/`conv`/
`default` fields directly. These assertions pin the parts of the
Task 4 contract a text dump structurally cannot show. *)
let parse_str ~file src =
let collector = Diag.Collector.create () in
let toks = Lexer.tokenize collector ~file src in
let prog = Parser.parse collector ~file toks in
(prog, collector)
let () =
(* golden/ast/two-error-recovery.wo: `class Broken1` has a malformed
field (`bad_field Text`, missing ':'), `class Good` in between is
well-formed, `interface Broken2` has a malformed signature
(`x Text` instead of `x: Text`). The dump golden already shows only
`Good` survives; this assertion is the load-bearing half: exactly
two diagnostics (not a cascade from either broken declaration),
both WO-E101 syntax errors, each at the actual offending token. *)
let path = "golden/ast/two-error-recovery.wo" in
let src = read_file path in
let prog, collector = parse_str ~file:path src in
check "recovery: exactly one surviving declaration (`Good`)"
(match prog.Ast.decls with
| [ Ast.Class c ] -> c.name = "Good"
| _ -> false);
let diags = Diag.Collector.diagnostics collector in
check_eq "recovery: exactly two diagnostics reported (one per broken decl)"
~expected:2 ~actual:(List.length diags) string_of_int;
match diags with
| [ d1; d2 ] ->
check "recovery: first diagnostic is WO-E101 at `bad_field` (line 3, col 3)"
(d1.code = "WO-E101" && d1.site.line = 3 && d1.site.col = 3);
check "recovery: second diagnostic is WO-E101 at the bad param type (line 11, col 13)"
(d2.code = "WO-E101" && d2.site.line = 11 && d2.site.col = 13)
| _ -> check "recovery: diagnostic shape" false
let () =
(* golden/ast/body-recovery.wo (Task 5): `fn oops` has two malformed
statement bodies (`let bad1 = ;` — missing expression before the
terminator — and `return bad2 +` — missing the `+`'s right-hand
operand), each surrounded by well-formed `let` statements. The
dump golden already shows only `ok1`/`ok2` surviving; this is the
load-bearing half proving that's *recovery* (one diagnostic per
broken statement, syncing at the next newline/semicolon per the
brief) and not a silent drop or a cascade. *)
let path = "golden/ast/body-recovery.wo" in
let src = read_file path in
let prog, collector = parse_str ~file:path src in
check "body-recovery: exactly one surviving fn (`oops`)"
(match prog.Ast.decls with
| [ Ast.Fn m ] -> m.name = "oops"
| _ -> false);
let diags = Diag.Collector.diagnostics collector in
check_eq "body-recovery: exactly two diagnostics reported (one per broken statement)"
~expected:2 ~actual:(List.length diags) string_of_int;
(match prog.Ast.decls with
| [ Ast.Fn m ] ->
check "body-recovery: both `let` statements survive, in order"
(List.map
(fun (s : Ast.stmt) ->
match s.Ast.s_kind with Ast.Let { name; _ } -> name | _ -> "?")
m.body
= [ "ok1"; "ok2" ])
| _ -> check "body-recovery: exactly one surviving fn" false);
match diags with
| [ d1; d2 ] ->
check "body-recovery: first diagnostic is WO-E101 at the missing `let` value (line 3, col 14)"
(d1.code = "WO-E101" && d1.site.line = 3 && d1.site.col = 14);
check "body-recovery: second diagnostic is WO-E101 after the dangling `+` (line 5, col 16)"
(d2.code = "WO-E101" && d2.site.line = 5 && d2.site.col = 16)
| _ -> check "body-recovery: diagnostic shape" false
let () =
(* golden/ast/skip-on-block.wo: a policy/service/on-block-laden class
body. The dump golden shows exactly 3 fields and 0 methods survive
(the load-bearing brace-depth counter finding the object literal's
own close, not the type's); this assertion pins the other half —
zero diagnostics (the skip is a deliberate, silent no-op, not a
recovered error) and re-confirms shape at the AST level directly. *)
let path = "golden/ast/skip-on-block.wo" in
let src = read_file path in
let prog, collector = parse_str ~file:path src in
check_eq "skip-on-block: reports nothing (silent skip, not recovery)"
~expected:0
~actual:(List.length (Diag.Collector.diagnostics collector))
string_of_int;
(match prog.Ast.decls with
| [ Ast.Class c ] ->
check "skip-on-block: field names/order survive policy/service/on"
(List.map (fun (f : Ast.field) -> f.name) c.fields = [ "id"; "title"; "published" ]);
check "skip-on-block: no methods (none were declared)" (c.methods = [])
| _ -> check "skip-on-block: exactly one class declaration" false)
let () =
(* Coordinator-review finding: `on`/`service`/`policy` are plain Idents
(Task 3 deliberately keeps them usable as identifiers), so a FIELD
literally named one of them (`on: Bool`) must not be swallowed by
the skip-on-block interpretation just because its name matches —
only its *shape* (no Colon right after) means "this is a
service/policy/on block". golden/ast/field-named-sync-keyword.wo
puts fields named on/service/policy in the SAME class body as real
`policy ...`, `on ... do ...`, and `service rest ...` blocks, so
this one fixture proves both halves at once: the fields all survive
(this assertion), and the genuine blocks still correctly disappear
(the golden dump for this fixture shows only 5 fields, 0 methods,
nothing leaking from the skipped blocks) — while
golden/ast/skip-on-block.wo above continues to prove the reverse
case (genuine blocks, no fields sharing their names) stays green. *)
let path = "golden/ast/field-named-sync-keyword.wo" in
let src = read_file path in
let prog, collector = parse_str ~file:path src in
check_eq "field-named-sync-keyword: reports nothing" ~expected:0
~actual:(List.length (Diag.Collector.diagnostics collector))
string_of_int;
match prog.Ast.decls with
| [ Ast.Class c ] ->
check
"field-named-sync-keyword: fields named on/service/policy all survive, in order"
(List.map (fun (f : Ast.field) -> f.name) c.fields
= [ "id"; "on"; "service"; "policy"; "name" ]);
check "field-named-sync-keyword: no methods (none were declared)" (c.methods = [])
| _ -> check "field-named-sync-keyword: exactly one class declaration" false
let () =
(* Param conventions (Task 4 brief: bare = borrow, `mut`, `take`) —
pinned directly against Ast.param.conv, not just the dump's text
rendering of it. *)
let prog, _ =
parse_str ~file:"conv.wo" "fn f(a: Int, mut b: Int, take c: Int) -> Int {\n return a;\n}\n"
in
match prog.Ast.decls with
| [ Ast.Fn m ] ->
check "param conventions: bare/mut/take parsed in order"
(List.map (fun (p : Ast.param) -> p.conv) m.params = [ Ast.Borrow; Ast.Mut; Ast.Take ])
| _ -> check "param conventions: exactly one free fn" false
let () =
(* `= now()` is DefaultNow; anything else is DefaultOpaque carrying
the raw token span (Task 4 brief, ported from rt's DefaultExpr::Now
vs ::Opaque). Pinned at the AST level, not just via dump text. *)
let prog, _ =
parse_str ~file:"defaults.wo"
"type T {\n created: Timestamp = now()\n active: Bool = true\n}\n"
in
match prog.Ast.decls with
| [ Ast.Class c ] -> (
match c.fields with
| [ f1; f2 ] ->
check "default now(): recognized as DefaultNow" (f1.default = Some Ast.DefaultNow);
check "default true: opaque token span, not DefaultNow"
(match f2.default with
| Some (Ast.DefaultOpaque [ { Token.kind = Token.KwTrue; _ } ]) -> true
| _ -> false)
| _ -> check "defaults: exactly two fields" false)
| _ -> check "defaults: exactly one type declaration" false
let () =
(* @table's known keys (name/index) round-trip; an unknown key is a
parse error under its own code (WO-E102), distinct from the
generic WO-E101 syntax-error code — mirrors Task 3's WO-E001/002
split (one code per distinct situation, not one catch-all). *)
let prog, collector =
parse_str ~file:"table.wo"
"@table(name: \"prices\", index: [sku, at])\nclass Price {\n id: Id\n}\n"
in
check_eq "@table: no diagnostics on a well-formed configuration" ~expected:0
~actual:(List.length (Diag.Collector.diagnostics collector))
string_of_int;
(match prog.Ast.decls with
| [ Ast.Class c ] ->
check "@table: name and index captured"
(match c.table with
| Some { Ast.table_name = Some "prices"; indexes = [ [ "sku"; "at" ] ] } -> true
| _ -> false)
| _ -> check "@table: exactly one class" false);
let _, bad_collector = parse_str ~file:"bad-table.wo" "@table(shard_key: sku)\ntype T {\n id: Id\n}\n" in
let bad_diags = Diag.Collector.diagnostics bad_collector in
check_eq "@table: unknown key reports exactly one diagnostic" ~expected:1
~actual:(List.length bad_diags) string_of_int;
match bad_diags with
| [ d ] -> check "@table: unknown key is WO-E102, not the generic WO-E101" (d.code = "WO-E102")
| _ -> check "@table: unknown-key diagnostic shape" false
let () =
(* Node ids: unique across a parse and, for every container relative
to its own children, strictly smaller (Task 4 decision: a
container's id is minted once its head is confirmed and before its
body is parsed, uniformly for class/interface/method/fn — see
parser.ml's parse_sig_head comment). Collected by hand here rather
than depending on any future Ast-walking helper, since Task 4
doesn't ship one. *)
let prog, _ = parse_str ~file:"ids.wo" (read_file "golden/ast/pricing-demo.wo") in
let ids = ref [] in
let add id = ids := id :: !ids in
let visit_param (p : Ast.param) = add p.id in
let visit_field (f : Ast.field) = add f.id in
let visit_method (m : Ast.method_decl) =
check
(Printf.sprintf "node ids: method `%s` id < all its param ids" m.name)
(List.for_all (fun (p : Ast.param) -> m.id < p.id) m.params);
add m.id;
List.iter visit_param m.params
in
let visit_sig (s : Ast.method_sig) =
check
(Printf.sprintf "node ids: interface method `%s` id < all its param ids" s.name)
(List.for_all (fun (p : Ast.param) -> s.id < p.id) s.params);
add s.id;
List.iter visit_param s.params
in
List.iter
(fun (d : Ast.decl) ->
match d with
| Ast.Class c ->
check
(Printf.sprintf "node ids: class/type `%s` id < all its field/method ids" c.name)
(List.for_all (fun (f : Ast.field) -> c.id < f.id) c.fields
&& List.for_all (fun (m : Ast.method_decl) -> c.id < m.id) c.methods);
add c.id;
List.iter visit_field c.fields;
List.iter visit_method c.methods
| Ast.Interface i ->
check
(Printf.sprintf "node ids: interface `%s` id < all its method ids" i.name)
(List.for_all (fun (s : Ast.method_sig) -> i.id < s.id) i.methods);
add i.id;
List.iter visit_sig i.methods
| Ast.Fn m -> visit_method m)
prog.Ast.decls;
let sorted = List.sort compare !ids in
let deduped = List.sort_uniq compare !ids in
check "node ids: every id in the tree is unique" (List.length sorted = List.length deduped)
(* ---- statement/expression parser (Task 5, not golden-diffed) ------------
golden/ast/{body-statements,ctor-literal,db-stub,body-recovery}.wo
already pin the dump-text shape; these assertions pin the parts a
text dump structurally cannot show — the precedence ladder's actual
tree shape, and the insert/select asymmetry (statement-only vs.
statement-and-expression), same rationale as Task 4's own direct
assertions above. *)
let () =
(* Precedence ladder (parser.ml's parse_expr chain): comparison is
loosest, then concat, then additive, then multiplicative, then
unary — so `1 + 2 * 3 == 4 .. "x"` must parse as
`Eq(Add(1, Mul(2,3)), Concat(4, "x"))`, not e.g. `Mul` grabbing
`2 * (3 == 4)` or concat binding tighter than `+`. *)
let prog, _ = parse_str ~file:"prec.wo" "fn f() {\n return 1 + 2 * 3 == 4 .. \"x\"\n}\n" in
match prog.Ast.decls with
| [ Ast.Fn m ] -> (
match m.body with
| [ { Ast.s_kind = Ast.Return (Some e); _ } ] -> (
match e.Ast.kind with
| Ast.Binary
( Ast.Eq,
{ Ast.kind = Ast.Binary (Ast.Add, { Ast.kind = Ast.IntLit 1; _ }, add_rhs); _ },
{ Ast.kind = Ast.Binary (Ast.Concat, { Ast.kind = Ast.IntLit 4; _ }, concat_rhs); _ }
) ->
check "precedence: `2 * 3` is the addition's right operand, not split by `==`"
(match add_rhs.Ast.kind with
| Ast.Binary (Ast.Mul, { Ast.kind = Ast.IntLit 2; _ }, { Ast.kind = Ast.IntLit 3; _ }) ->
true
| _ -> false);
check "precedence: concat's right operand is the string literal"
(match concat_rhs.Ast.kind with Ast.StrLit "x" -> true | _ -> false)
| _ -> check "precedence: top-level operator is `==` over an `Add` and a `Concat`" false)
| _ -> check "precedence: exactly one `return` statement" false)
| _ -> check "precedence: exactly one free fn" false
let () =
(* Constructor literal: `ClassName { field: expr, ... }`, recognized
by the identifier-then-brace shape in expression position (Task 5
brief). Pinned directly against Ast.Ctor, not just dump text. *)
let prog, _ = parse_str ~file:"ctor.wo" "fn f() {\n let w = Widget { a: 1, b: 2 }\n}\n" in
match prog.Ast.decls with
| [ Ast.Fn m ] -> (
match m.body with
| [ { Ast.s_kind = Ast.Let { value = { Ast.kind = Ast.Ctor (name, fields); _ }; _ }; _ } ] ->
check "ctor literal: class name captured" (name = "Widget");
check "ctor literal: field names/order captured"
(List.map fst fields = [ "a"; "b" ])
| _ -> check "ctor literal: exactly one `let` binding a Ctor" false)
| _ -> check "ctor literal: exactly one free fn" false
let () =
(* The brief's stated asymmetry: `insert` is a statement-only trigger
(parser.ml's is_insert_trigger, checked only in parse_stmt) — a
bare `insert` reached from parse_primary is just an ordinary
identifier reference, exactly like self/me/on/service/policy's own
"recognized positionally, not a reserved word" rule (this task's
own keyword-discipline note). `select` (is_select_trigger) is
checked unconditionally *inside* parse_primary, so the same
position always builds a DbStub instead. Neither is an error on
its own — the difference shows up in which Ast.expr_kind comes
back. *)
let prog, collector =
parse_str ~file:"insert-vs-select.wo" "fn f() {\n let a = insert\n let b = select\n}\n"
in
check_eq "insert vs. select as bare expressions: no diagnostics" ~expected:0
~actual:(List.length (Diag.Collector.diagnostics collector))
string_of_int;
match prog.Ast.decls with
| [ Ast.Fn m ] -> (
match m.body with
| [
{ Ast.s_kind = Ast.Let { name = "a"; value = a_val; _ }; _ };
{ Ast.s_kind = Ast.Let { name = "b"; value = b_val; _ }; _ };
] ->
check "bare `insert` in expression position is a plain Ident"
(match a_val.Ast.kind with Ast.Ident "insert" -> true | _ -> false);
check "bare `select` in expression position always becomes a DbStub"
(match b_val.Ast.kind with Ast.DbStub _ -> true | _ -> false)
| _ -> check "insert vs. select: exactly two `let` statements" false)
| _ -> check "insert vs. select: exactly one free fn" false
let () =
(* The no_brace guard (parser.ml's state.no_brace / looks_like_ctor):
a bare identifier condition immediately followed by `{` is the
if-statement's own block, never a constructor literal — pinned
directly against the AST shape (Ast.Ident, not Ast.Ctor),
complementing golden/ast/ctor-literal.wo's dump-level coverage. *)
let prog, collector = parse_str ~file:"no-brace.wo" "fn f(active: Bool) {\n if active {\n return\n }\n}\n" in
check_eq "no_brace guard: reports nothing" ~expected:0
~actual:(List.length (Diag.Collector.diagnostics collector))
string_of_int;
match prog.Ast.decls with
| [ Ast.Fn m ] -> (
match m.body with
| [ { Ast.s_kind = Ast.If { cond; _ }; _ } ] ->
check "no_brace guard: if-condition is the bare ident, not a Ctor"
(match cond.Ast.kind with Ast.Ident "active" -> true | _ -> false)
| _ -> check "no_brace guard: exactly one `if` statement" false)
| _ -> check "no_brace guard: exactly one free fn" false
(* ---- fix round 1 regressions (post-review CRITICAL 1/2/3) ---------------
golden/ast/{condition-recovery,db-stub-nested}.wo and the extra
if-conditions added to golden/ast/ctor-literal.wo already pin the
dump-text shape; these assertions pin the parts a dump alone can't
show — diagnostic counts, and (for CRITICAL 1) the concrete AST node
kind that proves state.no_brace was actually restored rather than
merely "looking right" in rendered text. *)
let () =
(* CRITICAL 1: state.no_brace's save/restore was not exception-safe —
a failed if/while/for condition left it stuck at `true`, so every
constructor literal for the rest of the file silently stopped
parsing as one (it fell back to a bare Ident, desyncing the parse
of whatever followed). golden/ast/condition-recovery.wo's `if 1 +
{` fails inside its own condition; the fix (parser.ml's
with_no_brace, using Fun.protect) must restore no_brace before the
Parse_error reaches parse_block's recovery, so the very next
statement's constructor literal still parses as one. *)
let path = "golden/ast/condition-recovery.wo" in
let src = read_file path in
let prog, collector = parse_str ~file:path src in
let diags = Diag.Collector.diagnostics collector in
check_eq "condition-recovery: exactly one diagnostic (the broken condition, not a cascade)"
~expected:1 ~actual:(List.length diags) string_of_int;
(match diags with
| [ d ] -> check "condition-recovery: WO-E101" (d.code = "WO-E101")
| _ -> check "condition-recovery: diagnostic shape" false);
match prog.Ast.decls with
| [ Ast.Fn m ] -> (
match m.body with
| [ { Ast.s_kind = Ast.Let { name = "w"; value; _ }; _ } ] ->
check "condition-recovery: no_brace was restored — `Widget {...}` after the \
broken condition is still a real Ctor, not a bare Ident"
(match value.Ast.kind with Ast.Ctor ("Widget", [ ("a", _) ]) -> true | _ -> false)
| _ -> check "condition-recovery: exactly one surviving `let w = ...`" false)
| _ -> check "condition-recovery: exactly one surviving fn" false
let () =
(* CRITICAL 2: collect_dbstub_tokens only had a depth-0 stop guard on
RBrace, so a `select`/`insert` nested inside an enclosing call or
index expression had no way to stop at that call/index's own `)`/
`]` — it swallowed everything to Eof. golden/ast/db-stub-nested.wo
nests `select` inside both a call argument and an index
expression, followed by an unrelated `let done_marker = 1`; if the
scan ran away, done_marker would never be parsed (or the file
would end on a misleading "expected ')'/'], got EOF" diagnostic
instead of the three clean statements below). *)
let path = "golden/ast/db-stub-nested.wo" in
let src = read_file path in
let prog, collector = parse_str ~file:path src in
check_eq "db-stub-nested: reports nothing (both selects terminate at their own delimiter)"
~expected:0
~actual:(List.length (Diag.Collector.diagnostics collector))
string_of_int;
match prog.Ast.decls with
| [ Ast.Fn m ] -> (
match m.body with
| [
{ Ast.s_kind = Ast.Let { name = "wrapped"; value = wrapped_val; _ }; _ };
{ Ast.s_kind = Ast.Let { name = "arr"; value = arr_val; _ }; _ };
{ Ast.s_kind = Ast.Let { name = "done_marker"; value = done_val; _ }; _ };
] ->
check "db-stub-nested: `select` inside a call argument is a DbStub, and the \
call's own `)` still closed the call"
(match wrapped_val.Ast.kind with
| Ast.Call ({ Ast.kind = Ast.Ident "wrap"; _ }, [ { Ast.kind = Ast.DbStub _; _ } ]) ->
true
| _ -> false);
check "db-stub-nested: `select` inside an index expression is a DbStub, and the \
index's own `]` still closed it"
(match arr_val.Ast.kind with
| Ast.Index ({ Ast.kind = Ast.Ident "data"; _ }, { Ast.kind = Ast.DbStub _; _ }) -> true
| _ -> false);
check "db-stub-nested: parsing continued past both closing delimiters — \
`done_marker` is a normal IntLit, not swallowed or corrupted"
(match done_val.Ast.kind with Ast.IntLit 1 -> true | _ -> false)
| _ -> check "db-stub-nested: exactly three surviving `let` statements" false)
| _ -> check "db-stub-nested: exactly one surviving fn" false
let () =
(* CRITICAL 3: no_brace was only ever reset to `false` in
parse_primary's own LParen branch — never in parse_call_args or
parse_postfix's LBracket branch — so a constructor literal used as
a call argument or index expression *inside* an if/while/for
condition was never recognized as one (it hit looks_like_ctor's
`not st.no_brace` guard, which was still `true`), corrupting the
rest of the condition's parse. golden/ast/ctor-literal.wo already
pins the dump-text shape for both; these assertions pin the
concrete Ctor nodes directly. *)
let prog, collector =
parse_str ~file:"ctor-in-call-and-index.wo"
"fn f(mut active: Bool) {\n\
\ if make(Widget { x: 1 }) {\n\
\ return\n\
\ }\n\
\ if items[Widget { x: 1 }] {\n\
\ return\n\
\ }\n\
}\n"
in
check_eq "ctor in call/index inside a condition: reports nothing" ~expected:0
~actual:(List.length (Diag.Collector.diagnostics collector))
string_of_int;
match prog.Ast.decls with
| [ Ast.Fn m ] -> (
match m.body with
| [ { Ast.s_kind = Ast.If { cond = call_cond; _ }; _ }; { Ast.s_kind = Ast.If { cond = idx_cond; _ }; _ } ]
->
check "ctor as a call argument inside a condition is a real Ctor node"
(match call_cond.Ast.kind with
| Ast.Call (_, [ { Ast.kind = Ast.Ctor ("Widget", _); _ } ]) -> true
| _ -> false);
check "ctor as an index expression inside a condition is a real Ctor node"
(match idx_cond.Ast.kind with
| Ast.Index (_, { Ast.kind = Ast.Ctor ("Widget", _); _ }) -> true
| _ -> false)
| _ -> check "ctor in call/index inside a condition: exactly two `if` statements" false)
| _ -> check "ctor in call/index inside a condition: exactly one free fn" false
(* ---- CLI smoke -------------------------------------------------------
Everything above calls Lexer.tokenize/Dump.dump_tokens in-process --
real coverage of the lexer, zero coverage of bin/main.ml's own
plumbing (argv parsing, which stream a diagnostic lands on, the
0/1/2 exit contract). This section runs the actual built woc binary
as a subprocess. Sys.command (stdlib) shells out via /bin/sh; it
only returns an exit code, so stdout/stderr are captured via
redirection to temp files rather than a pipe API -- deliberately
avoids pulling in the unix library for this one need. *)
let woc_binary () =
match Sys.getenv_opt "WOC_BIN" with
| Some path -> path
| None -> (
(* Under `dune runtest`, cwd is ".../_build/default/test" and the
built binary sits at the sibling ".../_build/default/bin/woc" --
test/dune depends on ../bin/woc precisely so that's guaranteed
built before this test runs, making "../bin/woc" (relative to
cwd) the right path. Manual invocation falls back through a
couple of other plausible locations. *)
let candidates = [ "../bin/woc"; "_build/default/bin/woc"; "bin/woc" ] in
match List.find_opt Sys.file_exists candidates with
| Some path -> path
| None ->
failwith "runner: cannot locate the built woc binary (set WOC_BIN)")
(* Runs the woc binary with [args]; returns (exit_code, stdout, stderr). *)
let run_cli (args : string list) : int * string * string =
let bin = woc_binary () in
let out_file = Filename.temp_file "woc_stdout" ".txt" in
let err_file = Filename.temp_file "woc_stderr" ".txt" in
let cmd =
String.concat " " (List.map Filename.quote (bin :: args))
^ " >" ^ Filename.quote out_file ^ " 2>" ^ Filename.quote err_file
in
let exit_code = Sys.command cmd in
let stdout = read_file out_file in
let stderr = read_file err_file in
(try Sys.remove out_file with Sys_error _ -> ());
(try Sys.remove err_file with Sys_error _ -> ());
(exit_code, stdout, stderr)
let () =
let path = "golden/tokens/gotcha.wo" in
let exit_code, stdout, stderr = run_cli [ "--dump-tokens"; path ] in
check "cli smoke: --dump-tokens on a clean file exits 0" (exit_code = 0);
check "cli smoke: clean-file run writes nothing to stderr" (stderr = "");
let collector = Diag.Collector.create () in
let toks = Lexer.tokenize collector ~file:path (read_file path) in
check "cli smoke: stdout matches the in-process token dump exactly"
(stdout = Dump.dump_tokens toks)
let () =
let path = "golden/tokens/unknown-char.wo" in
let exit_code, stdout, stderr = run_cli [ "--dump-tokens"; path ] in
check "cli smoke: a diagnostic-producing file exits 1, not 0" (exit_code = 1);
check "cli smoke: the WO-E001 diagnostic goes to stderr" (stderr <> "");
let collector = Diag.Collector.create () in
let toks = Lexer.tokenize collector ~file:path (read_file path) in
check "cli smoke: stdout still carries the full token dump on exit 1"
(stdout = Dump.dump_tokens toks)
let () =
let exit_code, _stdout, stderr = run_cli [ "does-not-exist.wo" ] in
check "cli smoke: missing file (bare-path form) exits 2" (exit_code = 2);
check "cli smoke: missing-file message goes to stderr" (stderr <> "")
let () =
let path = "golden/ast/pricing-demo.wo" in
let exit_code, stdout, stderr = run_cli [ "--dump-ast"; path ] in
check "cli smoke: --dump-ast on a clean file exits 0" (exit_code = 0);
check "cli smoke: clean-file --dump-ast writes nothing to stderr" (stderr = "");
let prog, _ = parse_str ~file:path (read_file path) in
check "cli smoke: --dump-ast stdout matches the in-process AST dump exactly"
(stdout = Dump.dump_ast prog)
let () =
let path = "golden/ast/two-error-recovery.wo" in
let exit_code, stdout, stderr = run_cli [ "--dump-ast"; path ] in
check "cli smoke: a decl-recovery file exits 1, not 0" (exit_code = 1);
check "cli smoke: recovered parse diagnostics go to stderr" (stderr <> "");
let prog, _ = parse_str ~file:path (read_file path) in
check "cli smoke: --dump-ast stdout still carries the surviving decls on exit 1"
(stdout = Dump.dump_ast prog)
(* ---- golden-directory walk ------------------------------------------ *)
(* Each stage directory under golden/ names one `woc --dump-*` flag.
"tokens" (Task 3) and "ast" (Task 4) exist today; later tasks add
"types", "owner" alongside their own dump function in dump.ml. *)
let run_stage ~stage ~file ~src : string =
match stage with
| "tokens" ->
let collector = Diag.Collector.create () in
let toks = Lexer.tokenize collector ~file src in
Dump.dump_tokens toks
| "ast" ->
let collector = Diag.Collector.create () in
let toks = Lexer.tokenize collector ~file src in
let prog = Parser.parse collector ~file toks in
Dump.dump_ast prog
| other ->
failwith (Printf.sprintf "runner: unknown golden stage directory %S" other)
(* Line-based diff, unified-diff-flavored (common leading lines shown
as context, then removed/added) but not a full LCS — goldens are
sized for a human to read at a glance, not for minimal-diff output. *)
let print_diff ~expected ~actual =
let exp_lines = Array.of_list (String.split_on_char '\n' expected) in
let act_lines = Array.of_list (String.split_on_char '\n' actual) in
let n = min (Array.length exp_lines) (Array.length act_lines) in
let rec prefix_len i =
if i < n && exp_lines.(i) = act_lines.(i) then prefix_len (i + 1) else i
in
let start = prefix_len 0 in
Printf.printf " --- expected\n +++ actual\n";
for i = 0 to start - 1 do
Printf.printf " %s\n" exp_lines.(i)
done;
for i = start to Array.length exp_lines - 1 do
Printf.printf " - %s\n" exp_lines.(i)
done;
for i = start to Array.length act_lines - 1 do
Printf.printf " + %s\n" act_lines.(i)
done
let is_visible name = String.length name > 0 && name.[0] <> '.'
let run_golden_dir () =
let root = "golden" in
if not (Sys.file_exists root && Sys.is_directory root) then
failwith (Printf.sprintf "runner: golden directory not found at %S" root)
else begin
let src_root = if bless then Some (source_golden_dir ()) else None in
let stages =
Sys.readdir root |> Array.to_list |> List.filter is_visible
|> List.filter (fun name -> Sys.is_directory (Filename.concat root name))
|> List.sort compare
in
List.iter
(fun stage ->
let dir = Filename.concat root stage in
let entries = Sys.readdir dir |> Array.to_list |> List.sort compare in
let wo_files = List.filter (fun n -> Filename.check_suffix n ".wo") entries in
List.iter
(fun wo_name ->
incr checks;
let name = Filename.chop_suffix wo_name ".wo" in
let wo_path = Filename.concat dir wo_name in
let expected_path = Filename.concat dir (name ^ ".expected") in
let src = read_file wo_path in
let file_label = stage ^ "/" ^ wo_name in
let actual = run_stage ~stage ~file:file_label ~src in
if bless then begin
let src_expected_path =
Filename.concat
(Filename.concat (Option.get src_root) stage)
(name ^ ".expected")
in
write_file src_expected_path actual;
Printf.printf "BLESSED: %s\n" src_expected_path
end
else begin
let expected =
if Sys.file_exists expected_path then read_file expected_path
else ""
in
if expected <> actual then begin
incr failures;
Printf.printf "FAIL: %s\n" (Filename.concat stage wo_name);
print_diff ~expected ~actual
end
end)
wo_files)
stages
end
let () = run_golden_dir ()
let () =
Printf.printf "runner: %d checks, %d failures\n" !checks !failures;
if !failures > 0 then exit 1 else exit 0

212
compiler/test/test_diag.ml Normal file
View file

@ -0,0 +1,212 @@
(* test_diag.ml — minimal unit-test seam for compiler/src/diag.ml.
This is NOT the golden-file runner (Task 3 adds that as
compiler/test/runner.ml, alongside this file). Plain assertions,
printed failures, nonzero exit on any failure — just enough to
drive diag.ml with TDD before the golden framework exists. *)
let checks = ref 0
let failures = ref 0
let check name cond =
incr checks;
if not cond then begin
incr failures;
Printf.printf "FAIL: %s\n" name
end
let check_eq name ~expected ~actual to_string =
incr checks;
if expected <> actual then begin
incr failures;
Printf.printf "FAIL: %s\n expected: %s\n actual: %s\n" name
(to_string expected) (to_string actual)
end
module D = Woc_lib.Diag
(* ---- fixture source text ------------------------------------------ *)
let pricing_wo =
String.concat "\n"
[ "type Widget {"
; " field name: Text"
; "}"
; ""
; "fn use_widget() {"
; " let p = Widget { name: \"a\" }"
; " -- noop"
; " -- noop"
; " -- noop"
; " let q = p"
; " -- noop"
; " -- noop"
; " -- noop"
; " take p"
]
let lookup file = if file = "pricing.wo" then Some pricing_wo else None
(* ---- rendering shape: code, position, caret excerpt, related site - *)
let () =
let related =
[ D.related_site ~file:"pricing.wo" ~line:6 ~col:7 ~label:"moved here" ]
in
let d =
D.error ~code:"WO-E301" ~file:"pricing.wo" ~line:14 ~col:8
~message:"value 'p' used after move" ~related ()
in
let rendered = D.render lookup d in
let lines = String.split_on_char '\n' rendered in
let expected =
[ "pricing.wo:14:8: error WO-E301: value 'p' used after move"
; " take p"
; String.make 7 ' ' ^ "^"
; " pricing.wo:6:7: moved here"
; " let p = Widget { name: \"a\" }"
; " " ^ String.make 6 ' ' ^ "^"
]
in
check_eq "render: full diagnostic shape (header/excerpt/caret + related)"
~expected ~actual:lines (String.concat "\n")
let () =
(* Warning severity, no related sites: header word changes, no
trailing related blocks appended. *)
let d =
D.warning ~code:"WO-E999" ~file:"pricing.wo" ~line:1 ~col:1
~message:"placeholder" ()
in
let rendered = D.render lookup d in
check "render: warning word + no related blocks"
(rendered = "pricing.wo:1:1: warning WO-E999: placeholder\ntype Widget {\n^")
let () =
(* Source unavailable: falls back to the header line only, no crash. *)
let d =
D.error ~code:"WO-E001" ~file:"missing.wo" ~line:3 ~col:2
~message:"no source available" ()
in
let rendered = D.render lookup d in
check "render: missing source falls back to header-only line"
(rendered = "missing.wo:3:2: error WO-E001: no source available")
let () =
(* Tabs count as one column: a leading tab is not expanded, so the
caret offset is exactly (col - 1) characters regardless of what
the preceding characters are. *)
let tabby_lookup file = if file = "t.wo" then Some "\tlet p = 1" else None in
let d = D.error ~code:"WO-E001" ~file:"t.wo" ~line:1 ~col:6 ~message:"x" () in
let rendered = D.render tabby_lookup d in
match String.split_on_char '\n' rendered with
| [ _header; _source; caret ] ->
check "render: tab counts as one column" (caret = String.make 5 ' ' ^ "^")
| _ -> check "render: tab counts as one column (unexpected shape)" false
let () =
(* A defensive edge case, not a real compiler output: line 0 (or
negative) is out of the 1-based contract. Rendering must fall
back to a header-only line, matching the missing-file case,
rather than raising (List.nth_opt raises Invalid_argument on a
negative index if this guard is ever removed). *)
let d =
D.error ~code:"WO-E001" ~file:"pricing.wo" ~line:0 ~col:1
~message:"out-of-range line stays non-fatal" ()
in
let rendered = D.render lookup d in
check "render: line < 1 falls back to header-only, does not raise"
(rendered = "pricing.wo:0:1: error WO-E001: out-of-range line stays non-fatal")
(* ---- collector: source-order accumulation, sort, dedup ------------ *)
let () =
let c = D.Collector.create () in
D.Collector.add c
(D.error ~code:"WO-E100" ~file:"b.wo" ~line:5 ~col:1 ~message:"m1" ());
D.Collector.add c
(D.error ~code:"WO-E100" ~file:"a.wo" ~line:10 ~col:2 ~message:"m2" ());
D.Collector.add c
(D.error ~code:"WO-E100" ~file:"a.wo" ~line:1 ~col:1 ~message:"m3" ());
let sites =
List.map
(fun (d : D.t) -> (d.site.file, d.site.line, d.site.col))
(D.Collector.diagnostics c)
in
check_eq "collector: output sorted by (file, line, col)"
~expected:[ ("a.wo", 1, 1); ("a.wo", 10, 2); ("b.wo", 5, 1) ]
~actual:sites (fun l ->
String.concat ", "
(List.map (fun (f, ln, cl) -> Printf.sprintf "%s:%d:%d" f ln cl) l))
let () =
let c = D.Collector.create () in
D.Collector.add c
(D.error ~code:"WO-E100" ~file:"a.wo" ~line:1 ~col:1 ~message:"first" ());
D.Collector.add c
(D.error ~code:"WO-E100" ~file:"a.wo" ~line:1 ~col:1 ~message:"duplicate" ());
D.Collector.add c
(D.error ~code:"WO-E200" ~file:"a.wo" ~line:1 ~col:1
~message:"different code, same site" ());
let ds = D.Collector.diagnostics c in
check_eq "collector: dedups identical (code, file, line, col)"
~expected:2 ~actual:(List.length ds) string_of_int;
(match ds with
| [ first; _second ] ->
check "collector: dedup keeps first-added occurrence"
(first.message = "first")
| _ -> check "collector: dedup result shape" false)
(* ---- exit-code decision -------------------------------------------- *)
let () =
let c = D.Collector.create () in
check_eq "exit code: empty collector is clean" ~expected:0
~actual:(D.Collector.exit_code c) string_of_int
let () =
let c = D.Collector.create () in
D.Collector.add c
(D.warning ~code:"WO-E900" ~file:"a.wo" ~line:1 ~col:1 ~message:"w" ());
check_eq "exit code: warnings only stays clean" ~expected:0
~actual:(D.Collector.exit_code c) string_of_int
let () =
let c = D.Collector.create () in
D.Collector.add c
(D.warning ~code:"WO-E900" ~file:"a.wo" ~line:1 ~col:1 ~message:"w" ());
D.Collector.add c
(D.error ~code:"WO-E301" ~file:"a.wo" ~line:2 ~col:1 ~message:"e" ());
check_eq "exit code: any error reported yields 1" ~expected:1
~actual:(D.Collector.exit_code c) string_of_int
let () =
(* Regression: exit_code must agree with the deduped, displayed
view, not the raw pre-dedup accumulation. A Warning added first
and an Error added second at the exact same (code, file, line,
col) dedup down to just the warning (first occurrence wins) — so
the report shows zero errors, and exit_code must be 0 to match,
not 1 from a dropped duplicate's severity. *)
let c = D.Collector.create () in
D.Collector.add c
(D.warning ~code:"WO-E301" ~file:"a.wo" ~line:1 ~col:1
~message:"warning first" ());
D.Collector.add c
(D.error ~code:"WO-E301" ~file:"a.wo" ~line:1 ~col:1
~message:"error second, same code+site" ());
let ds = D.Collector.diagnostics c in
check_eq "exit code: dedup survivor decides exit code, not raw items"
~expected:1 ~actual:(List.length ds) string_of_int;
(match ds with
| [ only ] ->
check "exit code: dedup keeps the first-added warning"
(only.severity = D.Warning && only.message = "warning first")
| _ -> check "exit code: dedup survivor shape" false);
check_eq "exit code: agrees with the deduped (warning-only) view"
~expected:0 ~actual:(D.Collector.exit_code c) string_of_int
(* ---- summary --------------------------------------------------------*)
let () =
Printf.printf "test_diag: %d checks, %d failures\n" !checks !failures;
if !failures > 0 then exit 1 else exit 0