(* The indented syntax (spec-syntax.md): its reader, its printer, and the
   switch between the two readers by file extension.

   Four parts. Two programs hand-converted from paren to indented must read to
   the same forms. Every corpus file must survive paren -> printed indented ->
   read indented unchanged, up to the one merge the spec allows. A table pins
   the lexical edge cases and the refusals, with their kinds. And a program in
   each syntax importing a package in the other builds and runs the same on
   both backends. *)

open Flan

let () = Watchdog.arm ~seconds:300 "test_syntax"

let fail fmt = Test_support.fail fmt
let scratch = Test_support.scratch

(* ── Forms, compared without locations ─────────────────────────────── *)

let rec eq (a : Form.t) (b : Form.t) =
  match a.v, b.v with
  | Form.List x, Form.List y | Form.Vec x, Form.Vec y | Form.Map x, Form.Map y ->
    List.length x = List.length y && List.for_all2 eq x y
  | Form.Float x, Form.Float y ->
    Int64.equal (Int64.bits_of_float x) (Int64.bits_of_float y)
  | x, y -> x = y

(* The innermost pair that differs, for the failure line. *)
let rec first_diff (a : Form.t) (b : Form.t) =
  match a.v, b.v with
  | (Form.List x, Form.List y | Form.Vec x, Form.Vec y | Form.Map x, Form.Map y)
    when List.length x = List.length y ->
    (match List.find_opt (fun (p, q) -> not (eq p q)) (List.combine x y) with
     | Some (p, q) -> first_diff p q
     | None -> (a, b))
  | _ -> (a, b)

let same_forms a b =
  List.length a = List.length b && List.for_all2 eq a b

let describe_diff a b =
  if List.length a <> List.length b then
    Printf.sprintf "%d forms against %d" (List.length a) (List.length b)
  else
    match List.find_opt (fun (x, y) -> not (eq x y)) (List.combine a b) with
    | Some (x, y) ->
      let u, w = first_diff x y in
      Printf.sprintf "wanted %s, read %s (at %d:%d)" (Form.to_string u)
        (Form.to_string w) w.loc.Loc.line w.loc.Loc.col
    | None -> "equal"

(* A [let] whose whole body is another [let] is the merged [let]: spec §4
   step 3's one normalisation. Flan's [let] binds in order, so the two mean
   the same thing. *)
let rec norm (f : Form.t) : Form.t =
  let v =
    match f.v with
    | Form.List (({ v = Form.Sym "let"; _ } as h) :: { v = Form.Vec bs; loc } :: body) ->
      (match List.map norm body with
       | [ { v = Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs2; _ } :: body2); _ } ] ->
         Form.List (h :: Form.make (Form.Vec (List.map norm bs @ bs2)) loc :: body2)
       | body -> Form.List (h :: Form.make (Form.Vec (List.map norm bs)) loc :: body))
    | Form.List l -> Form.List (List.map norm l)
    | Form.Vec l -> Form.Vec (List.map norm l)
    | Form.Map l -> Form.Map (List.map norm l)
    | v -> v
  in
  { f with v }

let diag_text = function
  | Loc.Error d -> Printf.sprintf "%s %d:%d %s" d.Loc.kind d.dloc.Loc.line d.dloc.Loc.col d.dmsg
  | e -> Printexc.to_string e

(* ── The hand-converted pairs ──────────────────────────────────────── *)

let pair flan fln =
  match Reader.read_file flan, Source.read_file fln with
  | a, b ->
    if not (same_forms a b) then
      fail "%s and %s read differently: %s" flan fln (describe_diff a b)
  | exception e -> fail "%s / %s: %s" flan fln (diag_text e)

let () =
  pair "syntax/algorithms.flan" "syntax/algorithms.fln";
  pair "../sand.flan" "syntax/sand.fln";
  (* Checked, never run: sand opens a window. *)
  List.iter
    (fun f ->
       match Front.checked f with
       | _ -> ()
       | exception e -> fail "%s does not check: %s" f (diag_text e))
    [ "syntax/sand.fln"; "syntax/algorithms.fln" ]

(* ── The round trip over the corpus ────────────────────────────────── *)

