package dune-private-libs

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file syntax.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
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
open! Stdune

module Version = struct
  module T = struct
    type t = int * int

    let compare (major_a, minor_a) (major_b, minor_b) =
      match Int.compare major_a major_b with
      | (Gt | Lt) as ne -> ne
      | Eq -> Int.compare minor_a minor_b

    let to_dyn t =
      let open Dyn.Encoder in
      pair int int t
  end

  include T
  module Infix = Comparator.Operators (T)

  let equal = Infix.equal

  let to_string (a, b) = sprintf "%u.%u" a b

  let hash = Hashtbl.hash

  let encode t = Encoder.string (to_string t)

  let decode : t Decoder.t =
    let open Decoder in
    raw >>| function
    | Atom (loc, A s) -> (
      match Scanf.sscanf s "%u.%u" (fun a b -> (a, b)) with
      | Ok s -> s
      | Error () ->
        User_error.raise ~loc [ Pp.text "Atom of the form NNN.NNN expected" ] )
    | sexp -> User_error.raise ~loc:(Ast.loc sexp) [ Pp.text "Atom expected" ]

  let can_read ~parser_version:(parser_major, parser_minor)
      ~data_version:(data_major, data_minor) =
    let open Int.Infix in
    parser_major = data_major && parser_minor >= data_minor
end

