(* flan — milestone 2 driver. *)

(* Both error channels, in the one place that prints them. A single refusal
   still exits 1 and still opens with [file:line:col: message]; a driver that
   got to the end of the file hands over everything it found, sorted, with a
   count after it. Nothing here parses the message — the squiggle comes from
   the span and the classification from the kind. *)
let with_errors path f =
  try f () with
  | Flan.Loc.Error d ->
    prerr_endline (Flan.Loc.report d);
    ignore path;
    exit 1
  | Flan.Loc.Errors ds ->
    prerr_endline (Flan.Loc.report_all ds);
    ignore path;
    exit 1

let summarise (d : Flan.Ast.decl) =
  let open Flan.Ast in
  match d.d with
  | Package n -> Printf.sprintf "package %s" n
  | Import (a, p) -> Printf.sprintf "import %s %S" a p
  | Defalias (n, _) -> Printf.sprintf "defalias %s" n
  | Defstruct (n, fs) -> Printf.sprintf "defstruct %s (%d fields)" n (List.length fs)
  | Defunion (n, vs) -> Printf.sprintf "defunion %s (%d cases)" n (List.length vs)
  | Defvar (n, _, _) -> Printf.sprintf "defvar %s" n
  | Defconst (n, _, _) -> Printf.sprintf "defconst %s" n
  | Declare (fn, csym) ->
    Printf.sprintf "declare %s (%d params) = %s" fn.name (List.length fn.params)
      csym
  | DeclareC (fn, csym) ->
    Printf.sprintf "declare-c %s (%d params) = %s" fn.name
      (List.length fn.params) csym
  | Defenum (n, ms) -> Printf.sprintf "defenum %s (%d members)" n (List.length ms)
  | Defn fn ->
    Printf.sprintf "defn %s (%d params, %s return, %d body forms)"
      fn.name (List.length fn.params)
      (match fn.ret with None -> "Unit" | Some _ -> "explicit")
      (List.length fn.fbody)

(* Every path past [parse] goes through [Load]: an import is resolved into the
   declarations it stands for, and the package's C shim and linker arguments
   come back with them. *)
(* Every driver here is the batch case, which is the one the workflow is: write
   everything, compile at the end, work through the list. So every one of them
   asks for the whole list rather than the first thing wrong. *)
let load path : Flan.Load.t =
  Flan.Load.program ~file:path
    (Flan.Parse.program_all (Flan.Reader.read_file path))

let checked path = Flan.Check.program_all (load path).decls

(* What the source called each parameter, per function. The typed IR refers to
   locals by slot index and records no names — [Check] has them in its scope
   list and drops them — so the debug info would otherwise print [p0] for
   every argument. Slots 0..n-1 are the parameters in order ([Tast.fn]), which
   is what makes this recoverable here, from declarations that are already in
   hand, rather than needing a change to the typed IR. It stops at the
   parameters: a let-bound local's name is genuinely not available without one.
   Only gathered for a debug build. *)
let param_names (l : Flan.Load.t) =
  List.filter_map
    (fun (d : Flan.Ast.decl) ->
       match d.Flan.Ast.d with
       | Flan.Ast.Defn fn ->
         Some (fn.Flan.Ast.name,
               List.map (fun (p : Flan.Ast.field) -> p.Flan.Ast.fname)
                 fn.Flan.Ast.params)
       | _ -> None)
    l.Flan.Load.decls

(* Bounds checks are on unless a build asks for them off — the release
   decision, not the optimisation level (NEXT.md, Bounds checks). *)
let no_checks_flag = "--no-bounds-checks"

(* A dev build is the one a REPL can attach to: every call goes through a cell
   so a redefinition can be installed, and the cells and globals are exported
   so a loaded module can reach them (NEXT.md, the dev loop). *)
let dev_flag = "--dev"