(* The comments of a text, as a sorted list: where each lands may move — a
   comment inside an expression printed on one line goes above it — but none
   may be lost or made. *)
let comment_texts src =
  List.sort compare
    (List.map (fun (c : Source_text.comment) -> String.trim c.text) (Source_text.comments src))

(* What each comment is attached to. An own-line comment belongs to the form
   after it; a trailing one to the last form that starts on its line. After a
   conversion, the form after an own-line comment must be that form or one
   holding it (a comment inside an expression printed on one line goes above
   the line), and a trailing comment's line — or, when it had to move onto a
   line of its own, the line above — must hold its form. So a comment that
   drifted to another statement is caught, not only a lost one. *)
let starts_of (fs : Form.t list) =
  let out = ref [] in
  let rec walk (f : Form.t) =
    (* Outermost first among forms starting at one place: [x = v] and its
       [x] start together, and the statement is what a comment is about. *)
    let t = Form.to_string (norm f) in
    out := ((f.loc.Loc.line, f.loc.Loc.col, - String.length t), t) :: !out;
    match f.v with
    | Form.List l | Form.Vec l | Form.Map l -> List.iter walk l
    | _ -> ()
  in
  List.iter walk fs;
  List.map (fun ((l, c, _), t) -> (l, c, t)) (List.sort compare !out)

