Source file mreader_extend.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
open Std
open Extend_protocol.Reader

let { Logger.log } = Logger.for_section "Mreader_extend"

type t =
  { name : string;
    args : string list;
    config : Mconfig.t;
    source : Msource.t;
    driver : Extend_driver.t;
    mutable stopped : bool
  }

let print () t = t.name

let incorrect_behavior fn t =
  log ~title:fn "Extension %S has incorrect behavior" t.name

let stop t =
  if t.stopped then log ~title:"stop" "%a: already closed" print t
  else (
    log ~title:"stop" "%a" print t;
    t.stopped <- true;
    Extend_driver.stop t.driver)

let stop_finalise t =
  if not t.stopped then (
    log ~title:"stop_finalise" "leaked process %s" t.name;
    stop t)

let load_source t config source =
  let buffer =
    { path = Mconfig.filename config;
      flags = t.args;
      text = Msource.text source
    }
  in
  match Extend_driver.reader t.driver (Req_load buffer) with
  | Res_loaded -> Some t
  | _ ->
    Extend_driver.stop t.driver;
    incorrect_behavior "load_source" t;
    None

let start name args config source =
  let section = "(ext)" ^ name in
  let notify str = Logger.notify ~section "%s" str in
  let debug str = Logger.log ~section:"reader" ~title:section "%s" str in
  let driver = Extend_driver.run ~notify ~debug name in
  let process = { name; args; config; source; driver; stopped = false } in
  Gc.finalise stop_finalise process;
  load_source process config source

let parsetree = function
  | Signature sg -> `Interface sg
  | Structure str -> `Implementation str

let parse ?for_completion t =
  log ~title:"parse" "?for_completion:%a %a"
    (Option.print Msource.print_position)
    for_completion print t;
  assert (not t.stopped);
  match
    Extend_driver.reader t.driver
      (match for_completion with
      | None -> Req_parse
      | Some pos ->
        let pos =
          Msource.get_lexing_pos t.source
            ~filename:(Mconfig.filename t.config)
            pos
        in
        Req_parse_for_completion pos)
  with
  | Res_parse ast -> Some (`No_labels false, parsetree ast)
  | Res_parse_for_completion (info, ast) ->
    Some (`No_labels (not info.complete_labels), parsetree ast)
  | _ ->
    incorrect_behavior "parse" t;
    None

let reconstruct_identifier pos t =
  log ~title:"reconstruct_identifier" "%a %a" Lexing.print_position pos print t;
  match Extend_driver.reader t.driver (Req_get_ident_at pos) with
  | Res_get_ident_at ident -> Some ident
  | _ ->
    incorrect_behavior "reconstruct_identifier" t;
    None

let attr_cleaner =
  let open Ast_mapper in
  let attributes mapper attrs =
    let not_merlin_attribute attr =
      let name, _ = Ast_helper.Attr.as_tuple attr in
      not (String.is_prefixed ~by:"merlin." name.Location.txt)
    in
    let attrs = List.filter ~f:not_merlin_attribute attrs in
    default_mapper.attributes mapper attrs
  in
  { default_mapper with attributes }

let clean_tree =
  let open Ast_mapper in
  function
  | Pretty_case_list x -> Pretty_case_list (attr_cleaner.cases attr_cleaner x)
  | Pretty_core_type x -> Pretty_core_type (attr_cleaner.typ attr_cleaner x)
  | Pretty_expression x -> Pretty_expression (attr_cleaner.expr attr_cleaner x)
  | Pretty_pattern x -> Pretty_pattern (attr_cleaner.pat attr_cleaner x)
  | Pretty_signature x ->
    Pretty_signature (attr_cleaner.signature attr_cleaner x)
  | Pretty_structure x ->
    Pretty_structure (attr_cleaner.structure attr_cleaner x)
  | Pretty_toplevel_phrase (Parsetree.Ptop_def x) ->
    let x = attr_cleaner.structure attr_cleaner x in
    Pretty_toplevel_phrase (Parsetree.Ptop_def x)
  | Pretty_toplevel_phrase (Parsetree.Ptop_dir _) as tree -> tree

let print_pretty tree t =
  log ~title:"print_pretty" "TODO %a" print t;
  let tree = clean_tree tree in
  match Extend_driver.reader t.driver (Req_pretty_print tree) with
  | Res_pretty_print str -> Some str
  | _ ->
    incorrect_behavior "pretty_print" t;
    None

let print_outcomes ts t =
  log ~title:"print_outcomes" "TODO %a" print t;
  match ts with
  | [] -> Some []
  | ts -> (
    match Extend_driver.reader t.driver (Req_print_outcome ts) with
    | Res_print_outcome ts -> Some ts
    | _ ->
      incorrect_behavior "print_batch_outcome" t;
      None)

let print_outcome o t =
  log ~title:"print_outcome" "TODO %a" print t;
  match Extend_driver.reader t.driver (Req_print_outcome [ o ]) with
  | Res_print_outcome [ o ] -> Some o
  | _ ->
    incorrect_behavior "print_batch_outcome" t;
    None