Eight hand-written .fln programs run the same on both backends and through a conversion to parens and back

lib/check.ml

@@ -6200,6 +6200,13 @@ and check_fn ctx ~want ?gen loc (params : string list) body =
         | Some other when other <> Types.Never ->
           fail loc "expected %s, found an fn" (Types.to_string other)
         | _ ->
+          if fln_source loc then
+            fail loc
+              "nothing here says what this fn's parameters are — an fn takes \
+               its types from the position it is written in. Pass it where a \
+               Fn(T, ...) -> R is expected, or name the type where it is \
+               bound: let f: Fn(T, ...) -> R = fn(...)"
+          else
           fail loc
             "nothing here says what this fn's parameters are — an fn takes \
              its types from the position it is written in. Write it as an \
@@ -10701,8 +10708,10 @@ and named_call ?(qualified = false) ctx ~want loc name args =
           fail loc
             "a pattern cannot destructure %s — a slice's length is not known \
              until the program runs, so nothing here can check it has %Ld \
-             element%s. Use (at s i) and test (length s) yourself"
+             element%s. Use %s and test %s yourself"
             (Types.to_string target.Tast.ty) n (plural n)
+            (if fln_source loc then "s[i]" else "(at s i)")
+            (if fln_source loc then "length(s)" else "(length s)")
         | other ->
           fail loc
             "%s is not a fixed array, so [a b ...] cannot destructure it"

lib/indent_printer.ml

@@ -398,6 +398,10 @@ and list _f h args =
       && (match t.v with
           | Form.Byte _ -> false
           | Form.Sym x -> name_ok x && not (String.contains x '.') && not (R.capitalised x)
+          (* A field of a field chains: [w.x.count]. *)
+          | Form.List [ { v = Form.Sym f; _ }; _ ]
+            when String.length f > 1 && f.[0] = '.' && tt <> "" && tt.[0] <> '.' ->
+            String.length tt > 0 && not (String.contains tt ' ')
           | _ ->
             let c = tt.[String.length tt - 1] in
             c = ')' || c = ']' || c = '}' || c = '"')
@@ -760,8 +764,15 @@ and sugar n (f : Form.t) : string list option =
       | Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads)
       | _ -> true
     in
+    (* An else that is another if with an else chains on the line:
+       [if a then x else if b then y else z]. *)
+    let rec chain (x : Form.t) =
+      match x.v with
+      | Form.List [ { v = Form.Sym "if"; _ }; _; a; b ] -> simple a && chain b
+      | _ -> simple x
+    in
     let line = i ^ fst (expr f) in
-    if simple a && simple b && String.length line <= width && not (!inside f)
+    if simple a && chain b && String.length line <= width && not (!inside f)
     then Some [ line ]
     else
       Some

lib/indent_reader.ml

@@ -812,7 +812,21 @@ and items p closer open_loc ~what =
          | EOF -> unclosed p opener open_loc
          | _ ->
            let n = peek p in
-           if starts_value n.tok && n.sp && not (negative_literal n.tok) then
+           let block_lambda =
+             match e.v with
+             | Form.List ({ v = Form.Sym "fn"; _ } :: ps) ->
+               List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) ps
+               && n.loc.Loc.line > e.loc.Loc.eline
+             | _ -> false
+           in
+           if block_lambda then
+             failk "lambda-block-in-brackets" n.loc
+               "a lambda's block cannot go inside brackets, where a line break \
+                is only a space. Name it first, with the block under it:\n\n\
+               \    let f = %s\n      ...\n\n\
+                and pass f, or write it on one line: %s = value"
+               (text_of e) (text_of e)
+           else if starts_value n.tok && n.sp && not (negative_literal n.tok) then
              failk "missing-comma" n.loc
                "%s follows %s with no comma between them. Separate %s with \
                 commas: f(a, b)"
@@ -897,6 +911,29 @@ let rec ty p : Form.t =
    as a call does not. *)
 type st = { p : p; mutable lets : Form.t list }
 
