(** The inspector's reader: a value rendered by reading a stopped program's
    memory through the type layouts the compiler computed, with nothing
    compiled.

    What it replaces is a thunk per inspection. A Flan value carries no header,
    so only the compiler knows what the bytes at an address are, and the first
    answer to that was to compile the knowledge into a module — [Render.render]
    over the address, built, loaded, run on the stopped thread, read back. That
    costs a build per question, and it means nothing on this side can *hold* a
    value: the thunk is gone once it has printed. The layouts were never the
    program's to know, though. [Emit.lay] is where both backends get every
    offset and size, and the daemon owns the build, so it can read the bytes
    itself and walk them — the only facts it needs from the program are where a
    root is, what bytes are at an address, and the two things only the runtime
    can answer: whether a pointer may be followed, and what a dyn word is.
    Those are [mem] below, and the agent's [peek], [ptr] and [dyn] verbs.

    The text is [Render.render]'s, byte for byte, because the editor parses it
    back (emacs/flan-inspect.el) and because a locals listing and an
    inspection of the same slot must not read differently. That walk still
    exists — [println] and an evaluated expression's value are rendered at
    compile time — so this is a second walk over the same arms, and each arm
    below names its twin's decisions rather than making its own. What cannot
    drift is shared outright: which types are refused comes from running
    [Render.render] itself over the type ([refusal]), and a struct's name from
    [Render.head], which spells a generic instance [Pair i32]. *)

(* What the reader needs from the stopped program. [read] raises
   [Unreadable] rather than returning garbage for an address that is not
   mapped, which is the agent reading through process_vm_readv. *)
type ptr_state = Live | Dead of string | Unknown

exception Unreadable of string

type mem = {
  read : int -> int -> string;   (* address, length *)
  ptr  : int -> ptr_state;
  dyn  : int64 -> string;
}

type ctx = {
  md      : Emit.m;
  structs : Tast.structure list;
  datas   : Tast.data list;
  unions  : Tast.structure list;
  enums   : (string * (string * int64) list) list;
  mem     : mem;
  (* Bytes already read, by aligned chunk. A struct's fields are neighbours,
     and asking the agent once per scalar would be a round trip per leaf over
     a socket in the two-process daemon. Sound for one walk because the
     program is stopped for all of it. *)
  cache   : (int, string) Hashtbl.t;
}

let make ~(program : Tast.program) ~enums ~mem =
  { md = X86.layout_ctx ~checks:false ~dev:true program;
    structs = program.Tast.structs; datas = program.Tast.datas;
    unions = program.Tast.unions; enums; mem; cache = Hashtbl.create 16 }

let chunk = 256

let read c addr len =
  if len <= 0 then ""
  else
    let base = addr - (addr mod chunk) in
    if addr + len <= base + chunk then begin
      (* A chunk that crosses into an unmapped page fails as a whole, where the
         bytes asked for alone may be fine: fall back to exactly those. *)
      match Hashtbl.find_opt c.cache base with
      | Some s -> String.sub s (addr - base) len
      | None ->
        (match c.mem.read base chunk with
         | s -> Hashtbl.replace c.cache base s; String.sub s (addr - base) len
         | exception Unreadable _ -> c.mem.read addr len)
    end
    else c.mem.read addr len

let u8 c a = Char.code (read c a 1).[0]
let i8 c a = String.get_int8 (read c a 1) 0
let i16 c a = String.get_int16_le (read c a 2) 0
let u16 c a = String.get_uint16_le (read c a 2) 0
let i32 c a = String.get_int32_le (read c a 4) 0
let i64 c a = String.get_int64_le (read c a 8) 0
let ptr c a = Int64.to_int (i64 c a)

(* An integer of kind [k], widened to i64 the way the thunk's [Cast] widens
   it: sign extension for a signed kind, zero extension otherwise. *)
