flan/test/test_flan.ml

(* Reader tests. Plain assertions, no test framework — another dependency that
   would have to be reimplemented if the compiler is ever self-hosted. *)

open Flan

let failures = ref 0

let check name cond =
  if not cond then begin
    incr failures;
    Printf.printf "FAIL  %s\n" name
  end

let reads name src expected =
  match Reader.read_all ~file:"<test>" src with
  | forms ->
    let got = String.concat " " (List.map Form.to_string forms) in
    if got <> expected then begin
      incr failures;
      Printf.printf "FAIL  %s\n        src: %s\n        got: %s\n    wanted: %s\n"
        name src got expected
    end
  | exception Loc.Error (loc, msg) ->
    incr failures;
    Printf.printf "FAIL  %s\n        src: %s\n      error: %s: %s\n"
      name src (Loc.to_string loc) msg

let rejects name src =
  match Reader.read_all ~file:"<test>" src with
  | _ -> incr failures; Printf.printf "FAIL  %s: expected a read error\n" name
  | exception Loc.Error _ -> ()

let () =
  (* ── Atoms ─────────────────────────────────────────────────────── *)
  reads "integer"        "42" "42";
  reads "negative"       "-1" "-1";
  reads "float"          "0.05" "0.05";
  reads "hex"            "0xE6B800FF" "3870818559";
  reads "string"         "\"SAND\"" "\"SAND\"";
  reads "symbol"         "empty-at?" "empty-at?";
  reads "qualified"      "rl/draw-fps" "rl/draw-fps";
  reads "field access"   ".pos" ".pos";
  reads "operator"       "->>" "->>";
  reads "bare minus"     "-" "-";
  reads "keyword"        ":space" ":space";
  reads "else keyword"   ":else" ":else";

  (* Byte literals, as used by calc-me's tokenizer. *)
  reads "byte named"     "\\space" "\\space";
  reads "byte digit"     "\\0" "\\0";
  reads "byte paren"     "\\(" "\\(";
  reads "byte dot"       "\\." "\\.";

  (* ── Sequences ─────────────────────────────────────────────────── *)
  reads "list"           "(+ 1 2)" "(+ 1 2)";
  reads "vector"         "[1 2 3]" "[1 2 3]";
  reads "map literal"    "{:src src :pos 0}" "{:src src :pos 0}";
  reads "type notation"  "[4 f32]" "[4 f32]";
  reads "nested type"    "[rows [cols u32]]" "[rows [cols u32]]";
  reads "commas as space" "[1, 2, 3]" "[1 2 3]";
  reads "nested"         "(a (b [c {:d e}]))" "(a (b [c {:d e}]))";

  (* ── Trivia ────────────────────────────────────────────────────── *)
  reads "line comment"   "; nope\n42" "42";
  reads "trailing comment" "42 ; nope" "42";
  reads "banner comment" ";;;; header\n(f)" "(f)";
  reads "multiple forms" "(a) (b)" "(a) (b)";
  reads "empty source"   "" "";
  reads "only comments"  "; nothing here" "";

  (* ── Quote ─────────────────────────────────────────────────────── *)
  (* Restart names are quoted symbols. Before this existed, 'skip-form read as
     a symbol *named* "'skip-form", which is silently a different symbol from
     skip-form and nothing would ever have reported it. *)
  reads "quote symbol" "'skip-form" "(quote skip-form)";
  reads "quote in call" "(invoke-restart 'use-placeholder)"
                        "(invoke-restart (quote use-placeholder))";
  reads "quote list"    "'(a b)" "(quote (a b))";

  (* The whole class: no reader-significant character may end up inside a name. *)
  let rec bad_names f =
    let open Form in
    match f.v with
    | Sym s | Kw s ->
      if String.exists (fun c -> c = '\'' || c = '^') s then [ s ] else []
    | List l | Vec l | Map l -> List.concat_map bad_names l
    | _ -> []
  in
  let corpus = "(invoke-restart 'skip-form) (a 'b [c 'd] {:e 'f}) '(g 'h)" in
  check "no sigils leak into names"
    (bad_names (Form.make (Form.List (Reader.read_all ~file:"<test>" corpus))
                  Loc.unknown) = []);

  (* ── Errors ────────────────────────────────────────────────────── *)
  rejects "unclosed list"     "(f x";
  rejects "unbalanced close"  ")";
  rejects "mismatched"        "(f x]";
  rejects "unterminated str"  "\"abc";
  rejects "empty keyword"     ":";
  rejects "unknown char"      "\\bogus";
  rejects "metadata"          "^:async";
  rejects "dangling quote"    "'";

  (* ── Locations ─────────────────────────────────────────────────── *)
  (match Reader.read_all ~file:"f.flan" "(a)\n  (b)" with
   | [ a; b ] ->
     check "loc line 1" (a.loc.line = 1 && a.loc.col = 1);
     check "loc line 2" (b.loc.line = 2 && b.loc.col = 3);
     check "loc file"   (a.loc.file = "f.flan")
   | _ -> check "loc: two forms" false);

  (match Reader.read_all ~file:"f.flan" "(f\n  bad" with
   | _ -> check "unclosed reports opening loc" false
   | exception Loc.Error (loc, _) ->
     check "unclosed reports opening loc" (loc.line = 1 && loc.col = 1));

  if !failures = 0 then print_endline "reader: all tests passed"
  else begin
    Printf.printf "\n%d failure(s)\n" !failures;
    exit 1
  end

(* ═══ Parse: forms → AST ═══════════════════════════════════════════ *)

let parse1 src =
  match Reader.read_all ~file:"<test>" src with
  | [ f ] -> Parse.expr f
  | _ -> failwith "test source must be exactly one form"

let parse_decl src =
  match Reader.read_all ~file:"<test>" src with
  | [ f ] -> Parse.decl f
  | _ -> failwith "test source must be exactly one form"

let parse_rejects name src =
  match Reader.read_all ~file:"<test>" src |> Parse.program with
  | _ -> incr failures; Printf.printf "FAIL  %s: expected a parse error\n" name
  | exception Loc.Error _ -> ()

let () =
  let open Ast in

  (* ── Sugar is desugared, not preserved ─────────────────────────── *)
  (match (parse1 "(when c a b)").e with
   | If (_, { e = Do [ _; _ ]; _ }, None) -> ()
   | _ -> check "when -> if+do" false);

  (match (parse1 "(unless c a)").e with
   | If ({ e = Call ({ e = Var "not"; _ }, [ _ ]); _ }, _, None) -> ()
   | _ -> check "unless -> if(not)" false);

  (match (parse1 "(until c a)").e with
   | While ({ e = Call ({ e = Var "not"; _ }, [ _ ]); _ }, [ _ ]) -> ()
   | _ -> check "until -> while(not)" false);

  (match (parse1 "(cond a 1 b 2 :else 3)").e with
   | If (_, _, Some { e = If (_, _, Some { e = Int 3L; _ }); _ }) -> ()
   | _ -> check "cond -> nested if with :else last" false);

  (* and/or short-circuit, so they must not become calls *)
  (match (parse1 "(and a b)").e with
   | If (_, _, Some { e = Var "false"; _ }) -> ()
   | _ -> check "and short-circuits" false);
  (match (parse1 "(or a b)").e with
   | If (_, { e = Var "true"; _ }, Some _) -> ()
   | _ -> check "or short-circuits" false);

  (* ── Forms that bind or alter control are never calls ──────────── *)
  (* This is the class that silently misparses: it reads fine as a call and
     means something entirely different. *)
  (match (parse1 "(dotimes [i 10] (f i))").e with
   | Dotimes ("i", { e = Int 10L; _ }, [ _ ]) -> ()
   | _ -> check "dotimes binds" false);
  (match (parse1 "(fn [x y] x)").e with
   | Fn ([ "x"; "y" ], [ _ ]) -> ()
   | _ -> check "fn binds" false);
  (match (parse1 "(defer (close f))").e with
   | Defer [ _ ] -> ()
   | _ -> check "defer is not a call" false);
  (match (parse1 "(some (find x))").e with
   | Unwrap (Usome, _) -> ()
   | _ -> check "some is not a call" false);
  (match (parse1 "(try (read x))").e with
   | Unwrap (Utry, _) -> ()
   | _ -> check "try is not a call" false);

  (* ── Places: the fixed assignable list, not setf ───────────────── *)
  (match (parse1 "(set x 1)").e with
   | Set (Pvar "x", _) -> () | _ -> check "set local" false);
  (match (parse1 "(set (.hp e) 1)").e with
   | Set (Pfield (_, "hp"), _) -> () | _ -> check "set field" false);
  (match (parse1 "(set (at g r c) 1)").e with
   | Set (Pindex (_, [ _; _ ]), _) -> () | _ -> check "set index" false);
  (match (parse1 "(set (deref p) 1)").e with
   | Set (Pderef _, _) -> () | _ -> check "set deref" false);
  parse_rejects "set on a call" "(set (foo x) 1)";

  (* ── Field access and struct literals ──────────────────────────── *)
  (match (parse1 "(.pos c)").e with
   | Field ({ e = Var "c"; _ }, "pos") -> ()
   | _ -> check "field access" false);
  (match (parse1 "(Cursor {:src s :pos 0})").e with
   | Struct ("Cursor", [ ("src", _); ("pos", _) ]) -> ()
   | _ -> check "struct literal" false);
  (match (parse1 "[1 2 3]").e with
   | Arr [ _; _; _ ] -> () | _ -> check "array literal" false);

  (* ── Types: brackets mean different things by position ─────────── *)
  let ty src =
    match parse_decl (Printf.sprintf "(defn f [x %s])" src) with
    | { d = Defn { params = [ { fty; _ } ]; _ }; _ } -> fty.t
    | _ -> failwith "bad type test"
  in
  (match ty "[u8]" with Tslice _ -> () | _ -> check "[T] is a slice" false);
  (match ty "[4 f32]" with
   | Tarray (Lint 4L, _) -> () | _ -> check "[n T] is an array" false);
  (match ty "[rows [cols u32]]" with
   | Tarray (Lname "rows", { t = Tarray (Lname "cols", _); _ }) -> ()
   | _ -> check "nested array with named lengths" false);
  (match ty "(Ptr Cursor)" with
   | Tapp ("Ptr", [ _ ]) -> () | _ -> check "(Ptr T)" false);
  (match ty "{string i32}" with
   | Tmap (_, _) -> () | _ -> check "{K V} is a map type" false);
  (match ty "(Fn [a a] bool)" with
   | Tfn ([ _; _ ], _) -> () | _ -> check "(Fn [T] R)" false);

  (* ── Declarations ──────────────────────────────────────────────── *)
  (match (parse_decl "(defn f [x i32] bool x)").d with
   | Defn { ret = Some _; params = [ _ ]; fbody = [ _ ]; _ } -> ()
   | _ -> check "defn with return type" false);
  (* An omitted return type means Unit — the body must not be eaten as a type *)
  (match (parse_decl "(defn f [x i32] (g x))").d with
   | Defn { ret = None; fbody = [ _ ]; _ } -> ()
   | _ -> check "defn without return type" false);
  (match (parse_decl "(defvar grid [4 u32])").d with
   | Defvar ("grid", Some _, Zeroed) -> ()
   | _ -> check "defvar is ZII" false);
  (match (parse_decl "(defvar buf [4 u8] uninit)").d with
   | Defvar (_, _, Uninit) -> () | _ -> check "defvar uninit opts out" false);
  (match (parse_decl "(import rl \"vendor:raylib\")").d with
   | Import ("rl", "vendor:raylib") -> () | _ -> check "import" false);

  (* ── Unimplemented forms are rejected, not silently called ─────── *)
  parse_rejects "handler-bind" "(handler-bind [E h] body)";
  parse_rejects "restart-case" "(restart-case body (r [] 1))";
  parse_rejects "loop/recur"   "(loop [x 1] (recur x))";
  parse_rejects "defmacro"     "(defmacro m [] 1)";

  (* ── Malformed syntax is caught with a location ────────────────── *)
  parse_rejects "odd let bindings"  "(let [a])";
  parse_rejects "odd field pairs"   "(defstruct S [a])";
  parse_rejects "cond without body" "(cond a)";
  parse_rejects "unknown top form"  "(nope x)";

  (* ── The corpus parses ─────────────────────────────────────────── *)
  List.iter
    (fun path ->
       match Reader.read_file path |> Parse.program with
       | _ -> ()
       | exception Loc.Error (loc, msg) ->
         incr failures;
         Printf.printf "FAIL  %s does not parse: %s: %s\n"
           path (Loc.to_string loc) msg)
    (* dune runs tests in _build/default/test/; the corpus is declared as a
       dep in test/dune and lands at the build root. *)
    [ "../calc-me.flan"; "../sand.flan" ];

  if !failures = 0 then print_endline "parse: all tests passed"
  else begin
    Printf.printf "\n%d failure(s)\n" !failures;
    exit 1
  end

(* ═══ The return type / body ambiguity ═════════════════════════════ *)
(* (Option f64) and (Some 1) are the same s-expression shape. Which one is a
   return type is decided by the set of names that are actually types, not by
   capitalisation — otherwise a body starting with a constructor call gets
   silently eaten as a return type. *)

let program src = Reader.read_all ~file:"<test>" src |> Parse.program

let () =
  let open Ast in
  (* Pick the defn out; some sources also declare a struct. *)
  let ret_and_body name src =
    match
      List.find_map
        (fun (d : decl) ->
           match d.d with Defn fn -> Some fn | _ -> None)
        (program src)
    with
    | Some { ret; fbody; _ } -> (ret <> None, List.length fbody)
    | None -> check (name ^ ": has a defn") false; (false, 0)
  in

  check "known type ctor is a return type"
    (ret_and_body "option" "(defn f [] (Option f64) (g))" = (true, 1));

  check "value ctor is NOT a return type"
    (ret_and_body "some" "(defn f [] (Some 1) (bar))" = (false, 2));

  check "user struct is a return type"
    (ret_and_body "user"
       "(defstruct Cursor [pos i32]) (defn f [] Cursor (g))" = (true, 1));

  (* Order-independent: the type is declared after the function that returns it *)
  check "type declared later is still known"
    (ret_and_body "later"
       "(defn f [] Cursor (g)) (defstruct Cursor [pos i32])" = (true, 1));

  check "unknown capitalised head is a body form"
    (ret_and_body "unknown" "(defn f [] (Nope 1) (bar))" = (false, 2));

  if !failures = 0 then print_endline "ambiguity: all tests passed"
  else begin
    Printf.printf "\n%d failure(s)\n" !failures;
    exit 1
  end