libadalang/extensions/ocaml_api/module_struct

## vim: filetype=ocaml

module TargetInformation = struct
  let c_free =
    foreign ~from:c_lib "ada_target_info_free"
      (ptr void @-> raisable void)

  type t = unit ptr ptr

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

  let write value = (!@ value)

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

  let load =
    foreign ~from:c_lib "ada_target_info_load"
      (string @-> raisable c_type)

  let c_set =
    foreign ~from:c_lib "ada_target_info_set"
      (AnalysisContextStruct.c_type @-> c_type @-> raisable void)

  let set ctx info = c_set ctx.c_value info
end

module GPROptionsStruct : sig
  type t
  val c_type : t typ
  val create : unit -> t
  val add_switch : t -> int -> string -> string -> bool -> unit
end = struct
  type t = unit ptr ptr

  let c_free =
    foreign ~from:c_lib "ada_gpr_options_free"
      (ptr void @-> raisable void)

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

  let write value = (!@ value)

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

  let create =
    foreign ~from:c_lib "${capi.get_name('gpr_options_create')}"
      (void @-> raisable c_type)

  let add_switch =
    foreign ~from:c_lib "${capi.get_name('gpr_options_add_switch')}"
      (c_type @-> int @-> string @-> string @-> bool @-> raisable void)
end

module GPROptions = struct
  type t = GPROptionsStruct.t

  type gpr_option =
    | AP
    | Autoconf
    | Config
    | Db
    | DbMinus
    | ImplicitWith
    | ResolveLinks
    | NoProject
    | P
    | PrintGPRRegistry
    | RelocateBuildTree
    | RootDir
    | RTS
    | SrcSubdirs
    | Subdirs
    | Target
    | X

  let c_gpr_option = function
    | AP -> 0
    | Autoconf -> 1
    | Config -> 2
    | Db -> 3
    | DbMinus -> 4
    | ImplicitWith -> 5
    | ResolveLinks -> 6
    | NoProject -> 7
    | P -> 8
    | PrintGPRRegistry -> 9
    | RelocateBuildTree -> 10
    | RootDir -> 11
    | RTS -> 12
    | SrcSubdirs -> 13
    | Subdirs -> 14
    | Target -> 15
    | X -> 16

  let create () = GPROptionsStruct.create ()

  let add_switch
        switch
        ?(param = "")
        ?(index = "")
        ?(override = false)
        gpr_options =
    GPROptionsStruct.add_switch
      gpr_options (c_gpr_option switch) param index override

  let quick_create
        ?(scenario_vars=[])
        ?target
        ?runtime
        project =
    let opts = GPROptionsStruct.create () in
    add_switch P ~param:project opts;
    List.iter
      (fun (k, v) -> add_switch X ~param:(k ^ "=" ^ v) opts)
      scenario_vars ;
    ( match target with
      | Some "" | None -> ()
      | Some target -> add_switch Target ~param:target opts ) ;
    ( match runtime with
      | Some "" | None -> ()
      | Some rts -> add_switch RTS ~param:rts opts) ;
    opts

end

module GPRProject = struct
  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")}"
    (GPROptionsStruct.c_type @-> bool @-> 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 ?(ada_only = false) options : 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 options ada_only 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
    | EmptyCommentLines

  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
      | Some EmptyCommentLines ->
          allocate int 3
      | 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 = ${cfg.library.defaults.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