(** [flan dev]: one long-lived session, the program it belongs to running
    beside it, and a socket an editor talks to.

    This is the piece between an editor and everything else. What it adds over
    [flan reload] is that the session *persists*: a [defvar] added by one
    evaluation is part of the program the next one is checked against, and the
    set of names the running process was built with is the one from the build
    this daemon actually made. A CLI that rebuilds its session from source each
    time cannot have either.

    It owns the build, which is what makes its layout rules mean anything: a
    session's struct layouts and global types describe the memory of a process
    only if it is the session that compiled it. So the daemon launches the
    program rather than attaching to one. *)

(* Where a function's body was last built. The daemon owns the build, so it is
   the only thing that can answer "which module defines this name now" — but
   see [basis] below for what that answer honestly is. *)
type origin = {
  ogen : int;                    (* reload generation; 0 is the host's *)
  oso  : string;                 (* the object the body was linked into *)
  oll  : string;                 (* the IR it was built from *)
  oloc : string;                 (* where the source it came from was written *)
}

type t = {
  session : Session.t;
  child   : int;                 (* the running program *)
  agent   : string;              (* where it listens for modules *)
  dir     : string;              (* modules are built here, one per eval *)
  stdout  : Unix.file_descr;     (* the program's output, on its way to here *)
  out     : Buffer.t;            (* ...buffered until an editor asks for it *)
  mutable n : int;               (* dlopen caches by path: never reuse one *)
  (* Bookkeeping for disassembly, and the reason it can exist at all: the
     daemon compiled every module it sent, so the .ll and the .so are on its
     own disk. What it does not have is a way back into the process's cells. *)
  mutable gen : int;             (* accepted deliveries, in order *)
  owners  : (string, origin) Hashtbl.t;  (* fn name -> the last module sent *)
  host_ll : string;              (* the IR the running program was built from *)
}

(* The program's stdout is a pipe into this process, so that an editor can see
   it. That makes draining it a *liveness* requirement and not a nicety: a pipe
   nobody reads fills at 64K and the next write blocks the program forever. So
   it is read from the accept loop's select, not only when someone asks. *)
let capacity = 256 * 1024

let drain t =
  let b = Bytes.create 8192 in
  let rec go () =
    match Unix.select [ t.stdout ] [] [] 0. with
    | [], _, _ -> ()
    | _ ->
      (match Unix.read t.stdout b 0 8192 with
       | 0 -> ()
       | n ->
         Buffer.add_subbytes t.out b 0 n;
         (* Bounded: a program that prints every frame must not grow this
            process without limit. The newest text is the useful end. *)
         if Buffer.length t.out > capacity then begin
           let keep = Buffer.sub t.out (Buffer.length t.out - capacity) capacity in
           Buffer.clear t.out;
           Buffer.add_string t.out keep
         end;
         go ()
       | exception Unix.Unix_error (Unix.EAGAIN, _, _) -> ()
       | exception Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> ()
       | exception Unix.Unix_error _ -> ())
  in
  go ()

let take t =
  drain t;
  let s = Buffer.contents t.out in
  Buffer.clear t.out;
  s

let await ?(ms = 5000) f =
  let rec go ms =
    if f () then true
    else if ms <= 0 then false
    else begin ignore (Unix.select [] [] [] 0.005); go (ms - 5) end
  in
  go ms

(* ── Delivery ──────────────────────────────────────────────────────── *)

(* The agent answers "ok" when it has queued a module, and anything else is a
   refusal with a reason. Reporting that back rather than swallowing it is what
   keeps a failed delivery from looking like a successful evaluation — the
   whole class of bug this socket makes possible. *)
let deliver t path =
  let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
  Fun.protect
    ~finally:(fun () -> try Unix.close s with Unix.Unix_error _ -> ())
    (fun () ->
       Unix.connect s (Unix.ADDR_UNIX t.agent);
       let msg = path ^ "\n" in
       ignore (Unix.write_substring s msg 0 (String.length msg));
       let b = Bytes.create 1024 in
       let buf = Buffer.create 64 in
       let rec drain () =
         match Unix.read s b 0 1024 with
         | 0 -> ()
         | n -> Buffer.add_subbytes buf b 0 n; drain ()
         | exception Unix.Unix_error _ -> ()
       in
       drain ();
       String.trim (Buffer.contents buf))

(* Read back the value of the last expression evaluated, with the counter that
   says whether it is a new one. The thunk runs on the game thread whenever the
   program next reaches a frame boundary, which is not a moment the daemon gets
   to know about, so this waits for the counter to move rather than assuming it
   has. *)
let result t =
  let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
  Fun.protect
    ~finally:(fun () -> try Unix.close s with Unix.Unix_error _ -> ())
    (fun () ->
       Unix.connect s (Unix.ADDR_UNIX t.agent);
       ignore (Unix.write_substring s "result\n" 0 7);
       let b = Bytes.create 4096 in
       let buf = Buffer.create 256 in
       let rec drain () =
         match Unix.read s b 0 4096 with
         | 0 -> ()
         | n -> Buffer.add_subbytes buf b 0 n; drain ()
         | exception Unix.Unix_error _ -> ()
       in
       drain ();
       let text = Buffer.contents buf in
       match String.index_opt text '\n' with
       | None -> None
       | Some i ->
         let header = String.sub text 0 i in
         let body = String.sub text (i + 1) (String.length text - i - 1) in
         (match String.split_on_char ' ' header with
          | [ g; _ ] ->
            (match Int64.of_string_opt g with
             | Some g -> Some (g, body)
             | None -> None)
          | _ -> None))

(* ── The break state ───────────────────────────────────────────────── *)

(* Everything above is about changing a *running* program. This is the other
   half: an unhandled [error] does not kill a dev build, it stops the game
   thread on the frame that erred and waits. The agent's socket is where that
   shows, and the daemon is the only thing holding that socket — so an editor
   asks here or not at all.

   One line out, one line back, exactly like [result]: the agent is not a
   protocol and must not become one. *)
let ask t verb =
  let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
  Fun.protect
    ~finally:(fun () -> try Unix.close s with Unix.Unix_error _ -> ())
    (fun () ->
       Unix.connect s (Unix.ADDR_UNIX t.agent);
       let msg = verb ^ "\n" in
       ignore (Unix.write_substring s msg 0 (String.length msg));
       let b = Bytes.create 4096 in
       let buf = Buffer.create 128 in
       let rec drain () =
         match Unix.read s b 0 4096 with
         | 0 -> ()
         | n -> Buffer.add_subbytes buf b 0 n; drain ()
         | exception Unix.Unix_error _ -> ()
       in
       drain ();
       Buffer.contents buf)

type state =
  | Running
  | Stopped of string            (* the condition's class name *)
  | Unreachable of string        (* no answer: exited, or never listened *)

(* [status] is answered whether or not the program is stopped — "running" is an
   answer, not a refusal. Everything else the break loop offers is refused
   while running, and rightly: there is no restart stack to walk. But the
   question an editor asks *without already knowing* is this one, so it had to
   have an answer in both states or there would be nothing to poll. *)
let state t =
  match ask t "status" with
  | "" -> Unreachable "the program is not answering on its socket"
  | text ->
    let line = String.trim (List.hd (String.split_on_char '\n' text)) in
    if line = "running" then Running
    else if String.length line > 8 && String.sub line 0 8 = "stopped " then
      Stopped (String.sub line 8 (String.length line - 8))
    else Unreachable ("the program answered " ^ line)
  | exception Unix.Unix_error (e, _, _) -> Unreachable (Unix.error_message e)

(* Innermost first, terminated by a line that is a single dot — the agent's
   framing, not this one's. A refusal comes back as a line starting "err ", and
   is passed on rather than turned into an empty list: no restarts and cannot
   say are different answers. *)
let restarts t =
  match ask t "restarts" with
  | text ->
    let lines = String.split_on_char '\n' text in
    if List.exists (fun l -> String.length l >= 3 && String.sub l 0 3 = "err") lines
    then Error (String.trim text)
    else
      Ok
        (List.filter
           (fun l -> l <> "" && l <> ".")
           (List.map String.trim lines))
  | exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e)

let alive t =
  match Unix.waitpid [ Unix.WNOHANG ] t.child with
  | 0, _ -> true
  | _ -> false
  | exception Unix.Unix_error _ -> false

(* ── What a body was built from ─────────────────────────────────────── *)

let write_file path text =
  let oc = open_out_bin path in
  Fun.protect ~finally:(fun () -> close_out oc) (fun () -> output_string oc text)

let read_file path =
  let ic = open_in_bin path in
  Fun.protect
    ~finally:(fun () -> close_in ic)
    (fun () -> really_input_string ic (in_channel_length ic))

let find_fn t name =
  List.find_opt
    (fun (f : Tast.fn) ->
       String.equal f.Tast.name name && f.Tast.fparent = None)
    t.session.Session.program.Tast.fns

let fn_loc t name =
  match find_fn t name with
  | Some f -> Loc.to_string f.Tast.floc
  | None -> ""

(* ── Ops ───────────────────────────────────────────────────────────── *)

(* Every reply is a plist with a :status, so an editor can dispatch on one key
   and never has to guess whether a missing field means failure. *)
let ok fields =
  "(:status \"ok\"" ^ String.concat "" (List.map (fun f -> " " ^ f) fields) ^ ")"

(* Anything the program printed since the last reply rides along with this one.
   An editor that had to ask separately would miss the output an evaluation
   itself caused, which is the output anyone actually wants to see. *)
let with_output t reply =
  match take t with
  | "" -> reply
  | text ->
    let i = String.length reply - 1 in
    String.sub reply 0 i ^ " :output " ^ Wire.quote text ^ ")"

(* The break state rides along with every reply, exactly as the program's own
   output does, and for the same reason: a program can stop at any moment and
   nothing in a request/response protocol will mention it unless every response
   does. An editor that had to *ask* would find out about a stop only when it
   happened to wonder — and the most common moment for a program to stop is the
   instant after an evaluation, which is a reply it is already reading.

   It is the annotation, not the ops, that decides these two fields, so that
   there is one place in the daemon that says whether the program is stopped
   and the break ops cannot disagree with the poll. *)
let with_break t reply =
  let fields =
    match state t with
    | Stopped c -> " :stopped t :condition " ^ Wire.quote c
    | Running -> " :stopped nil"
    (* Unreachable is not "running": the honest shape of "it exited" is
       [:alive nil] from [describe], and claiming a state we could not read
       would be the [ok]-means-probably failure in miniature. *)
    | Unreachable _ -> " :stopped nil"
  in
  String.sub reply 0 (String.length reply - 1) ^ fields ^ ")"

let error ?loc msg =
  "(:status \"error\" :message " ^ Wire.quote msg
  ^ (match loc with None -> "" | Some l -> " :loc " ^ Wire.quote l)
  ^ ")"

let eval t ~code ~origin =
  if not (alive t) then error "the program exited; restart flan dev"
  else
    match Session.eval ~origin t.session code with
    | c when not c.Session.installs ->
      (* Accepted into the session and nothing to send: a declaration the
         program already has, with no body and no new storage. Saying "ok" and
         shipping an empty module would report success for a change that cannot
         have taken effect. *)
      ok
        [ ":names " ^ Wire.strings c.Session.names; ":fns ()";
          ":note " ^ Wire.quote "nothing to install" ]
    | c ->
      t.n <- t.n + 1;
      let out = Filename.concat t.dir (Printf.sprintf "m%d.so" t.n) in
      (* [Build.shared] deletes its own .ll unless asked to keep it, and what it
         keeps is in a working directory named after this process rather than
         after the module. Writing our own copy beside the .so is what makes
         [disassemble] able to show the IR of a body installed ten reloads ago:
         nothing else on this machine still has that text. *)
      let ll = Filename.concat t.dir (Printf.sprintf "m%d.ll" t.n) in
      write_file ll c.Session.ir;
      (match Build.shared ~opts:{ Build.default with Build.dev = true }
               ~ir:c.Session.ir ~out () with
       | timing ->
         (match deliver t out with
          | "ok" ->
            t.gen <- t.gen + 1;
            List.iter
              (fun n ->
                 Hashtbl.replace t.owners n
                   { ogen = t.gen; oso = out; oll = ll; oloc = fn_loc t n })
              c.Session.fns;
            ok
              [ ":names " ^ Wire.strings c.Session.names;
                ":fns " ^ Wire.strings c.Session.fns;
                Printf.sprintf ":ms %.1f"
                  (timing.Build.llc_ms +. timing.Build.link_ms) ]
          | reply -> error ("the program refused the module: " ^ reply)
          | exception Unix.Unix_error (e, _, _) ->
            error
              ("cannot reach the program on " ^ t.agent ^ ": "
               ^ Unix.error_message e))
       | exception Failure m -> error m)
    | exception Loc.Error (l, msg) -> error ~loc:(Loc.to_string l) msg

(* Redefining a name installs a body; evaluating an expression has no name to
   install into, so the module carries a thunk the agent runs once. The value
   comes back through the runtime rather than through this reply, because the
   frame boundary it runs at is the program's to choose. *)
let eval_expr t ~code ~origin =
  if not (alive t) then error "the program exited; restart flan dev"
  else
    match Session.eval_expr ~origin t.session code with
    | c ->
      let before = match result t with Some (g, _) -> g | None -> 0L in
      t.n <- t.n + 1;
      let out = Filename.concat t.dir (Printf.sprintf "e%d.so" t.n) in
      (match Build.shared ~opts:{ Build.default with Build.dev = true }
               ~ir:c.Session.ir ~out () with
       | _ ->
         (match deliver t out with
          | "ok" ->
            let rec wait ms =
              match result t with
              | Some (g, v) when Int64.compare g before > 0 -> Some v
              | _ when ms <= 0 -> None
              | _ ->
                ignore (Unix.select [] [] [] 0.005);
                if alive t then wait (ms - 5) else None
            in
            (match wait 5000 with
             | Some v -> ok [ ":value " ^ Wire.quote v ]
             | None ->
               error
                 "the program did not reach a frame boundary; is it calling \
                  (agent/poll)?")
          | reply -> error ("the program refused the module: " ^ reply)
          | exception Unix.Unix_error (e, _, _) ->
            error ("cannot reach the program: " ^ Unix.error_message e))
       | exception Failure m -> error m)
    | exception Loc.Error (l, msg) -> error ~loc:(Loc.to_string l) msg

let describe t =
  ok
    [ ":fns "
      ^ Wire.strings
          (List.map (fun (f : Tast.fn) -> f.Tast.name)
             t.session.Session.program.Tast.fns);
      ":globals "
      ^ Wire.strings
          (List.map (fun (g : Tast.global) -> g.Tast.gname)
             t.session.Session.program.Tast.globals);
      ":alive " ^ (if alive t then "t" else "nil") ]

(* [describe] answers what exists; this answers what each one *is*. Its own op
   rather than more fields on [describe], because [describe] is polled — an
   editor uses it to drain the program's output — and this is asked once on
   connect and again after each install. Putting signatures on the poll would
   pay for them every time anyone looked at the output buffer.

   One entry per name: (name kind signature loc). Four strings, so the editor
   reads it with [read] and nothing here needs a new wire type. [loc] is empty
   where there is none to give — only [Tast.fn] carries one — and an editor
   that finds it empty must say so rather than guess a file.

   Parameter *names* are not in the Tast, so a signature shows types only. *)
let signature_of_fn (f : Tast.fn) =
  Printf.sprintf "%s [%s] %s" f.Tast.name
    (String.concat " " (List.map Types.to_string f.Tast.params))
    (Types.to_string f.Tast.ret)

let entry ~name ~kind ~sign ~loc =
  Wire.list [ Wire.quote name; Wire.quote kind; Wire.quote sign; Wire.quote loc ]

let defs t =
  let p = t.session.Session.program in
  let fns =
    List.filter_map
      (fun (f : Tast.fn) ->
         match f.Tast.fparent with
         (* A handler-bind clause the checker lifted out. Nobody wrote this
            name, so completing it is noise and jumping to it is meaningless. *)
         | Some _ -> None
         | None ->
           Some
             (entry ~name:f.Tast.name ~kind:"fn" ~sign:(signature_of_fn f)
                ~loc:(Loc.to_string f.Tast.floc)))
      p.Tast.fns
  in
  let globals =
    List.map
      (fun (g : Tast.global) ->
         entry ~name:g.Tast.gname
           ~kind:(if g.Tast.gconst then "const" else "var")
           ~sign:
             (Printf.sprintf "%s %s" g.Tast.gname (Types.to_string g.Tast.gty))
           ~loc:"")
      p.Tast.globals
  in
  let externs =
    List.map
      (fun (e : Tast.extern) ->
         entry ~name:e.Tast.ename ~kind:"extern"
           ~sign:
             (Printf.sprintf "%s [%s] %s" e.Tast.ename
                (String.concat " " (List.map Types.to_string e.Tast.eparams))
                (Types.to_string e.Tast.eret))
           ~loc:"")
      p.Tast.externs
  in
  ok [ ":defs " ^ Wire.list (fns @ globals @ externs) ]

(* What is on offer where the program stopped. [:stopped] and [:condition] are
   not here: the annotation puts them on this reply as it puts them on every
   other, so an editor reads the same two keys whatever it asked. What this op
   adds is the restart names, which cost a second round trip to the program and
   are wanted only when someone is about to choose one. *)
let break t =
  if not (alive t) then error "the program exited; restart flan dev"
  else
    match state t with
    | Running -> ok []
    | Unreachable m -> error ("cannot ask the program whether it stopped: " ^ m)
    | Stopped _ ->
      (match restarts t with
       | Ok names -> ok [ ":restarts " ^ Wire.strings names ]
       | Error m -> error ("the program refused to list its restarts: " ^ m))

(* A choice is validated by the *program*, on its listener thread, against a
   stack the stopped game thread is holding still — not here. The daemon has no
   copy of that stack and anything it checked would be a guess that was true a
   moment ago.

   "ok" therefore means accepted, and says so: the resume happens when the
   stopped thread next comes round its loop, which is microseconds away and
   still not now. An editor that read [ok] as "running again" would poll once,
   find it stopped, and re-open the prompt it had just answered. *)
let choose t ~name =
  if not (alive t) then error "the program exited; restart flan dev"
  else if String.exists (fun c -> Char.code c < 32 || Char.code c = 127) name then
    (* The agent's contract is one line per request. A name carrying a newline
       would be a second request smuggled into the first, and the guarantee is
       this end's to keep: [completing-read] cannot produce one, but the daemon
       is what holds the socket and an editor is not the only thing that can
       speak to it. *)
    error "a restart name cannot contain a control character"
  else
    match ask t ("restart " ^ name) with
    | reply when String.trim reply = "ok" ->
      ok
        [ ":restart " ^ Wire.quote name;
          ":note "
          ^ Wire.quote "accepted; the program resumes at its next pass of the                         break loop" ]
    | reply -> error (String.trim reply)
    | exception Unix.Unix_error (e, _, _) ->
      error ("cannot reach the program: " ^ Unix.error_message e)

(* The other way out. The program exits 134 where it stopped, which ends this
   daemon too — it owns the program's lifetime and has nothing left to serve.
   Refused while running, by the program, for the same reason a restart is. *)
let abort t =
  if not (alive t) then error "the program exited; restart flan dev"
  else
    match ask t "abort" with
    | reply when String.trim reply = "ok" ->
      ok [ ":note " ^ Wire.quote "the program is exiting; flan dev ends with it" ]
    | reply -> error (String.trim reply)
    | exception Unix.Unix_error (e, _, _) ->
      error ("cannot reach the program: " ^ Unix.error_message e)

(* ── Disassembly ───────────────────────────────────────────────────── *)

(* [flan emit --dev] can print the IR of a whole source file, which is a
   different question from the one an editor asks: not "what would this compile
   to" but "what is the code the running program is calling for this name".
   Only the daemon can answer that, because it built every module it sent and
   still has the .ll and the .so on disk.

   What it cannot do is read a cell back. The agent's socket takes a module
   path, [result], [status], [restarts], [restart] and [abort] — there is no
   verb that reports an address, [flan_dev_cell] lives in the program's address
   space, and an expression evaluated through [eval-expr] renders a pointer as
   [<ptr>] on purpose. So the answer is the last module *delivered* for the
   name, and the reply says exactly that rather than implying more; see
   [basis]. The one case that is certain is the case where nothing has been
   delivered at all, and it says that too.

   SBCL's presentation is worth two things here and not a third. Offsets from
   the function's own start rather than file addresses, because an address into
   a .so means nothing to a reader; and labels for branch targets inside the
   function, which is most of the difference between readable and not. The
   third is source interleaving, which SBCL can do because it has the mapping
   and this build has no line tables — so it is refused by name in the reply
   instead of being faked by printing the listing with no source in it. *)

let objdump = try Sys.getenv "FLAN_OBJDUMP" with Not_found -> "objdump"

let run_capture cmd =
  let ic = Unix.open_process_in (cmd ^ " 2>&1") in
  let b = Buffer.create 4096 in
  let chunk = Bytes.create 4096 in
  let rec go () =
    match input ic chunk 0 4096 with
    | 0 -> ()
    | n -> Buffer.add_subbytes b chunk 0 n; go ()
    | exception End_of_file -> ()
  in
  go ();
  let code = match Unix.close_process_in ic with Unix.WEXITED c -> c | _ -> -1 in
  (code, Buffer.contents b)

let contains hay needle =
  let n = String.length needle and h = String.length hay in
  let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
  n = 0 || go 0

(* The IR of one function out of a module's text. [Emit] writes a define's
   closing brace at column 0 and nowhere else, so the end is unambiguous
   without parsing LLVM. One .ll can carry several bodies — [C-c C-k] sends a
   buffer's worth as one module — which is why this slices rather than
   returning the file. *)
let ir_of ~ir name =
  let sym = Emit.fname name in
  let rec take = function
    | [] -> []
    | "}" :: _ -> [ "}" ]
    | l :: rest -> l :: take rest
  in
  let rec find = function
    | [] -> None
    | l :: rest ->
      if String.length l > 7 && String.sub l 0 7 = "define " && contains l (sym ^ "(")
      then Some (String.concat "\n" (take (l :: rest)))
      else find rest
  in
  find (String.split_on_char '\n' ir)

(* objdump's own output, rebased and labelled. A line is
   [" 250:<tab>bytes<tab>mnemonic"], with a continuation line carrying only
   bytes when an instruction's encoding does not fit the column. *)
type insn = { off : int; bytes : string; text : string }

let parse_listing ~sym text =
  let head = "<" ^ sym ^ ">:" in
  let lines = String.split_on_char '\n' text in
  let rec drop = function
    | [] -> []
    | l :: rest -> if contains l head then rest else drop rest
  in
  (* objdump prints a blank line after the last instruction of a symbol and
     then whatever follows it in the section. Stopping at that line is what
     keeps a one-function listing from running into the next function. *)
  let rec upto = function
    | [] -> []
    | l :: rest -> if String.trim l = "" then [] else l :: upto rest
  in
  let body = upto (drop lines) in
  let base = ref None in
  let out = ref [] in
  List.iter
    (fun l ->
       match String.split_on_char '\t' l with
       | addr :: bytes :: rest ->
         let a = String.trim addr in
         let a =
           if String.length a > 0 && a.[String.length a - 1] = ':' then
             String.sub a 0 (String.length a - 1)
           else a
         in
         (match int_of_string_opt ("0x" ^ a) with
          | None -> ()
          | Some n ->
            if !base = None then base := Some n;
            let b = match !base with Some b -> b | None -> n in
            out :=
              { off = n - b; bytes = String.trim bytes;
                text = String.trim (String.concat "\t" rest) }
              :: !out)
       | _ -> ())
    body;
  (List.rev !out, !base <> None)

(* A branch inside the function shows as [<flan.step+0x79>] or, for the entry,
   [<flan.step>]. Those become [L0]..[Ln] in address order, as SBCL labels
   them; anything else objdump annotated — a cell, a plt entry, another
   function — is left exactly as it wrote it. *)
let target_of ~sym text =
  if not (contains text ("<" ^ sym)) then None
  else
    match String.index_opt text '<' with
    | None -> None
    | Some i ->
      let rest = String.sub text i (String.length text - i) in
      if String.length rest < 3 || rest.[String.length rest - 1] <> '>' then None
      else
        let inner = String.sub rest 1 (String.length rest - 2) in
        if String.equal inner sym then Some 0
        else
          let p = String.length sym in
          if String.length inner > p + 1 && String.sub inner 0 (p + 1) = sym ^ "+"
          then
            int_of_string_opt (String.sub inner (p + 1) (String.length inner - p - 1))
          else None

let render_listing ~sym insns =
  let targets =
    List.sort_uniq compare
      (List.filter_map (fun i -> target_of ~sym i.text) insns)
  in
  let label n =
    let rec idx k = function
      | [] -> None
      | x :: r -> if x = n then Some (Printf.sprintf "L%d" k) else idx (k + 1) r
    in
    idx 0 targets
  in
  let b = Buffer.create 4096 in
  List.iter
    (fun i ->
       (match label i.off with
        | Some lb -> Buffer.add_string b (lb ^ ":\n")
        | None -> ());
       let text =
         match target_of ~sym i.text with
         | Some n ->
           (match label n with
            | Some lb ->
              (* [jmp 1d9 <flan.step+0x89>] becomes [jmp L1]. The bare number
                 objdump prints is the address the branch encodes *in the
                 file*, which is the one number on the line that means nothing
                 once the listing is rebased — so it goes with the symbol it
                 duplicates. *)
              let j = String.index i.text '<' in
              let head = String.sub i.text 0 j in
              let k = ref (String.length head) in
              while !k > 0 && head.[!k - 1] = ' ' do decr k done;
              while !k > 0
                    && (match head.[!k - 1] with
                        | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
                        | _ -> false)
              do decr k done;
              String.sub head 0 !k ^ lb
            | None -> i.text)
         | None -> i.text
       in
       if text = "" then
         Buffer.add_string b (Printf.sprintf "  %04x  %s\n" i.off i.bytes)
       else
         Buffer.add_string b
           (Printf.sprintf "  %04x  %-22s %s\n" i.off i.bytes text))
    insns;
  Buffer.contents b

let asm_of ~obj name =
  let sym = "flan." ^ name in
  let code, text =
    run_capture
      (String.concat " "
         [ Filename.quote objdump; "-d";
           "--disassemble=" ^ Filename.quote sym; Filename.quote obj ])
  in
  if code <> 0 then
    Error
      (Printf.sprintf "%s failed on %s (exit %d): %s" objdump obj code
         (String.trim text))
  else
    match parse_listing ~sym text with
    | _, false -> Error (Printf.sprintf "%s found no symbol %s in %s" objdump sym obj)
    | insns, true -> Ok (render_listing ~sym insns)

(* Where a name's body was last built, and how much of that is a claim about
   the running process rather than about this daemon's disk. *)
let basis t name =
  match Hashtbl.find_opt t.owners name with
  | None ->
    ( { ogen = 0; oso = Filename.concat t.dir "program"; oll = t.host_ll;
        oloc = fn_loc t name },
      "the host executable — nothing defining this name has been delivered in \
       this session, so the program's cell still holds this body" )
  | Some o ->
    let m = Filename.basename o.oso in
    ( o,
      match state t with
      | Stopped c ->
        Printf.sprintf
          "%s — delivered and accepted, but the program is stopped on %s and \
           has not reached a frame boundary since, so this is not installed yet"
          m c
      | Running ->
        Printf.sprintf
          "%s — the last module delivered for this name, accepted for install; \
           the program installs it at its next frame boundary and the daemon \
           cannot read the cell back to confirm that it has"
          m
      | Unreachable r ->
        Printf.sprintf
          "%s — the last module delivered for this name; the program is not \
           answering (%s), so whether it installed cannot be said"
          m r )

let kind_of t name =
  let p = t.session.Session.program in
  if List.exists (fun (g : Tast.global) -> String.equal g.Tast.gname name)
       p.Tast.globals
  then Some "a global"
  else if
    List.exists (fun (e : Tast.extern) -> String.equal e.Tast.ename name)
      p.Tast.externs
  then Some "an extern"
  else None

let disassemble t ~name ~form =
  if form <> "ir" && form <> "asm" then
    error
      (Printf.sprintf
         "unknown form %S: disassemble takes :form \"ir\" or :form \"asm\"" form)
  else
    match find_fn t name with
    | None ->
      (match kind_of t name with
       | Some k ->
         error
           (Printf.sprintf
              "%s is %s, not a function: there is no generated code to show for it"
              name k)
       | None -> error (Printf.sprintf "no function named %s in this session" name))
    | Some f ->
      let o, why = basis t name in
      let common =
        [ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form;
          ":generation " ^ string_of_int o.ogen;
          ":signature " ^ Wire.quote (signature_of_fn f);
          ":loc " ^ Wire.quote (Loc.to_string f.Tast.floc);
          ":basis " ^ Wire.quote why ]
      in
      if form = "ir" then
        match read_file o.oll with
        | text ->
          (match ir_of ~ir:text name with
           | Some body ->
             ok (common @ [ ":object " ^ Wire.quote o.oll; ":text " ^ Wire.quote body ])
           | None ->
             error (Printf.sprintf "no define for %s in %s" (Emit.fname name) o.oll))
        | exception Sys_error m ->
          error ("the IR this body was built from is gone: " ^ m)
      else if not (Sys.file_exists o.oso) then
        error ("the object this body was linked into is gone: " ^ o.oso)
      else
        match asm_of ~obj:o.oso name with
        | Ok text ->
          ok
            (common
             @ [ ":object " ^ Wire.quote o.oso;
                 ":note "
                 ^ Wire.quote
                     "source interleaving needs line tables this build does not \
                      emit";
                 ":text " ^ Wire.quote text ])
        | Error m -> error m

let handle t req =
  match Wire.string_field req "op" with
  | Some "eval" ->
    (match Wire.string_field req "code" with
     | Some code ->
       let origin =
         match Wire.string_field req "file" with Some f -> f | None -> "<editor>"
       in
       eval t ~code ~origin
     | None -> error "eval needs :code")
  | Some "eval-expr" ->
    (match Wire.string_field req "code" with
     | Some code ->
       let origin =
         match Wire.string_field req "file" with Some f -> f | None -> "<editor>"
       in
       eval_expr t ~code ~origin
     | None -> error "eval-expr needs :code")
  | Some "describe" -> describe t
  | Some "defs" -> defs t
  | Some "break" -> break t
  | Some "restart" ->
    (match Wire.string_field req "name" with
     | Some name -> choose t ~name
     | None -> error "restart needs :name")
  | Some "abort" -> abort t
  | Some "disassemble" ->
    (match Wire.string_field req "name" with
     | Some name ->
       let form =
         match Wire.string_field req "form" with Some f -> f | None -> "asm"
       in
       disassemble t ~name ~form
     | None -> error "disassemble needs :name")
  | Some "close" -> ok []
  | Some op -> error ("unknown op: " ^ op)
  | None -> error "no :op"

(* ── The loop ──────────────────────────────────────────────────────── *)

(* One connection at a time. An editor is one client, evaluations are
   sequential by nature — each one is checked against the program the last one
   left behind — and a second concurrent evaluation would be racing for the
   same session anyway. *)
(* Returns whether the client asked to end the session. One editor per daemon,
   so [close] shuts the whole thing down rather than waiting for another
   connection nobody is going to make. *)
let serve t fd =
  let rec go () =
    match Wire.recv fd with
    | src ->
      let op, reply =
        match Wire.parse src with
        | req -> (Wire.string_field req "op", handle t req)
        | exception Loc.Error (_, m) -> (None, error ("bad request: " ^ m))
      in
      Wire.send fd (with_output t (with_break t reply));
      if op = Some "close" then true else go ()
    | exception Wire.Closed -> false
    | exception Unix.Unix_error _ -> false
  in
  go ()

let start ~file ~sock =
  let t0 = Unix.gettimeofday () in
  (* Absolute, because every location this daemon ever reports is derived from
     it and an editor is not in this process's working directory. [flan dev
     src/game.flan] run from a project root would otherwise send back
     "src/game.flan:12:7", which the editor can only resolve by guessing which
     directory it was relative to. *)
  let file = try Unix.realpath file with Unix.Unix_error _ -> file in
  let session, l = Session.create ~file in
  let dir =
    Filename.concat (Filename.get_temp_dir_name ())
      (Printf.sprintf "flan-dev-%d" (Unix.getpid ()))
  in
  (try Unix.mkdir dir 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
  let exe = Filename.concat dir "program" in
  (* [keep] so the host's own IR survives the build. It is the text [llc] was
     actually given, not a second emission of it, which is the difference
     between showing what the process was built from and showing what it
     probably was. [Build.executable] leaves it in its own working directory
     under the module's basename; it is moved here so that nothing else in this
     process can reuse the name. *)
  ignore
    (Build.executable
       ~opts:{ Build.default with Build.dev = true; Build.keep = true }
       ~csrcs:l.Load.csrcs ~lflags:l.Load.lflags session.Session.host ~out:exe);
  let host_ll = Filename.concat dir "host.ll" in
  (try
     Sys.rename (Filename.concat (Build.workdir ()) (Filename.basename exe ^ ".ll"))
       host_ll
   with Sys_error _ -> ());
  let agent = Filename.concat dir "agent.sock" in

  (* The program's source names some socket path; the daemon is the one that
     knows where it wants to talk to it, so it overrides through the
     environment. Guessing instead would fail silently — everything compiles,
     the module is built, and nothing ever receives it. *)
  Unix.putenv "FLAN_AGENT_SOCKET" agent;
  (* Through a pipe, so the program's own output can reach an editor instead of
     only the terminal the daemon was started in. *)
  let rd, wr = Unix.pipe ~cloexec:false () in
  let child = Unix.create_process exe [| exe |] Unix.stdin wr Unix.stderr in
  Unix.close wr;
  Unix.set_nonblock rd;

  (* Wait for it to bind before accepting an evaluation. One that arrives first
     would fail for a reason that reads like a compiler bug. *)
  if not (await (fun () -> Sys.file_exists agent)) then begin
    (try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ());
    failwith
      ("the program never listened on " ^ agent
       ^ " — does it call (agent/start ...)?")
  end;

  let t =
    { session; child; agent; dir; stdout = rd; out = Buffer.create 4096; n = 0;
      gen = 0; owners = Hashtbl.create 32; host_ll }
  in
  (try Unix.unlink sock with Unix.Unix_error _ -> ());
  let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
  Unix.bind ls (Unix.ADDR_UNIX sock);
  Unix.listen ls 4;
  Printf.eprintf "flan dev: %s ready on %s (%.0fms)\n%!" file sock
    ((Unix.gettimeofday () -. t0) *. 1000.);
  (* [accept] would block past the program's own exit, so it is waited on with
     a timeout and the child checked each time round: a daemon whose program
     has finished has nothing left to do, and an editor waiting on it would
     wait forever. *)
  let rec accept_loop () =
    if alive t then
      (* The program's pipe is in the same select as the listening socket: it
         has to be drained whether or not an editor is asking for anything. *)
      match Unix.select [ ls; t.stdout ] [] [] 0.2 with
      | [], _, _ -> accept_loop ()
      | ready, _, _ when not (List.mem ls ready) -> drain t; accept_loop ()
      | _ ->
        (match Unix.accept ls with
         | fd, _ ->
           let closed = serve t fd in
           (try Unix.close fd with Unix.Unix_error _ -> ());
           if not closed then accept_loop ()
         | exception Unix.Unix_error (Unix.EINTR, _, _) -> accept_loop ())
      | exception Unix.Unix_error (Unix.EINTR, _, _) -> accept_loop ()
  in
  Fun.protect
    ~finally:(fun () ->
      (try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ());
      (try Unix.close ls with Unix.Unix_error _ -> ());
      (try Unix.close rd with Unix.Unix_error _ -> ());
      (try Unix.unlink sock with Unix.Unix_error _ -> ()))
    accept_loop