let attachments src forms =
  let st = starts_of forms in
  List.map
    (fun (c : Source_text.comment) ->
       let owner =
         if c.own_line then
           List.find_opt (fun (l, _, _) -> l > c.line) st
         else
           (* The last place a form starts on the line, and the outermost
              form starting there. *)
           List.fold_left
             (fun acc ((l, col, _) as x) ->
                match acc with
                | Some (_, col', _) when l = c.line && col = col' -> acc
                | _ -> if l = c.line then Some x else acc)
             None st
       in
       (c, Option.map (fun (_, _, t) -> t) owner))
    (Source_text.comments src)

let attached_ok ~what path (src, forms) (out, back) =
  let want = attachments src forms and got = attachments out back in
  let st = starts_of back in
  let on_line l = List.filter_map (fun (l', _, t) -> if l' = l then Some t else None) st in
  (* Paired by text, in order: the n-th copy of a text with the n-th. *)
  let rec pair = function
    | [] -> ()
    | ((c : Source_text.comment), o) :: rest ->
      let t = String.trim c.text in
      let same (d : Source_text.comment) = String.trim d.text = t in
      let rec take = function
        | [] -> None
        | ((d, _) as x) :: xs ->
          if same d && not (List.memq x !used) then (used := x :: !used; Some x)
          else take xs
      in
      (match take got, o with
       | None, _ -> fail "%s %s: the comment %s went missing" what path t
       | Some _, None -> ()
       | Some ((d : Source_text.comment), g), Some o ->
         let holds x = Test_support.contains x o in
         (* The code line a moved trailing comment sits under: up past the
            comment lines between. *)
         let rec code_above l =
           if l < 1 then []
           else match on_line l with [] -> code_above (l - 1) | fs -> fs
         in
         let fine =
           if c.own_line then
             (match g with
              (* Above the form, above the statement holding it, or above the
                 first statement of the block it was: all of those read as
                 being about it. *)
              | Some g -> holds g || (String.length g > 4 && Test_support.contains o g)
              | None -> false)
           else
             List.exists holds (on_line d.line)
             || (d.own_line && List.exists holds (code_above (d.line - 1)))
         in
         if not fine then
           fail "%s %s: the comment %s (line %d) was about %s and is now beside %s"
             what path t c.line o (Option.value g ~default:"nothing"));
      pair rest
  and used = ref [] in
  pair want

(* Every .flan the build tree holds. [..] is the workspace root from here;
   the deps in test/dune decide what is in it. *)
let corpus () =
  let rec walk dir acc =
    Array.fold_left
      (fun acc name ->
         let path = Filename.concat dir name in
         if name <> "" && (name.[0] = '.' || name.[0] = '_') then acc
         else if Sys.is_directory path then walk path acc
         else if Filename.check_suffix name ".flan" then path :: acc
         else acc)
      acc (Sys.readdir dir)
  in
  List.sort String.compare (walk ".." [])

let () =
  let ok = ref 0 in
  List.iter
    (fun path ->
       match Reader.read_file path with
       | exception Loc.Error _ -> ()   (* not a program the paren reader takes *)
       | forms ->
         let source = In_channel.with_open_bin path In_channel.input_all in
         match Indent_printer.program ~source forms with
         | exception Indent_printer.Unprintable (f, why) ->
           fail "round trip %s: %s at %d:%d" path why f.loc.Loc.line f.loc.Loc.col
         | text ->
           match Indent_reader.read_all ~file:(path ^ ".fln") text with
           | exception e -> fail "round trip %s: %s" path (diag_text e)
           | back ->
             let a = List.map norm forms and b = List.map norm back in
             if not (same_forms a b) then
               fail "round trip %s: %s" path (describe_diff a b)
             else if comment_texts text <> comment_texts source then
               fail "round trip %s: the comments did not all come through" path
             else begin
               attached_ok ~what:"round trip" path (source, forms) (text, back);
               (* And back to parens, from the indented text: the forms and
                  the comments survive the second printer too. *)
               let paren = Paren_printer.program ~source:text back in
               match Reader.read_all ~file:path paren with
               | exception e -> fail "back to parens %s: %s" path (diag_text e)
               | again ->
                 if not (same_forms (List.map norm again) b) then
                   fail "back to parens %s: %s" path
                     (describe_diff b (List.map norm again))
                 else if comment_texts paren <> comment_texts source then
                   fail "back to parens %s: the comments did not all come through" path
                 else begin
                   attached_ok ~what:"back to parens" path (text, back) (paren, again);
                   incr ok
                 end
             end)
    (corpus ());
  Printf.printf "round trip: %d files\n" !ok;
  (* The deps decide what is walked, and a stanza that lost them would pass
     over nothing. *)
  if !ok < 390 then fail "round trip covered only %d files" !ok

(* ── Lexical edge cases ────────────────────────────────────────────── *)

let read src = Indent_reader.read_all ~file:"<syntax>" src

let reads name src want =
  match read src with
  | forms ->
    let got = String.concat "\n" (List.map Form.to_string forms) in
    if got <> want then fail "%s: read %s, wanted %s" name got want
  | exception e -> fail "%s: refused: %s" name (diag_text e)

let refuses name src kind needle =
  match read src with
  | forms ->
    fail "%s: read %s, wanted the refusal %s" name
      (String.concat " " (List.map Form.to_string forms)) kind
  | exception Loc.Error d ->
    if d.Loc.kind <> kind then fail "%s: refused as %s, wanted %s (%s)" name d.Loc.kind kind d.dmsg
    else if not (Test_support.contains d.dmsg needle) then
      fail "%s: %s does not say %S: %s" name kind needle d.dmsg
  | exception e -> fail "%s: %s" name (Printexc.to_string e)

let () =
  (* Minus. *)
  reads "subtraction" "x = a - 1" "(set x (- a 1))";
  reads "negative literal" "x = -1" "(set x -1)";
  reads "negation" "x = -y" "(set x (- y))";
  reads "negation binds after postfix" "x = -p.x" "(set x (- (.x p)))";
  reads "lisp name" "x = a-b" "(set x a-b)";
  reads "decrement is a name" "--(j)" "(-- j)";
  reads "minus as a call" "x = -(a + b)" "(set x (- (+ a b)))";
  refuses "glued minus" "x = a -1" "indent/glued-minus" "a - 1";
  refuses "glued minus in a call" "f(a -1)" "indent/glued-minus" "space the minus";
  (* The arrow. *)
  reads "return arrow" "fn f(x: i32) -> i32 = x" "(defn f [x i32] i32 x)";
  reads "arrow inside a name" "fn dyn->f64(v: f64) -> f64 = v" "(defn dyn->f64 [v f64] f64 v)";
  reads "function type"
    "fn g(h: Fn(i32, i32) -> bool) -> () = h(1, 2)"
    "(defn g [h (Fn [i32 i32] bool)] () (h 1 2))";
  reads "untyped parameter is dyn" "fn id(x) -> dyn = x" "(defn id [x dyn] dyn x)";
  refuses "no return type" "fn f(x)\n  x" "indent/return-type" "-> i32";
  (* Characters, lexed before brackets and separators. *)
  reads "character literals" "x = [\\( \\, \\space \\)]" "(set x [\\( \\, \\space \\)])";
  reads "character arguments" "f(\\,, \\))" "(f \\, \\))";
  (* Keywords and annotations. *)
  reads "keyword" "def k = :else" "(def k dyn :else)";
  reads "annotation" "once grid: [4 [8 u32]]" "(defonce grid [4 [8 u32]])";
  reads "keyword argument" "rl/key-pressed?(:key-r)" "(rl/key-pressed? :key-r)";
  refuses "colon inside a name" "fn f(x:i32) -> () = x" "indent/colon-in-name" "x: i32";
  (* Adjacency. *)
  reads "call" "f(a, b)" "(f a b)";
  reads "index" "x[i, j]" "(at x i j)";
  reads "call of a call" "f(a)(b)" "((f a) b)";
  reads "field chain" "camera.target.x" "(.x (.target camera))";
  reads "qualified case" "Shape.Rect" "Shape.Rect";
  reads "field of a call" "f(x).y" "(.y (f x))";
  reads "struct literal" "Vector2{.x 1, .y 2}" "(Vector2 {.x 1 .y 2})";
  reads "operator call" "+(a, b, c)" "(+ a b c)";
  reads "operator value" "reduce(+, 0, xs)" "(reduce + 0 xs)";
  refuses "spaced call" "f (a)" "indent/spaced-call" "f(...)";
  refuses "spaced index" "x [i]" "indent/spaced-index" "x[i]";
  refuses "missing comma" "f(a b)" "indent/missing-comma" "commas";
  refuses "unspaced operator" "x = f(a)+ b" "indent/unspaced-operator" "a + b";
  (* Collections. *)
  reads "whitespace vector" "x = [i n]" "(set x [i n])";
  reads "comma vector" "x = [a - 1, b]" "(set x [(- a 1) b])";
  refuses "operator between spaces" "x = [a - 1 b]" "indent/separate-elements" "commas";
  reads "quoted list" "x = '(a b c)" "(set x (quote (a b c)))";
  (* Trailing colon blocks. *)
  reads "trailing block" "rl/with-drawing():\n  clear()\n  draw()"
    "(rl/with-drawing (clear) (draw))";
  reads "fallback with a block" "defmethod(describe, :square, [s]):\n  s"
    "(defmethod describe :square [s] s)";
  refuses "block without the colon" "f(x)\n  y" "indent/stray-indent" "trailing colon";
  refuses "colon on a non-call" "a + b:\n  y" "indent/colon-block" "comment:";
  reads "bare name takes a block" "comment:\n  f()\n  g()" "(comment (f) (g))";
  reads "qualified name takes a block" "rl/with-drawing:\n  f()" "(rl/with-drawing (f))";
  (* Indentation. *)
  refuses "tab" "fn f() -> ()\n\tg()" "indent/tab" "spaces";
  refuses "dedent to no block" "if a\n    b\n  c" "indent/dedent"
    "between the block at column 1 and the one at column 5";
  (* A continuation sits deeper than the line it continues. *)
  refuses "leading operator left of its block" "if a\n  b\n+ 1" "indent/continuation" "column 3";
  refuses "leading operator at the statement's column" "let x = 1\n+ 2\nx"
    "indent/continuation" "Indent it further";
  refuses "trailing operator, shallower next line" "if a\n  x = b +\nc"
    "indent/continuation" "finish the line above";
  reads "blank and comment lines" "if a\n\n  ; note\n  b\n\n; more\nc"
    "(when a b)\nc";
  (* Continuation lines. *)
  reads "trailing operator" "x = a +\n  b" "(set x (+ a b))";
  reads "leading operator" "x = a\n    + b" "(set x (+ a b))";
  reads "continued condition" "if a\n   and b\n  c" "(when (and a b) c)";
  (* Runs of one operator. *)
  reads "flattened" "x = a + b + c" "(set x (+ a b c))";
  reads "chain" "x = a < b < c" "(set x (< a b c))";
  reads "left to right" "x = a - b + c" "(set x (+ (- a b) c))";
  reads "precedence" "x = a or b and not c == d" "(set x (or a (and b (not (= c d)))))";
  refuses "not-equal chain" "x = a != b != c" "indent/chained-not-equal" "!=(a, b, c)";
  reads "not-equal call" "x = !=(a, b, c)" "(set x (!= a b c))";
  refuses "mixed comparison" "x = a < b <= c" "indent/mixed-comparison" "and";
  (* Statements. *)
  reads "lets merge" "fn f() -> i32\n  let a = 1\n  let b = 2\n  a + b"
    "(defn f [] i32 (let [a 1 b 2] (+ a b)))";
  reads "let with a block" "let a = 1\n  a\nb" "(let [a 1] a)\nb";
  reads "elif" "if a\n  1\nelif b\n  2\nelse\n  3" "(cond a 1 b 2 :else 3)";
  reads "one-line if" "x = if a then 1 else 2" "(set x (if a 1 2))";
  reads "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))";
  (* A place with a call in it is evaluated once: it reads as update. *)
  reads "assignment op over a call's place" "a[next()] += 1"
    "(update (at a (next)) + 1)";
  reads "for" "for :outer i in range(1, n)\n  f(i)" "(dotimes :outer [i 1 n] (f i))";
  reads "unit statement" "restart-case\n  f()\nrestart continue()\n  ()"
    "(restart-case (f) (continue [] (do)))";
  reads "match" "match s\n  Circle(r) -> r\n  _ ->\n    a()\n    b()"
    "(match s (Circle r) r _ (do (a) (b)))";
  reads "match over literals" "match n\n  5 -> a\n  -2.5 -> b\n  \"go\" -> c\n  \\a -> d\n  _ -> e"
    "(match n 5 a -2.5 b \"go\" c \\a d _ e)";
  reads "handler-bind moves the clauses" "handler-bind\n  f()\non E(c)\n  g(c)"
    "(handler-bind [(E [c] (g c))] (f))";
  reads "quote block"
    "defmacro(m, [x & ys]):\n  quote\n    f(~x)\n    ~@ys"
    "(defmacro m [x & ys] (quasiquote (do (f (unquote x)) (unquote-splicing ys))))";
  reads "lambda" "g = fn(i, j) = i * 10 + j" "(set g (fn [i j] (+ (* i 10) j)))";
  reads "lambda with a block" "g = fn(i)\n  a(i)\n  b(i)" "(set g (fn [i] (a i) (b i)))";
  reads "where" "fn s(xs: [$t]) -> () where ordered?($t) = f(xs)"
    "(defn s [xs [$t]] () {:where (ordered? $t)} (f xs))";
  reads "data" "data Shape\n  Circle(r: f32)\n  Empty"
    "(defdata Shape [(Circle [r f32]) Empty])";
  reads "enum" "enum K\n  lo = -1\n  mid" "(defenum K [lo -1 mid])";
  reads "struct" "struct Cell\n  row: i32\n  tag" "(defstruct Cell [row i32 tag dyn])";
  reads "read-only pointer" "def p: Ptr(const u8) = uninit" "(def p (Ptr const u8) uninit)";
  (* Statements that fit on a line, in one-line slots. *)
  reads "arm statements" "match s\n  1 -> break\n  2 -> continue :outer\n  _ -> x += 1"
    "(match s 1 (break) 2 (continue :outer) _ (set x (+ x 1)))";
  reads "then break" "if c then break" "(when c (break))";
  reads "then return else assign" "if c then return 5 else x = 2" "(if c (return 5) (set x 2))";
  reads "return in an expression if" "y = if c then return else 1" "(set y (if c (return) 1))";
  reads "defer an assignment" "defer x = 0" "(defer (set x 0))";
  (* Messages with a shape of their own. *)
  refuses "parenthesised pair" "x = (a, b)" "indent/tuple" "[a, b]";
  refuses "rest parameter" "fn f(& rest) -> () = 0" "indent/rest-parameter" "xs: [T]";
  refuses "assignment as a test" "if x = 1\n  y" "indent/assign-in-test" "write == instead";
  (* A message quotes the text as written, never the paren form. *)
  refuses "two assignments" "if a then b = c = d" "indent/assign-in-test" "if a then b = c,";
  refuses "a let-bound if with no block" "let r = if a > 1\nr" "indent/expected-block" "if a > 1 takes";
  refuses "two bindings on a line" "let v: i32 = a, w = b" "indent/one-binding" "a is followed by a comma";
  reads "a let-bound match" "let r = match a\n  1 -> 2\n  _ -> 3\nr" "(let [r (match a 1 2 _ 3)] r)";
  reads "a let-bound if" "let q = if a\n  1\nelse\n  2\nq" "(let [q (if a 1 2)] q)";
  reads "a let-bound call with a block" "let v = foo(a):\n  x\nv" "(let [v (foo a x)] v)";
  refuses "colon after if" "if c:\n  y" "indent/header-colon" "no colon";
  refuses "colon after a return type" "fn f() -> i32:\n  0" "indent/header-colon" "no colon";
  refuses "colon after a number" "while x < 3:\n  y" "indent/header-colon" "no colon";
  refuses "one-line handler-case" "handler-case g()" "indent/clause-header" "on Type(c)";
  refuses "one-line on clause" "handler-case\n  g()\non A(c) -> 1" "indent/clause-body" "on A(c)";
  refuses "one-line elif" "x = if a then 1 elif b then 2 else 3" "indent/one-line-elif" "else if b";
  refuses "elif with then" "if a\n  1\nelif b then 2" "indent/elif-then" "no then";
  refuses "brace hint" "x = {.x a + 1 .y 2}" "indent/separate-elements" "{.x a + 1, .y 2}";
  refuses "mixed separators" "x = [1 2, 3]" "indent/mixed-separators" "[1, 2, 3]";
  reads "one-line quote" "defmacro(m, [x]):\n  quote ~x + 1"
    "(defmacro m [x] (quasiquote (+ (unquote x) 1)))";
  reads "typed let" "let x: i32 = 5\nx" "(let [x (the i32 5)] x)";
  (* And back: the printer writes the idioms. *)
  let prints name src want =
    match Reader.read_all ~file:"<p>" src with
    | forms ->
      let got = Indent_printer.program ~source:src forms in
      if not (Test_support.contains got want) then
        fail "%s: printed %S, wanted it to contain %S" name got want
    | exception e -> fail "%s: %s" name (diag_text e)
  in
  prints "compound assignment" "(defn f [] () (set x (+ x 1)))" "  x += 1";
  prints "compound update" "(defn f [] () (update (at a (next)) + 1))"
    "  a[next()] += 1";
  prints "arm statements" "(defn f [] () (match s 1 (break) _ (return 2)))"
    "1 -> break\n    _ -> return 2";
  prints "then and else statements" "(defn f [] () (if c (return 1) (set x 2)))"
    "if c then return 1 else x = 2";
  prints "a statement argument makes a block" "(foo 1 (set x 2))" "foo(1):\n  x = 2";
  prints "no arguments before the block" "(comment (f))" "comment:\n  f()";
  prints "typed let" "(defn f [] i32 (let [x (the i32 5)] x))" "let x: i32 = 5";
  prints "do in an arm is a block" "(defn f [] () (match s _ (do (a) (b))))" "_ ->\n      a()";
  prints "hex spelling" "(def c dyn 0xFFF00FFF)" "0xFFF00FFF";
  prints "own-line comment above its form" "(defn f [] ()\n  ;; why\n  (g))" "  ;; why\n  g()";
  prints "trailing comment at its line's end" "(defn f [] ()\n  (g) ; note\n  (h))" "  g()  ; note\n";
  (* The other direction keeps them too. *)
  let back name src want =
    match Indent_reader.read_all ~file:"<b>" src with
    | forms ->
      let got = Paren_printer.program ~source:src forms in
      if not (Test_support.contains got want) then
        fail "%s: printed %S, wanted it to contain %S" name got want
    | exception e -> fail "%s: %s" name (diag_text e)
  in
  back "spellings to parens" "fn main() -> i32\n  println(0x1F, 1e3, 1_000, 3.0, 2.50, 0b101)\n  0"
    "(println 0x1F 1e3 1_000 3.0 2.50 0b101)";
  back "each binding keeps its comment"
    "fn main() -> i32\n  let a = 1  ; first\n  let b = 2  ; second\n  a + b"
    "(let [a 1  ; first\n        b 2]  ; second";
  prints "each binding keeps its comment, indented"
    "(defn f [] i32\n  (let [a 1 ; first\n        b 2] ; second\n    (+ a b)))"
    "  let a = 1  ; first\n  let b = 2  ; second";
  back "comments to parens" "; head\n\nfn main() -> i32\n  ; why\n  g()  ; note\n  0"
    "; head\n\n(defn main [] i32\n  ; why\n  (g)  ; note\n  0)"

(* ── Spans, for pause marks and error overlays ──────────────────────── *)

let span_is name (f : Form.t) (l, c, el, ec) =
  let g = f.loc in
  if (g.Loc.line, g.Loc.col, g.Loc.eline, g.Loc.ecol) <> (l, c, el, ec) then
    fail "%s spans %d:%d-%d:%d, wanted %d:%d-%d:%d" name g.Loc.line g.Loc.col
      g.Loc.eline g.Loc.ecol l c el ec

let () =
  (* A rewritten statement spans its text from the first token to the last,
     so a mark or an overlay drawn from it covers what was written. *)
  match read "x = a.b.c + b + c" with
  | [ ({ v = Form.List [ _; _; ({ v = Form.List [ _; abc; _; _ ]; _ } as sum) ]; _ } as set) ] ->
    span_is "x = ..." set (1, 1, 1, 18);
    span_is "a.b.c + b + c" sum (1, 5, 1, 18);
    span_is "a.b.c" abc (1, 5, 1, 10)
  | _ -> fail "x = a.b.c + b + c read as another shape"

let () =
  (* Editor code, placed where it was written: line 40, column 5, and the
     indent stack seeded with that column, so the next line at column 5 is a
     sibling rather than a dedent. *)
  Source.with_code ~syntax:Source.Indented ~at:(Some (40, 5)) (fun () ->
    match Source.read_code ~expr:true ~file:"<buf>" "f(1)\n    g(2)" with
    | [ ({ v = Form.List [ { v = Form.Sym "do"; _ }; a; b ]; _ } as d) ] ->
      span_is "the snippet" d (40, 5, 41, 9);
      span_is "its first line" a (40, 5, 40, 9);
      span_is "its second line" b (41, 5, 41, 9)
    | fs ->
      fail "a two-line snippet read as %s"
        (String.concat " " (List.map Form.to_string fs)));
  (* A snippet's first line is its left edge: a later line left of it is
     refused as that, and a snippet sent with leading spaces starts where its
     first token does. *)
  Source.with_code ~syntax:Source.Indented ~at:(Some (40, 5)) (fun () ->
    (match Source.read_code ~file:"<buf>" "f(1)\n  g(2)" with
     | _ -> fail "a line left of the snippet's first was read"
     | exception Loc.Error d ->
       if not (Test_support.contains d.Loc.dmsg "left of column 5 where the code sent starts")
       then fail "a line left of a snippet: %s" d.Loc.dmsg);
    match Source.read_code ~file:"<buf>" "  f(1)\n      g(2)" with
    | [ _; _ ] -> ()
    | _ -> fail "a snippet with leading spaces"
    | exception e -> fail "a snippet with leading spaces: %s" (diag_text e));
  (* A condition cut out from after [elif ] at column 3: its wrapped line at
     column 8 is deeper than the elif, which is what the file says, though not
     deeper than the cut. [:indent] says where the statement starts; every
     location stays the buffer's own. *)
  Source.with_code ~indent:3 ~syntax:Source.Indented ~at:(Some (10, 8)) (fun () ->
    (match Source.read_code ~expr:true ~file:"<buf>" "x == 0 or\n       x == 1" with
     | [ f ] -> span_is "a wrapped condition, cut mid-line" f (10, 8, 11, 14)
     | _ -> fail "a wrapped condition read as more than one form"
     | exception e -> fail "a wrapped condition: %s" (diag_text e));
    match Source.read_code ~expr:true ~file:"<buf>" "x == 0 or\n  x == 1" with
    | _ -> fail "a continuation left of its statement was read"
    | exception Loc.Error _ -> ());
  Source.with_code ~syntax:Source.Indented ~at:(Some (10, 8)) (fun () ->
    match Source.read_code ~expr:true ~file:"<buf>" "x == 0 or\n       x == 1" with
    | _ -> fail "without :indent, a wrapped line is measured from the cut"
    | exception Loc.Error _ -> ());
  Source.with_code ~syntax:Source.Paren ~at:(Some (7, 3)) (fun () ->
    match Source.read_code ~file:"<buf>" "(f 1)" with
    | [ f ] -> span_is "a paren snippet" f (7, 3, 7, 8)
    | _ -> fail "a paren snippet")

(* ── Loading ───────────────────────────────────────────────────────── *)

let write path text = Out_channel.with_open_bin path (fun oc -> output_string oc text)

let () =
  (* A spaced-out operator is one name; the checker says which arithmetic. *)
  let f = Filename.concat scratch "syntax-hint.fln" in
  write f "fn main() -> i32\n  let x = 3\n  x-1\n";
  (match Front.checked f with
   | _ -> fail "x-1 checked"
   | exception Loc.Error d ->
     if not (Test_support.contains d.Loc.dmsg "Did you mean x - 1?") then
       fail "x-1: %s" d.Loc.dmsg
   | exception e -> fail "x-1: %s" (Printexc.to_string e));
  (* One package, one file in two syntaxes: refused naming both. *)
  let dir = Filename.concat scratch "syntax-twin" in
  let pkg = Filename.concat dir "geo" in
  (try Unix.mkdir dir 0o755 with Unix.Unix_error _ -> ());
  (try Unix.mkdir pkg 0o755 with Unix.Unix_error _ -> ());
  write (Filename.concat pkg "geo.flan") "(defn one [] i32 1)\n";
  write (Filename.concat pkg "geo.fln") "fn one() -> i32 = 1\n";
  let main = Filename.concat dir "main.flan" in
  write main "(import geo \"geo\")\n(defn main [] i32 (geo/one))\n";
  match Front.checked main with
  | _ -> fail "a package with geo.flan and geo.fln loaded"
  | exception Loc.Error d ->
    if not (Test_support.contains d.Loc.dmsg "geo.flan"
            && Test_support.contains d.Loc.dmsg "geo.fln") then
      fail "twin files: %s" d.Loc.dmsg
  | exception e -> fail "twin files: %s" (Printexc.to_string e)

(* ── Both directions of an import, on both backends ────────────────── *)

let run_both path want =
  List.iter
    (fun x86 ->
       let exe =
         Filename.concat scratch
           (Printf.sprintf "flan-syntax-%s-%d%s"
              (Filename.basename path) (Unix.getpid ()) (if x86 then "-x86" else ""))
       in
       match
         let p, csrcs, lflags = Test_support.linked path in
         ignore (Build.executable ~opts:{ Build.default with x86 } ~csrcs ~lflags p ~out:exe)
       with
       | exception e -> fail "%s%s does not build: %s" path (if x86 then " --x86" else "") (diag_text e)
       | () ->
         let out = exe ^ ".out" in
         let code = Sys.command (Filename.quote exe ^ " > " ^ Filename.quote out ^ " 2>&1") in
         let text = In_channel.with_open_bin out In_channel.input_all in
         (try Sys.remove out; Sys.remove exe with Sys_error _ -> ());
         if code <> 0 || text <> want then
           fail "%s%s printed %S and exited %d, wanted %S" path
             (if x86 then " --x86" else "") text code want)
    [ false; true ]

let () =
  if Test_support.have "clang" then begin
    run_both "syntax/mixed/main.flan" "12\n12\n0\n55\n";
    run_both "syntax/mixed/main.fln" "25\n7\nfar\n3\n"
  end
  else print_endline "syntax: no clang, the import programs are not built"

let () = Test_support.report ~label:"syntax" ()