module Supported_versions = struct
  (* The extension supported versions are declared using an explicit list of all
     versions but stored as a map from major versions to maps from minor version
     to dune_lang required versions. For instance, if:

     - version 1.0 of an extension was introduced in Dune 1.4

     - version 1.1 was introduced in Dune 1.6

     - version 1.2 was introduced in Dune 2.3

     - version 2.0 was introduced in Dune 2.4

     we'd have the following map (in associative list syntax):

     {[ [ 1, [ 0, (1, 4); 1, (1, 6); 2, (2, 3) ]; 2, [ 0, (2, 3) ] ] ]} *)
  type t = Version.t Int.Map.t Int.Map.t

  let to_dyn t = Int.Map.to_dyn (Int.Map.to_dyn Version.to_dyn) t

  (* We convert the exposed extension version type: {[ (Version.t * [ `Since of
     Version.t ]) list ]} which is a list of fully qualified versions paired
     with the corresponding dune_lang version. To the internal representation:
     {[ (Version.t Int.Map.t) Int.Map.t ]} which is a list of major versions
     paired with lists of minor versions paires with a dune_lang version. *)
  let make (versions : (Version.t * [ `Since of Version.t ]) list) : t =
    let v =
      List.fold_left versions
        ~init:(Int.Map.empty : t)
        ~f:(fun major_map ((major, minor), `Since lang_ver) ->
          let add_minor minor_map =
            Some (Int.Map.add_exn minor_map minor lang_ver)
          in
          Int.Map.update major_map major ~f:(function
            | Some minor_map -> add_minor minor_map
            | None -> add_minor Int.Map.empty))
    in
    v

  let remove_uncompatible_versions lang_ver =
    Int.Map.filter_map ~f:(fun minors ->
        let minors =
          Int.Map.filter minors ~f:(fun min_lang -> lang_ver >= min_lang)
        in
        Option.some_if (not (Int.Map.is_empty minors)) minors)

  let rec greatest_supported_version ?dune_lang_ver t =
    let open Option.O in
    match dune_lang_ver with
    | Some lang_ver ->
      let compat = remove_uncompatible_versions lang_ver t in
      greatest_supported_version compat
    | None ->
      let* major, minors = Int.Map.max_binding t in
      let* minor, _ = Int.Map.max_binding minors in
      Some (major, minor)

  let get_min_lang_ver t (major, minor) =
    let open Option.O in
    let* minors = Int.Map.find t major in
    Int.Map.find minors minor

  let is_supported t (major, minor) lang_ver =
    match Int.Map.find t major with
    | Some t -> (
      match Int.Map.find t minor with
      | Some min_lang_ver -> lang_ver >= min_lang_ver
      | None -> false )
    | None -> false

  let supported_ranges lang_ver (t : t) =
    let compat = remove_uncompatible_versions lang_ver t in
    Int.Map.to_list compat
    |> List.map ~f:(fun (major, minors) ->
           let max_minor, _ = Option.value_exn (Int.Map.max_binding minors) in
           let lower_bound =
             (* Map 0.0 to 0.1 since 0.0 is not a valid version number *)
             if major = 0 then
               (0, 1)
             else
               (major, 0)
           in
           let upper_bound = (major, max_minor) in
           assert (lower_bound <= upper_bound);
           (lower_bound, upper_bound))
end

type t =
  { name : string
  ; desc : string
  ; key : Version.t Univ_map.Key.t
  ; supported_versions : Supported_versions.t
  }

module Error_msg = struct
  let since t ver ~what =
    Printf.sprintf
      "%s is only available since version %s of %s. Please update your \
       dune-project file to have (lang %s)."
      what (Version.to_string ver) t.desc (Version.to_string ver)
end

module Error = struct
  let since loc t ver ~what =
    User_error.raise ~loc [ Pp.text (Error_msg.since t ver ~what) ]

  let renamed_in loc t ver ~what ~to_ =
    User_error.raise ~loc
      [ Pp.textf "%s was renamed to '%s' in the %s version of %s" what to_
          (Version.to_string ver) t.desc
      ]

  let deleted_in ?(extra_info = "") loc t ?(repl = []) ver ~what =
    User_error.raise ~loc
      ( Pp.concat
          [ Pp.textf "%s was deleted in version %s of %s." what
              (Version.to_string ver) t.desc
          ; ( if extra_info = "" then
              Pp.nop
            else
              Pp.space )
          ; Pp.text extra_info
          ]
      :: repl )
end

module Warning = struct
  let deprecated_in ?(extra_info = "") loc t ?(repl = []) ver ~what =
    User_warning.emit ~loc
      ( Pp.concat
          [ Pp.textf "%s was deprecated in version %s of %s." what
              (Version.to_string ver) t.desc
          ; ( if extra_info = "" then
              Pp.nop
            else
              Pp.space )
          ; Pp.text extra_info
          ]
      :: repl )
end

let create ~name ~desc supported_versions =
  { name
  ; desc
  ; key = Univ_map.Key.create ~name Version.to_dyn
  ; supported_versions = Supported_versions.make supported_versions
  }

let name t = t.name

let check_supported ~dune_lang_ver t (loc, ver) =
  if
    not (Supported_versions.is_supported t.supported_versions ver dune_lang_ver)
  then
    let dune_ver_text v =
      Printf.sprintf "version %s of the dune language" (Version.to_string v)
    in
    let until =
      match Supported_versions.get_min_lang_ver t.supported_versions ver with
      | Some v -> Printf.sprintf " until %s" (dune_ver_text v)
      | None -> ""
    in
    let l =
      Supported_versions.supported_ranges dune_lang_ver t.supported_versions
    in
    let supported =
      ( if List.is_empty l then
        Pp.textf "There are no supported versions of this extension in %s."
      else
        Pp.textf "Supported versions of this extension in %s:" )
        (dune_ver_text dune_lang_ver)
    in
    let message =
      [ Pp.textf "Version %s of %s is not supported%s." (Version.to_string ver)
          t.desc until
      ; supported
      ; Pp.enumerate l ~f:(fun (a, b) ->
            let open Version.Infix in
            if a = b then
              Pp.text (Version.to_string a)
            else
              Pp.textf "%s to %s" (Version.to_string a) (Version.to_string b))
      ]
    in
    let is_error = String.is_empty until || dune_lang_ver >= (2, 5) in
    User_warning.emit ~is_error ~loc message

let greatest_supported_version ?dune_lang_ver t =
  Supported_versions.greatest_supported_version ?dune_lang_ver
    t.supported_versions

let key t = t.key

open Decoder

let set t ver parser = set t.key ver parser

let get_exn t =
  get t.key >>= function
  | Some x -> return x
  | None ->
    let+ context = get_all in
    Code_error.raise "Syntax identifier is unset"
      [ ("name", Dyn.Encoder.string t.name)
      ; ("supported_versions", Supported_versions.to_dyn t.supported_versions)
      ; ("context", Univ_map.to_dyn context)
      ]

let desc () =
  let+ kind = kind in
  match kind with
  | Values (loc, None) -> (loc, "This syntax")
  | Fields (loc, None) -> (loc, "This field")
  | Values (loc, Some s) -> (loc, sprintf "'%s'" s)
  | Fields (loc, Some s) -> (loc, sprintf "Field '%s'" s)

let deleted_in ?(extra_info = "") t ver =
  let open Version.Infix in
  let* current_ver = get_exn t in
  if current_ver < ver then
    return ()
  else
    let* loc, what = desc () in
    Error.deleted_in ~extra_info loc t ver ~what

let deprecated_in ?(extra_info = "") t ver =
  let open Version.Infix in
  let* current_ver = get_exn t in
  if current_ver < ver then
    return ()
  else
    let+ loc, what = desc () in
    Warning.deprecated_in ~extra_info loc t ver ~what

let renamed_in t ver ~to_ =
  let open Version.Infix in
  let* current_ver = get_exn t in
  if current_ver < ver then
    return ()
  else
    let+ loc, what = desc () in
    Error.renamed_in loc t ver ~what ~to_

let since ?(fatal = true) t ver =
  let open Version.Infix in
  let* current_ver = get_exn t in
  if current_ver >= ver then
    return ()
  else
    desc () >>= function
    | loc, what when fatal -> Error.since loc t ver ~what
    | loc, what ->
      User_warning.emit ~loc [ Pp.text (Error_msg.since t ver ~what) ];
      return ()
OCaml

Innovation. Community. Security.