(* 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 ────────────────────────────────── *)

(* 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 same_forms a b then incr ok
             else fail "round trip %s: %s" path (describe_diff a b))
    (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))";
  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 "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" "x == ...";
  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 "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"

(* ── 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" ()