Source file syntax.ml

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 ()