Source file ThunkLuaExistingOutput.ml

(** An interpreter and support modules for built-in Lua types. No Lua functions
    or libraries are accessible, and no userdata. *)
module Builtin = struct
  module T = Lua.Lib.Combine.T1 (Lua.Empty.Type)
  module X = Lua.Lib.WithType (T)
  module L = Lua.Lib.Combine.C1 (X (ThunkLuaLibEmpty.M))
  module I = Lua.MakeInterp (Lua.Parser.MakeStandard) (Lua.MakeEval (T) (L))
  module C = ThunkLuaChunking.Make (I)
  module IoUtils = ThunkLuaUtils.IoUtils' (I)
end

module Make (Params : ThunkLuaParams.S) (I : Lualib.CORE) = struct
  module V = I.V

  let get_unified_existingoutput g =
    match Params.mode with
    | Analyze | Build _ -> ""
    | Unified _ -> begin
        match I.getglobal g (V.string.embed "unified") with
        | V.LuaValueBase.Table t -> (
            match V.Table.find ~key:(V.string.embed "_existingoutput") t with
            | String existingoutput -> existingoutput
            | _ -> invalid_arg "`unified._existingoutput` must be a string")
        | _ -> invalid_arg "`unified` must be a table"
      end
    | Workspace _ -> begin
        match I.getglobal g (V.string.embed "workspace") with
        | V.LuaValueBase.Table t -> (
            match V.Table.find ~key:(V.string.embed "_existingoutput") t with
            | String existingoutput -> existingoutput
            | _ -> invalid_arg "`workspace._existingoutput` must be a string")
        | _ -> invalid_arg "`workspace` must be a table"
      end

  let builtin_data_constructor v =
    (* the depth is to guard against cyclic tables *)
    let rec aux depth (v : Builtin.I.Ast.value) : V.value =
      match (depth, v) with
      | _, _ when depth > 100 -> Nil
      | _, Nil -> Nil
      | _, Number flt -> Number flt
      | _, String string -> String string
      | _, Function _ | _, Userdata _ -> Nil
      | _, Table table ->
          let newtable =
            V.Table.create (Builtin.I.Value.Luahash.length table)
          in
          let rec aux_kv (k, v) =
            let d = depth + 1 in
            let k' = aux d k in
            let v' = aux d v in
            V.Table.bind newtable ~key:k' ~data:v';
            try aux_kv (Builtin.I.Value.Table.next table k)
            with Not_found -> ()
          in
          (try aux_kv (Builtin.I.Value.Table.first table) with Not_found -> ());
          Table newtable
    in
    aux 0 v

  let parse_lua_values (s : string) : (V.value list, string) result =
    let lines = String.split_on_char '\n' s in
    let b = Buffer.create 16 in
    let q : V.value Queue.t = Queue.create () in
    let done_chunk (chunker : Builtin.C.t) =
      let chunk = Buffer.contents b in
      Buffer.clear b;
      let lexbuf = Lexing.from_string chunk in
      match
        Builtin.IoUtils.do_lexbuf ~sourcename:"<unified.existingoutput>"
          ~in_what:"in unified script" chunker.g lexbuf
      with
      | Error (msg, _loc_opt) -> Error ("Lua chunking error: " ^ msg)
      | Ok [] -> Error ("Lua chunk did not produce a value: " ^ chunk)
      | Ok [ single ] ->
          Queue.push (builtin_data_constructor single) q;
          Ok ()
      | Ok (_ :: _) -> Error ("Lua chunk produced multiple values: " ^ chunk)
    in
    let rec aux state lineno rest_lines =
      match (state, rest_lines) with
      | `NeedInit, [] -> Ok ()
      | `NeedInit, line :: rest when String.trim line = "" ->
          (* skip over empty lines if not in middle of a chunk *)
          aux `NeedInit (lineno + 1) rest
      | `NeedInit, line :: rest -> (
          match Builtin.C.init () with
          | `Error msg -> Error ("failed to initialize Lua chunking: " ^ msg)
          | `Init chunked ->
              aux (`Accumulating chunked) lineno (("return " ^ line) :: rest))
      | `Accumulating chunker, [] -> done_chunk chunker
      | `Accumulating chunker, line :: rest -> (
          Buffer.add_string b line;
          Buffer.add_char b '\n';
          let chunked =
            Builtin.C.accumulate ~file:"<unified.existingoutput>"
              ~lex_into_chunks:Builtin.IoUtils.lex_into_chunks chunker lineno
              line
          in
          match chunked with
          | `Done -> (
              match done_chunk chunker with
              | Ok () -> aux `NeedInit (lineno + 1) rest
              | Error msg -> Error msg)
          | `Continued chunked -> aux (`Accumulating chunked) (lineno + 1) rest)
    in
    match aux `NeedInit 1 lines with
    | Ok () -> Ok (List.of_seq (Queue.to_seq q))
    | Error msg -> Error msg

  let existingoutput g =
    let existingoutput = get_unified_existingoutput g in
    match parse_lua_values existingoutput with
    | Ok values -> values
    | Error msg -> [ Nil; V.string.embed msg ]
end