+(* Whether the code line before [t] is a one-line [if c then a] with no
+   else: an else under it reads as written for that if, and is not. *)
+let one_line_if_above p (t : token) =
+  let layout = function NEWLINE | INDENT | DEDENT -> true | _ -> false in
+  let rec prev j =
+    if j < 0 then None
+    else
+      let u = p.toks.(j) in
+      if u.loc.Loc.line < t.loc.Loc.line && not (layout u.tok) then Some u.loc.Loc.line
+      else prev (j - 1)
+  in
+  match prev (p.i - 1) with
+  | None -> false
+  | Some l ->
+    let rec line j acc =
+      if j < 0 || p.toks.(j).loc.Loc.line < l then acc
+      else line (j - 1) (if layout p.toks.(j).tok || p.toks.(j).loc.Loc.line > l then acc
+                         else p.toks.(j).tok :: acc)
+    in
+    (match line (p.i - 1) [] with
+     | NAME "if" :: rest -> List.mem (NAME "then") rest && not (List.mem (NAME "else") rest)
+     | _ -> false)
+
 (* A block of several lines is a [do] spanning its lines, from the first
    statement to the end of the last — not from the header above it, which is
    another form's. *)
@@ -1132,6 +1169,14 @@ and stmt (s : st) : Form.t =
   let t = peek p in
   match t.tok with
   | NAME w when header_follow p w -> header s w
+  | NAME (("else" | "elif") as w) when one_line_if_above p t ->
+    failk "orphan-else" t.loc
+      "the if above is a one-line if, which ends with its line, so this %s \
+       has no if to belong to. Keep the one-line form on one line:\n\n\
+      \    if c then a else b\n\n\
+       or give each branch a block:\n\n\
+      \    if c\n      a\n    else\n      b"
+      w
   | NAME (("else" | "elif") as w) ->
     failk "orphan-else" t.loc
       "%s is not under an if at this column. It goes at the same column as \

test/syntax/handwritten/traffic.fln

@@ -0,0 +1,91 @@
+; A traffic light at a crossing, driven by a clock and a pedestrian button.
+; Each state carries how long it has left; a fault drops the light to
+; flashing, and a supervisor decides whether to reset it.
+
+data Light
+  Green(left: i32)
+  Yellow(left: i32, walk: bool)
+  Red(left: i32, walk: bool)
+  Flashing()
+
+struct Fault
+  tick: i32
+
+const green-time = 4
+const yellow-time = 1
+const red-time = 3
+
+fn next(l: Light, pressed: bool) -> Light
+  match l
+    Green(left) ->
+      if left > 1 and not pressed
+        Light.Green{.left left - 1}
+      else
+        Light.Yellow{.left yellow-time, .walk pressed}
+    Yellow(left, walk) ->
+      if left > 1
+        Light.Yellow{.left left - 1, .walk walk}
+      else
+        Light.Red{.left red-time, .walk walk}
+    Red(left, walk) ->
+      if left > 1 then Light.Red{.left left - 1, .walk walk} else Light.Green{.left green-time}
+    Flashing -> Light.Flashing{}
+
+fn show(l: Light) -> string
+  match l
+    Green(_) -> "G"
+    Yellow(_, _) -> "Y"
+    Red(_, walk) -> if walk then "W" else "R"
+    Flashing -> "*"
+
+; Runs the light for ticks steps; a fault at fault-at is signalled, and
+; whoever handles it may reset the light to red.
+fn run(ticks: i32, presses: [const i32], fault-at: i32) -> ()
+  let l = Light.Red{.left 1, .walk false}
+  let p = 0
+  let t = 0
+  until :clock t >= ticks
+    let pressed = p < length(presses)
+                  and presses[p] == t
+    if pressed
+      ++(p)
+    if t == fault-at
+      l = restart-case
+        error(Fault{.tick t})
+        l
+      restart reset()
+        :report
+        "Put the light back to red and carry on"
+        Light.Red{.left red-time, .walk false}
+      restart flash()
+        Light.Flashing{}
+    match l
+      Flashing ->
+        print(show(l))
+        break :clock
+      _ -> print(show(l))
+    l = next(l, pressed)
+    t += 1
+  println("")
+
+fn main() -> i32
+  let none = [-1]
+  let two = [1 9]
+  run(12, slice(none), -1)
+  run(12, slice(two), -1)
+  handler-bind
+    run(12, slice(none), 5)
+  on Fault(f)
+    invoke-restart('reset)
+  handler-bind
+    run(12, slice(none), 5)
+  on Fault(f)
+    invoke-restart('flash)
+  println:
+    handler-case
+      run(12, slice(none), 2)
+      "no fault"
+    on Fault(f)
+      println("")
+      "fault at tick"
+  0

test/syntax/handwritten/traffic.out

@@ -0,0 +1,6 @@
+RGGGGYRRRGGG
+RGYWWWGGGGYW
+RGGGGRRRGGGG
+RGGGG*
+RG
+fault at tick

test/syntax/handwritten/words.fln

@@ -0,0 +1,84 @@
+; Word statistics over a paragraph: a frequency table, the longest words,
+; and a grade for how varied the vocabulary is.
+
+enum Grade
+  poor = 1
+  fair = 2
+  rich = 3
+
+struct Count
+  word: [const u8]
+  n: i32
+
+fn letter?(c: u8) -> bool
+  (c >= \a and c <= \z)
+    or (c >= \A and c <= \Z)
+    or c == \'
+
+; The words of text, lowercased, in order.
+fn words(text: [const u8]) -> Vec([const u8])
+  let out = vec-new([const u8])
+  let lower = to-lower(text)
+  let i = 0
+  let n = length(lower)
+  while :scan i < n
+    until i >= n or letter?(lower[i])
+      i += 1
+    if i >= n
+      break :scan
+    let start = i
+    while i < n and letter?(lower[i])
+      i += 1
+    push(out, slice(lower, start, i))
+  out
+
+fn tally(ws: [[const u8]]) -> Vec(Count)
+  let seen = map-new(string, i32)
+  defer free(seen)
+  let counts = vec-new(Count)
+  for i in range(length(ws))
+    match get(seen, string(ws[i]))
+      Some(k) -> counts[k].n += 1
+      None ->
+        put(seen, string(ws[i]), i32(length(counts)))
+        push(counts, Count{.word ws[i], .n 1})
+  counts
+
+fn grade(distinct: i32, total: i32) -> Grade
+  let ratio = distinct * 10 / max(total, 1)
+  if ratio >= 7 then :rich else if ratio >= 4 then :fair else :poor
+
+fn describe(g: Grade) -> string
+  match i32(g)
+    1 -> "repetitive"
+    2 -> "ordinary"
+    _ -> "varied"
+
+fn main() -> i32
+  let text = "The cat saw the dog. The dog didn't see the cat, but the bird saw both!"
+  let ws = words(bytes-view(text))
+  let counts = tally(slice(ws))
+  let by-count: Fn(Count, Count) -> bool = fn(a, b)
+    if a.n != b.n
+      return a.n > b.n
+    bytes<?(a.word, b.word)
+  sort-by(slice(counts), by-count)
+  for i in range(3)
+    let {.word .n} = counts[i]
+    println(string(word), n)
+  let top: [3 i32] = [counts[0].n counts[1].n counts[2].n]
+  let [most & others] = top
+  println("most frequent seen", most, "times, then", others)
+  let total = i32(length(ws))
+  let distinct = i32(length(counts))
+  let g = grade(distinct, total)
+  println(distinct, "of", total, "distinct:", describe(g))
+  let longest = reduce(slice(ws), slice(ws[0], 0, 0), fn(a, b) =
+    if length(b) > length(a) then b else a)
+  println("longest", string(longest))
+  let short = 0 < length(longest) < 5
+  match short
+    true -> println("short words only")
+    false -> println("some long words")
+  println("three distinct counts?", !=(counts[0].n, counts[1].n, counts[2].n))
+  0

test/syntax/handwritten/words.out

@@ -0,0 +1,8 @@
+the 5
+cat 2
+dog 2
+most frequent seen 5 times, then [2 2]
+9 of 16 distinct: ordinary
+longest didn't
+some long words
+three distinct counts? false

test/test_syntax.ml

@@ -918,7 +918,7 @@ let () =
 
 (* ── Both directions of an import, on both backends ────────────────── *)
 
-let run_both path want =
+let run_both ?(backends = [ false; true ]) path want =
   List.iter
     (fun x86 ->
        let exe =
@@ -939,7 +939,7 @@ let run_both path want =
          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 ]
+    backends
 
 (* A program and its conversion print the same: the flat lets, the renames
    and the macro bodies they rest on keep what each name means. *)
@@ -972,6 +972,66 @@ let run_converted path =
   | ((c, a), (d, b)) ->
     fail "%s printed %S (exit %d), and converted %S (exit %d)" path a c b d
 
+(* ── Programs written by hand in the indented syntax ─────────────────── *)
+
+(* Each [syntax/handwritten/x.fln] prints [x.out] on both backends; its
+   conversion to parens reads back to the same forms, with every comment,
+   and converts back to indented text that reads to them again; and the
+   converted .flan builds and prints the same. *)
+let handwritten () =
+  let dir = "syntax/handwritten" in
+  Sys.readdir dir |> Array.to_list
+  |> List.filter (fun f -> Filename.check_suffix f ".fln")
+  |> List.sort compare
+  |> List.map (Filename.concat dir)
+
+let converts_back path =
+  let src = In_channel.with_open_bin path In_channel.input_all in
+  let forms = Source.read_file path in
+  let norm_all fs =
+    macros := Body_macros.table ~file:path fs;
+    List.map norm fs
+  in
+  let want = norm_all forms in
+  let paren = Paren_printer.program ~source:src forms in
+  match Reader.read_all ~file:path paren with
+  | exception e -> fail "%s to parens: %s" path (diag_text e)
+  | again ->
+    if not (same_forms want (norm_all again)) then
+      fail "%s to parens: %s" path (describe_diff want (norm_all again))
+    else if comment_texts paren <> comment_texts src then
+      fail "%s to parens: the comments did not all come through" path
+    else begin
+      let fln = Indent_printer.program ~source:paren ~macros:!macros again in
+      (match Indent_reader.read_all ~file:path fln with
+       | exception e -> fail "%s back to indented: %s" path (diag_text e)
+       | back ->
+         if not (same_forms want (norm_all back)) then
+           fail "%s back to indented: %s" path (describe_diff want (norm_all back)));
+      (* Beside the original, so its imports resolve the same way. *)
+      let flan = Filename.concat (Filename.dirname path)
+          (Printf.sprintf ".conv-%d-%s.flan" (Unix.getpid ())
+             (Filename.remove_extension (Filename.basename path))) in
+      Out_channel.with_open_bin flan (fun oc -> output_string oc paren);
+      Fun.protect ~finally:(fun () -> try Sys.remove flan with Sys_error _ -> ())
+        (fun () -> run_both ~backends:[ false ] flan
+            (In_channel.with_open_bin (Filename.remove_extension path ^ ".out")
+               In_channel.input_all))
+    end
+
+let () =
+  List.iter
+    (fun p -> try converts_back p with e -> fail "%s: %s" p (diag_text e))
+    (List.filter (fun _ -> Test_support.have "clang") (handwritten ()));
+  if List.length (handwritten ()) < 8 then
+    fail "only %d hand-written programs" (List.length (handwritten ()));
+  if Test_support.have "clang" then
+    List.iter
+      (fun p ->
+         run_both p (In_channel.with_open_bin (Filename.remove_extension p ^ ".out")
+                       In_channel.input_all))
+      (handwritten ())
+
 let () =
   if Test_support.have "clang" then begin
     List.iter run_converted