libadalang/extensions/ocaml_api/module_struct

module GPRProject = struct
  type project_scenario_variable

  let c_project_scenario_variable : project_scenario_variable structure typ =
    structure "project_scenario_variable"

  let scenario_var_name = field c_project_scenario_variable "name" (ptr char)

  let scenario_var_value = field c_project_scenario_variable "value" (ptr char)

  let () = seal c_project_scenario_variable

  let create_scenario_variable scenario_vars =
    (* One more to store (null, null) *)
    let scenario_vars_len = List.length scenario_vars + 1 in
    let c_scenario_vars =
      (* Allocates a fresh array with given size, fill with zeros. Thus,
         the last cell is already (null, null) *)
      allocate_n c_project_scenario_variable ~count:scenario_vars_len
    in
    let fill_scenario_vars i (name, value) =
      let c_struct = make c_project_scenario_variable in
      let name = char_ptr_of_string name in
      let value = char_ptr_of_string value in
      setf c_struct scenario_var_name name ;
      add_gc_link ~from:c_scenario_vars ~to_:name ;
      setf c_struct scenario_var_value value ;
      add_gc_link ~from:c_scenario_vars ~to_:value ;
      c_scenario_vars +@ i <-@ c_struct
    in
    List.iteri fill_scenario_vars scenario_vars ;
    c_scenario_vars

  (* project_scenario_variable is never wrapped *)
  let project_scenario_variable =
    view
      (ptr c_project_scenario_variable)
      ~read:(fun _ -> assert false)
      ~write:create_scenario_variable

  type string_array

  let c_string_array : string_array structure typ =
    structure "string_array"

  let array_length = field c_string_array "length" int

  let array_c_ptr = field c_string_array "c_ptr" (ptr string)

  let () = seal c_string_array

  let c_free_string_array =
    foreign ~from:c_lib "${capi.get_name("free_string_array")}"
      (ptr c_string_array @-> raisable void)

  let read_string_array c_value =
    let result =
      List.init
        (!@ (c_value |-> array_length))
        (fun i -> (!@ ((!@ (c_value |-> array_c_ptr)) +@ i)))
    in
    c_free_string_array c_value ;
    result

  let write_string_array _value =
    (* Not used for now *)
    assert false

  let string_array = view (ptr c_string_array) ~read:read_string_array ~write:write_string_array

  type t = unit ptr ptr

  let gpr_project_free =
    foreign ~from:c_lib "${capi.get_name("gpr_project_free")}"
      (ptr void @-> raisable void)

  let read c_value =
    let finalise arg =
      gpr_project_free (!@ arg)
    in
    allocate ~finalise (ptr void) c_value

  let write value = (!@ value)

  let c_type = view (ptr void) ~read ~write

  let gpr_project_load =
    foreign ~from:c_lib "${capi.get_name("gpr_project_load")}"
    (string @-> project_scenario_variable @-> string
     @-> string @-> ptr c_type @-> ptr string_array @-> raisable void)

  let gpr_project_create_preprocessor =
    foreign ~from:c_lib "${capi.get_name("gpr_project_create_preprocessor")}"
      (c_type @-> string @-> ptr int @-> raisable FileReader.c_type)

  let load
      ?(scenario_vars = [])
      ?(target = "")
      ?(runtime = "")
      project_file : t =
    (* Use allocate_n to avoid having to give it an initial value *)
    let result = allocate_n ~count:1 c_type in
    let errors = allocate_n ~count:1 string_array in
    gpr_project_load project_file scenario_vars target runtime result errors ;
    (* Not sure what to do with errors here as we already have an exception *)
    !@ result

  let c_source_files =
    foreign ~from:c_lib "${capi.get_name("gpr_project_source_files")}"
      (c_type @-> int @-> ptr void @-> raisable string_array)

  type source_file_mode =
    | Default
    | RootProject
    | WholeProject
    | WholeProjectWithRuntime

  let write_source_file_mode = function
    | Default -> 0
    | RootProject -> 1
    | WholeProject -> 2
    | WholeProjectWithRuntime -> 3

  let source_files ?(mode = Default) gpr_project =
    c_source_files gpr_project (write_source_file_mode mode) null

  type line_mode =
    | DeleteLines
    | BlankLines
    | CommentLines

  let create_preprocessor ?(project = "") ?line_mode gpr_project =
    let line_mode_c =
      match line_mode with
      | Some DeleteLines ->
          allocate int 0
      | Some BlankLines ->
          allocate int 1
      | Some CommentLines ->
          allocate int 2
      | None ->
         from_voidp int null
    in
    gpr_project_create_preprocessor gpr_project project line_mode_c

  let gpr_project_create_unit_provider =
    foreign ~from:c_lib "${capi.get_name("gpr_project_create_unit_provider")}"
      (c_type @-> string @-> raisable UnitProvider.c_type)

  let create_unit_provider ?(project = "") gpr_project =
    let result = gpr_project_create_unit_provider gpr_project project in
    (* The unit provider keeps an internal reference to the project. Use
       the keep argument to simulate the same behaviour and avoid freeing
       the project file too early. *)
    UnitProvider.wrap ~keep:gpr_project result

  let gpr_project_initialize_context =
    foreign ~from:c_lib "${capi.get_name("gpr_project_initialize_context")}"
      ( c_type @-> AnalysisContextStruct.c_type @-> string
        @-> ptr void @-> bool @-> int @-> raisable void )

  let create_analysis_context
      ?(with_trivia = true)
      ?(tab_stop = ${ctx.default_tab_stop})
      ?(project = "")
      gpr_project : analysis_context =
    if tab_stop < 1 then
      raise (Invalid_argument "Invalid tab_stop (positive integer expected)") ;
    let c_context =
      AnalysisContextStruct.allocate_analysis_context ~keep:gpr_project ()
    in
    gpr_project_initialize_context
      gpr_project
      c_context
      project
      Ctypes.null (* TODO: bind the event handlers API to OCaml *)
      with_trivia
      tab_stop ;
    { c_value= c_context
      ; unit_provider= UnitProvider.null }
end