(* Source-level debugging: DWARF in the IR, -g on the C, and -O0 forced.
   Its own flag and not a mode of --dev, because the two answer different
   questions — --dev is "can I redefine this while it runs", --debug is "can I
   stop it and read it". See [Build.opts]. *)
let debug_flag = "--debug"

(* ASan and UBSan over the whole program, the runtime's C and the Flan alike.
   Its own flag for the same reason --debug is: it answers "is this program
   touching memory it does not own", which is neither of the other two
   questions. It does not imply -O0 — see [Build.opts], which also records
   what each of the two sanitizers actually reaches. *)
let sanitize_flag = "--sanitize"

(* [flan dev] builds one binary that is the program and holds the compiler,
   and serves the editor from a thread inside it. This asks for the old shape
   instead — a compiler process that launches the program and talks to it over
   a socket. It is the escape hatch for a machine that cannot build the
   compiler object (no ocamlfind, no flan.cmxa beside this binary), not a
   preference, and it goes away with the transport it drives. *)
let two_process_flag = "--two-process"

let flags =
  [ no_checks_flag; dev_flag; debug_flag; sanitize_flag; two_process_flag ]

(* [--target=wasm32-wasi] and [--target=web], the two cross targets. Unlike
   the flags above, a target
   carries a value, so it is matched by prefix and stripped from the residual
   arguments by the same test — otherwise [-o out --target=X] falls into the
   usage error. *)
let target_prefix = "--target="

let is_flag a =
  List.mem a flags || String.starts_with ~prefix:target_prefix a

let target_of args =
  List.find_map
    (fun a ->
       if String.starts_with ~prefix:target_prefix a then
         Some (String.sub a (String.length target_prefix)
                 (String.length a - String.length target_prefix))
       else None)
    args

let () =
  match Array.to_list Sys.argv with
  | _ :: "read" :: files when files <> [] ->
    List.iter
      (fun path ->
         with_errors path (fun () ->
           Flan.Reader.read_file path
           |> List.iter (fun f -> print_endline (Flan.Form.to_string f))))
      files
  | _ :: "parse" :: files when files <> [] ->
    List.iter
      (fun path ->
         with_errors path (fun () ->
           Flan.Reader.read_file path
           |> Flan.Parse.program_all
           |> List.iter (fun d -> print_endline (summarise d))))
      files
  | _ :: "check" :: files when files <> [] ->
    List.iter
      (fun path ->
         with_errors path (fun () ->
           let p = checked path in
           List.iter
             (fun (g : Flan.Tast.global) ->
                Printf.printf "%s %s %s\n"
                  (if g.gconst then "defconst" else "defvar")
                  g.gname (Flan.Types.to_string g.gty))
             p.globals;
           List.iter
             (fun (f : Flan.Tast.fn) ->
                Printf.printf "defn %s : (Fn [%s] %s)  %d slots\n" f.name
                  (String.concat " "
                     (List.map Flan.Types.to_string f.params))
                  (Flan.Types.to_string f.ret) (Array.length f.slots))
             p.fns))
      files
  (* The generated C, for looking at. A wrong FFI binding is wrong in the
     wrapper, and the wrapper is not on disk anywhere — [Build] hands the text
     straight to clang — so without this the only way to read one is to catch
     it in the object cache. *)
  | _ :: "shim" :: files when files <> [] ->
    List.iter
      (fun path ->
         with_errors path (fun () ->
           match (checked path).Flan.Tast.cshim with
           | [] -> Printf.printf "%s: no declare-c, so no generated C\n" path
           | parts -> List.iter (fun (_, src) -> print_string src) parts))
      files
  (* A header, read. The importer is a pure function of the header and the
     package beside it, so it can be looked at without building anything —
     which is what makes the diff against a hand-written binding possible, and
     what makes "generate once and commit the result" a usable option rather
     than a description of one. Prints the declarations it would produce, then
     what it refused and why, then how the package's defstructs compare with
     the header's records. *)
  | _ :: "import-c" :: header :: rest ->
    with_errors header (fun () ->
      let pkg = List.filter (fun a -> Filename.check_suffix a ".flan") rest in
      let flags =
        List.filter (fun a -> not (Filename.check_suffix a ".flan")) rest
      in
      let ds =
        List.concat_map
          (fun f -> Flan.Parse.program (Flan.Reader.read_file f)) pkg
      in
      let structs =
        List.filter_map
          (fun (d : Flan.Ast.decl) ->
             match d.Flan.Ast.d with
             | Flan.Ast.Defstruct (n, fs) -> Some (n, fs)
             | _ -> None)
          ds
      in
      let known_enums =
        List.filter_map
          (fun (d : Flan.Ast.decl) ->
             match d.Flan.Ast.d with
             | Flan.Ast.Defenum (n, _) -> Some n
             | _ -> None)
          ds
      in
      let taken = Hashtbl.create 64 in
      List.iter
        (fun d ->
           match Flan.Ast.declared_name d with
           | Some n -> Hashtbl.replace taken n ()
           | None -> ())
        ds;
      let bound_syms =
        List.filter_map
          (fun (d : Flan.Ast.decl) ->
             match d.Flan.Ast.d with
             | Flan.Ast.Declare (_, s) | Flan.Ast.DeclareC (_, s) -> Some s
             | _ -> None)
          ds
      in
      let imported, dump, env =
        Flan.Cimport.header ~loc:(Flan.Loc.make header 0 0) ~header ~flags
          ~known_structs:(List.map fst structs) ~known_enums ~taken ~bound_syms
          ~config:
            (match pkg with
             | f :: _ -> Flan.Load.binding_config (Filename.dirname f)
             | [] -> Flan.Cimport.no_config)
      in
      List.iter
        (fun d -> print_endline (Flan.Cimport.decl_source d))
        imported.Flan.Cimport.decls;
      Printf.printf "\n;; %d imported, %d refused, of %d functions in %s\n"
        (List.length imported.Flan.Cimport.decls)
        (List.length imported.Flan.Cimport.hidden)
        (List.length dump.Flan.Cimport.fns) header;
      List.iter
        (fun (n, why) -> Printf.printf ";; refused %s: %s\n" n why)
        imported.Flan.Cimport.hidden;
      (match Flan.Cimport.check_structs ~env ~structs dump with
       | [] ->
         if structs <> [] then
           Printf.printf ";; every defstruct agrees with the header\n"
       | bad ->
         List.iter
           (fun (n, why) -> Printf.printf ";; DISAGREES %s: %s\n" n why)
           bad);
      (* And the bindings the package already wrote by hand, against the
         header's own signatures. Nothing else in the build can do this: a
         wrong declare-c is wrong in the generated prototype too, so the two
         agree with each other and only the library disagrees. *)
      let bound =
        List.filter_map
          (fun (d : Flan.Ast.decl) ->
             match d.Flan.Ast.d with
             | Flan.Ast.DeclareC (fn, sym) -> Some (fn, sym)
             | _ -> None)
          ds
      in
      if bound <> [] then
       (match Flan.Cimport.diff_bound ~env ~bound dump with
        | [] ->
          Printf.printf
            ";; all %d hand-written declare-c agree with the header\n"
            (List.length bound)
        | diffs ->
          Printf.printf ";; %d of %d hand-written declare-c disagree\n"
            (List.length diffs) (List.length bound);
          List.iter
            (fun (x : Flan.Cimport.sig_diff) ->
               Printf.printf ";; DIFFERS %s (%s): %s\n"
                 x.Flan.Cimport.dflan x.Flan.Cimport.dsym x.Flan.Cimport.dwhy)
            diffs);
      (* And the constants, which until now nothing read at all: a wrong flag
         bit or a wrong enum member is the one kind of error here that is
         completely silent. *)
      let enums =
        List.filter_map
          (fun (d : Flan.Ast.decl) ->
             match d.Flan.Ast.d with
             | Flan.Ast.Defenum (n, ms) -> Some (n, ms)
             | _ -> None)
          ds
      and pconsts =
        List.filter_map
          (fun (d : Flan.Ast.decl) ->
             match d.Flan.Ast.d with
             | Flan.Ast.Defconst (n, _, e) -> Some (n, e)
             | _ -> None)
          ds
      in
      let config =
        match pkg with
        | f :: _ -> Flan.Load.binding_config (Filename.dirname f)
        | [] -> Flan.Cimport.no_config
      in
      (match Flan.Cimport.check_constants ~config ~enums ~consts:pconsts dump with
       | [] ->
         if enums <> [] then
           Printf.printf ";; every defenum member agrees with the header\n"
       | bad ->
         List.iter
           (fun (x : Flan.Cimport.const_diff) ->
              Printf.printf ";; %s %s: %s\n"
                (if x.Flan.Cimport.cmapping then "UNMAPPED" else "DISAGREES")
                x.Flan.Cimport.cname x.Flan.Cimport.cwhy)
           bad))

  (* Regeneration. [import-c] prints what it would produce; this writes it, and
     the difference between the two is that this one cannot skip the check.

     It reads the header out of the package's own `headers`, not off the
     command line, because the version that may be read is a property of the
     package — `headers` is where it says which one, and `link` is where it
     says which library that has to match. And it reads every .flan in the
     directory *except* the file it writes, so the hand-written declarations
     still win and the generated ones are not mistaken for them on the next
     run.

     Non-zero and nothing written when the package and the header disagree.
     That is the whole point: the committed file is the one thing here with no
     second opinion, so the moment of writing it is the only moment left at
     which the library can contradict it. *)
  | _ :: "generate-c" :: dir :: _ ->
    with_errors dir (fun () ->
      let loc = Flan.Loc.make dir 0 0 in
      let out = Filename.concat dir "generated.flan" in
      let ds =
        List.concat_map
          (fun f -> Flan.Parse.program (Flan.Reader.read_file f))
          (List.filter
             (fun f -> not (String.equal f out))
             (Flan.Load.entries dir ".flan"))
      in
      let config = Flan.Load.binding_config dir in
      match Flan.Load.header_specs ~loc dir with
      | [] ->
        Printf.eprintf
          "flan generate-c: %s/headers names no header that is there. \
           Regeneration reads the library's own header, at the version \
           %s/link names — export it and run this again.\n" dir dir;
        exit 2
      | _ :: _ :: _ ->
        Printf.eprintf
          "flan generate-c: %s/headers names more than one header, and one \
           generated file cannot come from several — the declarations would \
           depend on which was read last.\n" dir;
        exit 2
      | [ (h, flags) ] ->
        let r = Flan.Cimport.regenerate ~loc ~header:h ~flags ~ds ~config ~out in
        List.iter
          (fun (n, why) -> Printf.printf ";; refused %s: %s\n" n why)
          r.Flan.Cimport.ghidden;
        List.iter
          (fun (n, why) -> Printf.eprintf "DISAGREES %s: %s\n" n why)
          r.Flan.Cimport.gstructs;
        List.iter
          (fun (x : Flan.Cimport.sig_diff) ->
             Printf.eprintf "DIFFERS %s (%s): %s\n"
               x.Flan.Cimport.dflan x.Flan.Cimport.dsym x.Flan.Cimport.dwhy)
          r.Flan.Cimport.gsigs;
        List.iter
          (fun (x : Flan.Cimport.const_diff) ->
             Printf.eprintf "%s %s: %s\n"
               (if x.Flan.Cimport.cmapping then "UNMAPPED" else "DISAGREES")
               x.Flan.Cimport.cname x.Flan.Cimport.cwhy)
          r.Flan.Cimport.gconsts;
        if r.Flan.Cimport.gwrote then
          Printf.printf
            "wrote %s: %d declarations, %d refused, of %d functions in %s.\n\
             Every defstruct, every hand-written declare-c and every mapped\n\
             constant agrees with it.\n"
            out r.Flan.Cimport.gdecls
            (List.length r.Flan.Cimport.ghidden) r.Flan.Cimport.gfns h
        else begin
          Printf.eprintf
            "flan generate-c: %s does not agree with %s — %d struct layouts, \
             %d hand-written signatures and %d constants, of which %d are a \
             mapping the package has not declared. Nothing was written: a \
             generated file made against a header the library does not match \
             is the silent failure this check exists to prevent, and a \
             constant nothing is mapped to is one nothing checks.\n"
            dir h
            (List.length r.Flan.Cimport.gstructs)
            (List.length r.Flan.Cimport.gsigs)
            (List.length r.Flan.Cimport.gconsts)
            (List.length
               (List.filter
                  (fun (x : Flan.Cimport.const_diff) -> x.Flan.Cimport.cmapping)
                  r.Flan.Cimport.gconsts));
          exit 1
        end)

  (* The IR is target-independent — [Emit] writes no triple and no datalayout,
     which is what lets one .ll serve both targets — so there is nothing for a
     target to change here. Refused rather than accepted and ignored: silently
     swallowing a flag is the shape the house rule exists to prevent. *)
  | _ :: "emit" :: args when target_of args <> None ->
    prerr_endline
      "flan emit: --target is refused — the emitted IR carries no triple and \
       no datalayout, and the target is chosen at build.";
    exit 2
  | _ :: "emit" :: args when List.exists (fun a -> not (is_flag a)) args ->
    let checks = not (List.mem no_checks_flag args) in
    let dev = List.mem dev_flag args in
    let debug = List.mem debug_flag args in
    (* --sanitize changes the IR — every [define] names the attribute group
       ASan's pass selects on — so [emit] has to honour it or what this prints
       is not what a sanitized build compiles. *)
    let sanitize = List.mem sanitize_flag args in
    let files = List.filter (fun a -> not (is_flag a)) args in
    List.iter
      (fun path ->
         with_errors path (fun () ->
           let l = load path in
           let pnames = if debug then param_names l else [] in
           Flan.Check.program_all l.decls
           |> Flan.Emit.program ~checks ~dev ~debug ~pnames ~sanitize
           |> print_string))
      files
  | _ :: "build" :: path :: rest ->
    let checks = not (List.mem no_checks_flag rest) in
    let dev = List.mem dev_flag rest in
    let debug = List.mem debug_flag rest in
    let sanitize = List.mem sanitize_flag rest in
    let target = target_of rest in
    let out =
      match List.filter (fun a -> not (is_flag a)) rest with
      | [ "-o"; o ] -> o
      | [] ->
        let base = Filename.remove_extension (Filename.basename path) in
        (* A wasm module is not an executable and must not be named like one:
           the extension is what tells a runtime, and a reader, what it is. *)
        (* A web build is three files — the page, its JS and the module — and
           the page is the one named here: emcc derives the other two from it,
           and it is the one a browser opens. *)
        (match target with
         | Some t when Flan.Build.is_web t -> base ^ ".html"
         | Some t when String.starts_with ~prefix:"wasm32" t -> base ^ ".wasm"
         | _ -> base)
      | _ ->
        prerr_endline
          "usage: flan build <file.flan> [-o out] [--no-bounds-checks] \
           [--dev] [--debug] [--sanitize] [--target=wasm32-wasi|web]";
        exit 2
    in
    with_errors path (fun () ->
      let l = load path in
      let p = Flan.Check.program_all l.decls in
      (* The link follows the program, not the import list: a package nothing
         reachable calls into contributes no C and no linker argument, and its
         functions are not emitted either. That is what lets one file import
         raylib and still be buildable for wasm32. *)
      let p, csrcs, lflags = Flan.Reach.link ~dev l p in
      ignore (Flan.Build.executable
                ~opts:{ Flan.Build.default with checks; dev; debug; sanitize;
                                                target }
                ~csrcs ~lflags ~pnames:(if debug then param_names l else [])
                p ~out))
  (* The daemon an editor talks to: one session, the program it belongs to
     running beside it, and a socket. Unlike [flan reload] the session persists,
     so a defvar added by one evaluation is part of what the next one is checked
     against — and it owns the build, which is what makes its layout rules
     describe the process that is actually running. *)
  | _ :: "dev" :: path :: rest ->
    (* --debug builds the host *and* every module this daemon sends with DWARF,
       which is one flag because it is one decision: a line breakpoint in a
       .flan buffer needs a line table on the host to fire at all, and one in
       each redefinition module to still be firing after C-c C-c. It implies
       -O0 on both, so it is asked for rather than assumed. *)
    let debug = List.mem debug_flag rest in
    let merged = not (List.mem two_process_flag rest) in
    let rest = List.filter (fun a -> not (is_flag a)) rest in
    let sock =
      match rest with
      | [ "-s"; s ] -> s
      | [] -> Filename.concat (Filename.dirname path) ".flan-dev.sock"
      | _ ->
        prerr_endline
          "usage: flan dev <program.flan> [-s socket] [--debug]            [--two-process]";
        exit 2
    in
    with_errors path (fun () -> Flan.Dev.start ~debug ~merged ~file:path ~sock ())

  (* One redefinition, built the way an editor will ask for it: a session over
     the program the process was built from, and a file of the forms that
     changed. The session works out which names are new and whether the change
     is one a running process can be told at all — neither of which a command
     given only a list of function names could. *)
  | _ :: "reload" :: prog :: forms :: rest ->
    let debug = List.mem debug_flag rest in
    let rest = List.filter (fun a -> not (is_flag a)) rest in
    let out =
      match rest with
      | [ "-o"; o ] -> o
      | [] -> Filename.remove_extension (Filename.basename forms) ^ ".so"
      | _ ->
        prerr_endline
          "usage: flan reload <program.flan> <forms.flan> [-o out.so] [--debug]";
        exit 2
    in
    with_errors forms (fun () ->
      let t, _ = Flan.Session.create ~debug ~file:prog () in
      let src = In_channel.with_open_bin forms In_channel.input_all in
      let c = Flan.Session.eval ~origin:forms t src in
      let opts = { Flan.Build.default with dev = true; debug } in
      let timing = Flan.Build.shared ~opts ~ir:c.Flan.Session.ir ~out () in
      Printf.eprintf "%s  %s  llc %.1fms  ld %.1fms\n" out
        (String.concat " " c.Flan.Session.fns) timing.Flan.Build.llc_ms
        timing.Flan.Build.link_ms)
  (* [run] builds and execs. A .wasm is not executable, and picking a runtime
     for it is a decision this command has no business making, so a cross
     target is refused here by name rather than half-supported. *)
  | _ :: "run" :: _ :: args when target_of args <> None ->
    prerr_endline
      "flan run: --target is refused — a cross-built module is not something \
       this host can exec. Use flan build --target=... and a wasm runtime.";
    exit 2
  | _ :: "run" :: path :: args ->
    with_errors path (fun () ->
      let exe =
        Filename.concat (Filename.get_temp_dir_name ())
          (Printf.sprintf "flan-run-%d" (Unix.getpid ()))
      in
      let l = load path in
      let p = Flan.Check.program_all l.decls in
      let p, csrcs, lflags = Flan.Reach.link l p in
      ignore (Flan.Build.executable ~csrcs ~lflags p ~out:exe);
      let code =
        Sys.command (String.concat " " (List.map Filename.quote (exe :: args)))
      in
      (try Sys.remove exe with Sys_error _ -> ());
      exit code)
  | _ ->
    prerr_endline
      "usage: flan (read|parse|check|emit|shim) <file.flan>...\n\
      \       flan import-c <header.h> [package.flan...] [clang flags...]\n\
      \       flan generate-c <package-dir>\n\
      \       flan build <file.flan> [-o out] [--no-bounds-checks] [--dev] \
       [--debug] [--sanitize] [--target=wasm32-wasi|web]\n\
      \       flan run <file.flan> [args...]\n\
      \       flan reload <program.flan> <forms.flan> [-o out.so]\n\
      \       flan dev <program.flan> [-s socket]";
    exit 2