let int c a (k : Types.ikind) : int64 =
  match k with
  | Types.I8 -> Int64.of_int (i8 c a)
  | Types.U8 -> Int64.of_int (u8 c a)
  | Types.I16 -> Int64.of_int (i16 c a)
  | Types.U16 -> Int64.of_int (u16 c a)
  | Types.I32 -> Int64.of_int32 (i32 c a)
  | Types.U32 -> Int64.logand (Int64.of_int32 (i32 c a)) 0xFFFFFFFFL
  | Types.I64 | Types.U64 -> i64 c a

(* ── The text, as the runtime spells it ───────────────────────────────── *)

(* The result buffer's size, and what a value that overran it becomes: cut
   so that "..." still fits, then "..." (runtime/flan_dev.c, [RESULT_MAX]
   and [truncate_value]). One cap per value, where the thunk had one per
   module — a locals listing used to share 4096 bytes between every slot,
   and the slots after the cut fell out of the reply without a word. *)
let cap = 4096

exception Full

let put b s =
  let room = cap - Buffer.length b in
  if String.length s > room then begin
    Buffer.add_string b (String.sub s 0 (max 0 room));
    raise Full
  end
  else Buffer.add_string b s

(* runtime/flan_rt.c's [flan_f64_format]: an unsigned NaN, and C's %g, which
   OCaml's Printf hands to the same printf. *)
let f64 x = if Float.is_nan x then "nan" else Printf.sprintf "%g" x

(* runtime/flan_rt.c's [flan_escape_char], framed in quotes as
   [flan_dev_emit_str] frames it. *)
let quoted s =
  let b = Buffer.create (String.length s + 2) in
  Buffer.add_char b '"';
  String.iter
    (fun ch ->
       match ch with
       | '"' -> Buffer.add_string b "\\\""
       | '\\' -> Buffer.add_string b "\\\\"
       | '\n' -> Buffer.add_string b "\\n"
       | '\t' -> Buffer.add_string b "\\t"
       | '\r' -> Buffer.add_string b "\\r"
       | c when Char.code c < 0x20 -> Buffer.add_string b (Printf.sprintf "\\x%02x" (Char.code c))
       | c -> Buffer.add_char b c)
    s;
  Buffer.add_char b '"';
  Buffer.contents b

(* runtime/flan_dev.c's [flan_dev_emit_u8_char]: the byte's spelling as
   lib/reader.ml's [read_byte] takes it back, or nothing. *)
let u8_char x =
  match x with
  | 32 -> " (\\space)"
  | 9 -> " (\\tab)"
  | 10 -> " (\\newline)"
  | 13 -> " (\\return)"
  | 0 -> " (\\nul)"
  | _ when x < 33 || x > 126 -> ""
  | _ ->
    (match Char.chr x with
     | '(' | ')' | '[' | ']' | '{' | '}' | '"' | ';' | '`' | '~' | ',' -> ""
     | ch -> Printf.sprintf " (\\%c)" ch)

(* ── Which types are refused ──────────────────────────────────────────── *)

(* The refusal [Render.render] would give for a value of [ty], or [None].
   Asked of the walk itself, over a placeholder it never evaluates, so the
   rule — which arms exist, and that a field past the span cap or a level past
   the depth cap is never looked at — has one statement. *)
let refusal c (ty : Types.t) : string option =
  let loc = Loc.unknown in
  let unit_ = { Tast.e = Tast.Unit; ty = Types.Unit; loc } in
  let emit _ = unit_ in
  let rc =
    { Render.structs = c.structs; datas = c.datas; unions = c.unions;
      enums = c.enums;
      emit = { Render.ebytes = emit; estr = emit; ei64 = emit; eu64 = emit;
               ef64 = emit; edyn = emit };
      ptrs = Some { Render.live = (fun _ -> { unit_ with ty = Types.Bool });
                    bytechar = emit; epitaph = emit };
      alloc = (fun _ -> 0) }
  in
  match Render.render rc 0 { Tast.e = Tast.Local 0; ty; loc } with
  | _ -> None
  | exception Loc.Error { Loc.dmsg; _ } -> Some dmsg

(* ── The walk ─────────────────────────────────────────────────────────── *)

let find_struct c n =
  List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname n) c.structs

let find_data c n =
  List.find_opt (fun (u : Tast.data) -> String.equal u.Tast.dname n) c.datas

let size c ty = fst (Emit.lay c.md ty)

let offsets c tys = let _, _, offs = Emit.lay_fields c.md tys in offs

(* Where a data value's payload starts: the second member of [Emit.lay]'s
   { i32 tag, [k x iA] }. *)
let payload_off c (u : Tast.data) =
  let psize, palign = Emit.payload_lay c.md u in
  if psize = 0 then 4
  else
    List.nth
      (offsets c
         [ Types.Int Types.I32;
           Types.Array (Int64.of_int (psize / palign),
                        Types.Int (Emit.int_kind (palign * 8))) ])
      1

let case_offsets c (v : Tast.variant) =
  offsets c (List.map (fun (f : Tast.field) -> f.Tast.fty) v.Tast.vfields)

let option_off c t = List.nth (offsets c [ Types.Int Types.I8; t ]) 1

(* [Render.render]'s arms, in its order and with its text. *)
let rec walk c b depth addr (ty : Types.t) =
  if depth > Render.max_depth then put b "..."
  else
    match ty with
    | Types.Int Types.U64 -> put b (Printf.sprintf "%Lu" (i64 c addr))
    | Types.Int Types.U8 ->
      let x = u8 c addr in
      put b (string_of_int x);
      put b (u8_char x)
    | Types.Int k -> put b (Int64.to_string (int c addr k))
    | Types.Float Types.F32 -> put b (f64 (Int32.float_of_bits (i32 c addr)))
    | Types.Float Types.F64 -> put b (f64 (Int64.float_of_bits (i64 c addr)))
    (* An [i1] in memory is a byte, and a load keeps its low bit. *)
    | Types.Bool -> put b (if u8 c addr land 1 <> 0 then "true" else "false")
    | Types.Unit -> put b "()"
    (* As the runtime spells a dyn char, which [Form.byte_repr] mirrors. *)
    | Types.Char -> put b (Form.byte_repr (Int32.to_int (i32 c addr) land 0x1fffff))
    (* The prelude's String is a (Vec u8), whose header starts with the same
       pointer and length a str is. *)
    | Types.String | Types.Slice (_, Types.Int Types.U8) | Types.Named "String" ->
      let p = ptr c addr and n = Int64.to_int (i64 c (addr + 8)) in
      (* Enough bytes to overrun the cap once quoted, and no more: a string of
         a million bytes is shown as its first few thousand either way. *)
      let n = max 0 (min n cap) in
      put b (quoted (if n = 0 then "" else read c p n))
    (* The members are checked last-declared first, as the thunk's chain of
       comparisons is nested, so a value two members share reads as the later. *)
    | Types.Enum n ->
      let members = try List.assoc n c.enums with Not_found -> [] in
      let v = Int64.of_int32 (i32 c addr) in
      (match List.find_opt (fun (_, m) -> Int64.equal m v) (List.rev members) with
       | Some (name, _) -> put b (":" ^ name)
       | None -> put b (Int64.to_string v))
    | Types.Ptr (_, t) -> pointer c b depth (ptr c addr) t
    | Types.Alloc -> put b "<allocator>"
    | Types.Vec _ -> put b "<vec>"
    | Types.Fn _ -> put b ("<" ^ Types.to_string ty ^ ">")
    | Types.Option t ->
      if i8 c addr <> 0 then begin
        put b "(some ";
        walk c b (depth + 1) (addr + option_off c t) t;
        put b ")"
      end
      else put b "none"
    | Types.Named n when find_data c n <> None ->
      let u = Option.get (find_data c n) in
      let tag = Int32.to_int (i32 c addr) in
      (match List.nth_opt u.Tast.cases tag with
       | Some v when tag >= 0 ->
         let full = Render.case_name n v.Tast.vname in
         if v.Tast.vfields = [] then put b full
         else begin
           let base = addr + payload_off c u in
           let offs = case_offsets c v in
           put b ("(" ^ full ^ " {");
           List.iteri
             (fun i ((f : Tast.field), off) ->
                if i < Render.max_span then begin
                  if i > 0 then put b " ";
                  put b ("." ^ f.Tast.fname ^ " ");
                  walk c b (depth + 1) (base + off) f.Tast.fty
                end)
             (List.combine v.Tast.vfields offs);
           if List.length v.Tast.vfields > Render.max_span then put b " ...";
           put b "})"
         end
       | _ -> put b (Printf.sprintf "<%s tag %d>" n tag))
    | Types.Named n
      when List.exists (fun (u : Tast.structure) -> String.equal u.Tast.sname n)
             c.unions ->
      put b ("<" ^ n ^ " union>")
    | Types.Named n ->
      (match find_struct c n with
       | None -> put b ("<" ^ n ^ ">")
       | Some st ->
         let fields = st.Tast.fields in
         let offs = offsets c (List.map (fun (f : Tast.field) -> f.Tast.fty) fields) in
         put b ("(" ^ Render.head n ^ " {");
         List.iteri
           (fun i ((f : Tast.field), off) ->
              if i < Render.max_span then begin
                if i > 0 then put b " ";
                put b ("." ^ f.Tast.fname ^ " ");
                walk c b (depth + 1) (addr + off) f.Tast.fty
              end)
           (List.combine fields offs);
         if List.length fields > Render.max_span then put b " ...";
         put b "})")
    | Types.Array (n, t) ->
      let n = Int64.to_int n in
      let shown = min n Render.max_span and sz = size c t in
      put b "[";
      for i = 0 to shown - 1 do
        if i > 0 then put b " ";
        walk c b (depth + 1) (addr + (i * sz)) t
      done;
      if n > shown then put b " ...";
      put b "]"
    (* No span cap, as the thunk's loop has none: the value's cap is what
       stops a long slice. *)
    | Types.Slice (_, t) ->
      let p = ptr c addr and n = Int64.to_int (i64 c (addr + 8)) in
      let sz = size c t in
      put b "[";
      for i = 0 to n - 1 do
        if i > 0 then put b " ";
        walk c b (depth + 1) (p + (i * sz)) t
      done;
      put b "]"
    | Types.Dyn -> put b (c.mem.dyn (i64 c addr))
    (* [refusal] turned these away before the walk began. *)
    | t -> put b ("<" ^ Types.to_string t ^ ">")

(* A pointer holding [p]: followed one level deeper if the registry says it
   is live, what died there if it is dead, and its bare shape if the registry
   never saw it — a stack local, a global, a pointer from C, or null. *)
and pointer c b depth p t =
  match c.mem.ptr p with
  | Live -> put b "<ptr "; walk c b (depth + 1) p t; put b ">"
  | Dead why -> put b "<ptr"; put b why; put b ">"
  | Unknown -> put b "<ptr>"

let finish f ty c =
  match refusal c ty with
  | Some why -> Error why
  | None ->
    let b = Buffer.create 64 in
    (match f b with
     | () -> Ok (Buffer.contents b)
     | exception Full ->
       let s = Buffer.contents b in
       Ok (String.sub s 0 (min (String.length s) (cap - 3)) ^ "...")
     | exception Unreadable why -> Error why
     | exception Failure why -> Error why)

(* The value of type [ty] at [addr], as [Render.render] would have printed
   it, or the refusal. A value that could not be read — an address the agent
   found unmapped — is an error too, named, rather than a partial rendering. *)
let render c ~addr (ty : Types.t) : (string, string) result =
  finish (fun b -> walk c b 0 addr ty) ty c

(* A [(Ptr ty)] holding [addr], which is how an address somebody has in hand
   is shown: through the pointer arm, so the registry is asked before a byte
   of it is read and a dead block names what died instead. *)
let render_ptr c ~addr (ty : Types.t) : (string, string) result =
  finish (fun b -> pointer c b 0 addr ty) (Types.Ptr (Types.Mut, ty)) c

(* ── Where a path ends ────────────────────────────────────────────────── *)

(* The address a [Session.step_into] path reaches, and its type.

   The steps are still [Session.step_into]'s: it is the one statement of which
   steps a type admits and how each is refused, and the thunk's addressing was
   built on it. What it produces is an expression over a [Deref] of the root;
   this computes where that expression's value lives instead of compiling it.
   Two checks the compiled thunk made in the program are made here: an index
   into a slice against the slice's length, and a data type's case against its
   tag — a field of the case the value is not in is a payload that is not
   there. *)
let rec place c (e : Tast.expr) : (int, string) result =
  let ( let* ) = Result.bind in
  match e.Tast.e with
  | Tast.Deref { Tast.e = Tast.Int (a, _); _ } -> Ok (Int64.to_int a)
  | Tast.Field (target, i) ->
    let* a = place c target in
    (match target.Tast.ty with
     | Types.Option t -> Ok (if i = 0 then a else a + option_off c t)
     | Types.Named n ->
       (match find_struct c n with
        | Some st ->
          Ok (a + List.nth (offsets c (List.map (fun (f : Tast.field) -> f.Tast.fty)
                                          st.Tast.fields)) i)
        | None -> Error (n ^ " has no layout here"))
     | t -> Error ("no field in " ^ Types.to_string t))
  | Tast.CaseField (target, case, i) ->
    let* a = place c target in
    (match target.Tast.ty with
     | Types.Named n ->
       (match find_data c n with
        | None -> Error (n ^ " has no layout here")
        | Some u ->
          let rec index k = function
            | [] -> None
            | (v : Tast.variant) :: rest ->
              if String.equal v.Tast.vname case then Some (k, v) else index (k + 1) rest
          in
          (match index 0 u.Tast.cases with
           | None -> Error (n ^ " has no case called " ^ case)
           | Some (k, v) ->
             let tag = Int32.to_int (i32 c a) in
             if tag <> k then
               Error
                 (Printf.sprintf
                    "the value is not a %s — its tag says %s — so that case's \
                     fields are not in it"
                    (Render.case_name n case)
                    (match List.nth_opt u.Tast.cases tag with
                     | Some w when tag >= 0 -> Render.case_name n w.Tast.vname
                     | _ -> string_of_int tag))
             else Ok (a + payload_off c u + List.nth (case_offsets c v) i)))
     | t -> Error ("no case field in " ^ Types.to_string t))
  | Tast.Prim (Tast.At, [ target; { Tast.e = Tast.Int (i, _); _ } ]) ->
    let* a = place c target in
    let i = Int64.to_int i in
    (match target.Tast.ty with
     | Types.Array (_, t) -> Ok (a + (i * size c t))
     | Types.Slice (_, t) ->
       let n = Int64.to_int (i64 c (a + 8)) in
       if i >= n then
         Error
           (Printf.sprintf "%d is past the end of a slice of %d elements" i n)
       else Ok (ptr c a + (i * size c t))
     | t -> Error ("no element in " ^ Types.to_string t))
  | _ -> Error "not a place the inspector can find"

let place c e =
  match place c e with
  | r -> r
  | exception Unreadable why -> Error why

(* The root [step_into] walks from: the value of type [ty] at [addr]. *)
let root ~addr (ty : Types.t) : Tast.expr =
  let loc = Loc.unknown in
  { Tast.e =
      Tast.Deref
        { Tast.e = Tast.Int (Int64.of_int addr, Types.I64);
          ty = Types.Ptr (Types.Mut, ty); loc };
    ty; loc }