Source file `cms_format.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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*           Mark Shinwell and Leo White, Jane Street Europe              *)
(*                   Fabrice Le Fessant, INRIA Saclay                     *)
(*                                                                        *)
(*   Copyright 2023 Jane Street Group LLC                                 *)
(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** cms and cmsi files format. *)

module Uid = Shape.Uid

let read_magic_number ic =
  let len_magic_number = String.length Config.cms_magic_number in
  really_input_string ic len_magic_number

type cms_infos = {
  cms_modname : Compilation_unit.t;
  cms_comments : (string * Location.t) list;
  cms_sourcefile : string option;
  cms_builddir : string;
  cms_source_digest : Digest.t option;
  cms_initial_env : Env.t option;
  cms_uid_to_loc : string Location.loc Shape.Uid.Tbl.t;
  cms_uid_to_attributes : Parsetree.attributes Shape.Uid.Tbl.t;
  cms_shape_format : Clflags.shape_format;
  cms_impl_shape : Shape.t option; (* None for mli *)
  cms_ident_occurrences :
    (Longident.t Location.loc * Shape_reduce.result) array;
  cms_declaration_dependencies :
    (Cmt_format.dependency_kind * Uid.t * Uid.t) list;
  cms_externals: Vicuna_value_shapes.extfun array;
}

type error =
Not_a_shape of string

exception Error of error

let input_cms ic = (input_value ic : cms_infos)

let output_cms oc cms =
  output_string oc Config.cms_magic_number;
  output_value oc (cms : cms_infos)

let read filename =
  let ic = open_in_bin filename in
  Misc.try_finally
    ~always:(fun () -> close_in ic)
    (fun () ->
       let magic_number = read_magic_number ic in
        if magic_number = Config.cms_magic_number then
          input_cms ic
        else
          raise (Error (Not_a_shape filename))
    )

let toplevel_attributes = ref []

let register_toplevel_attributes uid ~attributes ~loc =
  let loc : _ Location.loc = { txt = ""; loc } in
  toplevel_attributes := (uid, loc, attributes) :: !toplevel_attributes

let uid_tables_of_binary_annots binary_annots =
  let cms_uid_to_loc = Types.Uid.Tbl.create 42 in
  let cms_uid_to_attributes = Types.Uid.Tbl.create 42 in
  List.iter (fun (uid, loc, attrs) ->
    Types.Uid.Tbl.add cms_uid_to_loc uid loc;
    Types.Uid.Tbl.add cms_uid_to_attributes uid attrs)
    !toplevel_attributes;
  Cmt_format.iter_declarations binary_annots
    ~f:(fun uid decl ->
      let loc = Typedtree.loc_of_decl ~uid decl in
      let attrs =
        match decl with
        | Value v -> v.val_attributes
        | Value_binding v -> v.vb_attributes
        | Type v -> v.typ_attributes
        | Constructor v -> v.cd_attributes
        | Extension_constructor v -> v.ext_attributes
        | Label v -> v.ld_attributes
        | Module v -> v.md_attributes
        | Module_substitution v -> v.ms_attributes
        | Module_binding v -> v.mb_attributes
        | Module_type v -> v.mtd_attributes
        | Class v -> v.ci_attributes
        | Class_type v -> v.ci_attributes
        | Jkind v -> v.jkind_attributes
      in
      Types.Uid.Tbl.add cms_uid_to_loc uid loc;
      Types.Uid.Tbl.add cms_uid_to_attributes uid attrs
    );
  cms_uid_to_loc, cms_uid_to_attributes

let externals_of_binary_annots binary_annots =
  match binary_annots with
  | Cmt_format.Implementation str ->
    Vicuna_traverse_typed_tree.extract_from_typed_tree str |> Array.of_list
  | _ -> [| |]

let save_cms target modname binary_annots initial_env shape
  cms_declaration_dependencies =
  if (!Clflags.binary_annotations_cms && not !Clflags.print_types) then begin
    Misc.output_to_file_via_temporary
       ~mode:[Open_binary] (Unit_info.Artifact.filename target)
       (fun _temp_file_name oc ->
        (* We use the raw_source_file because the original_source_file may not
           exist (or may have changed), so computing the digest may fail or
           produce inconsistent results. Merlin expects the cms_sourcefile to be
           the file we computed the digest of, which is why we use the
           raw_source_file for that as well. *)
        let sourcefile = Unit_info.Artifact.raw_source_file target in
        let source_digest = Option.map Digest.file sourcefile in
        let cms_ident_occurrences, cms_initial_env =
          if !Clflags.store_occurrences then
            let cms_ident_occurrences = Cmt_format.index_occurrences binary_annots in
            let cms_initial_env = if Cmt_format.need_to_clear_env
              then Env.keep_only_summary initial_env else initial_env in
            cms_ident_occurrences, Some cms_initial_env
          else
            [| |], None
         in
         let cms_uid_to_loc, cms_uid_to_attributes =
           uid_tables_of_binary_annots binary_annots
         in
         let cms_externals = externals_of_binary_annots binary_annots in
         let cms = {
           cms_modname = modname;
              (* XXX merlin: upstream does
                 `cms_comments = Lexer.comments ()`
                 here.  But we don't seem to have the same lexer, so we can't
                 do that straightforwardly.  On the other hand, this function
                 should never be called by merlin, so it doesn't matter, right?
              *)
           cms_comments = [];
           cms_sourcefile = sourcefile;
           cms_builddir = Location.rewrite_absolute_path (Sys.getcwd ());
           cms_source_digest = source_digest;
           cms_initial_env;
           cms_uid_to_loc;
           cms_uid_to_attributes;
           cms_shape_format = !Clflags.shape_format;
           cms_impl_shape = shape;
           cms_ident_occurrences;
           cms_declaration_dependencies;
           cms_externals;
         } in
         output_cms oc cms)
  end

let clear () = ()

let shape_format_to_string =
  function
  | Clflags.Old_merlin -> "old-merlin"
  | Clflags.Debugging_shapes -> "debugging-shapes"
Source file cms_format.ml

Source file `cms_format.ml`
