Refactor syntax versioning management

Now, the version of the main language as well as the version of
extensions is passed through the user context of sexp parsers.

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>
This commit is contained in:
Jeremie Dimino 2018-06-19 13:02:35 +01:00
parent 2d1765285a
commit 43f274b323
9 changed files with 226 additions and 135 deletions

View File

@ -122,64 +122,94 @@ type t =
}
module Lang = struct
type t = Syntax.Version.t * Stanza.Parser.t list
type t =
{ syntax : Syntax.t
; stanzas : Stanza.Parser.t list
}
let make ver f = (ver, f)
type instance =
{ lang : t
; version : Syntax.Version.t
}
let langs = Hashtbl.create 32
let register name versions =
let register syntax stanzas =
let name = Syntax.name syntax in
if Hashtbl.mem langs name then
Exn.code_error "Dune_project.Lang.register: already registered"
[ "name", Sexp.To_sexp.string name ];
Hashtbl.add langs name (Syntax.Versioned_parser.make versions)
Hashtbl.add langs name { syntax; stanzas }
let parse first_line =
let { Dune_lexer.
lang = (name_loc, name)
lang = (name_loc, name)
; version = (ver_loc, ver)
} = first_line
in
let ver =
Sexp.Of_sexp.parse Syntax.Version.t Univ_map.empty
(Atom (ver_loc, Sexp.Atom.of_string ver)) in
(Atom (ver_loc, Sexp.Atom.of_string ver))
in
match Hashtbl.find langs name with
| None ->
Loc.fail name_loc "Unknown language %S.%s" name
(hint name (Hashtbl.keys langs))
| Some versions ->
Syntax.Versioned_parser.find_exn versions
~loc:ver_loc ~data_version:ver
| Some t ->
Syntax.check_supported t.syntax (ver_loc, ver);
{ lang = t
; version = ver
}
let latest name =
let versions = Option.value_exn (Hashtbl.find langs name) in
Syntax.Versioned_parser.last versions
let version = fst
let get_exn name =
let lang = Option.value_exn (Hashtbl.find langs name) in
{ lang
; version = Syntax.greatest_supported_version lang.syntax
}
end
module Extension = struct
type t = Syntax.Version.t * Stanza.Parser.t list Sexp.Of_sexp.t
type t =
{ syntax : Syntax.t
; stanzas : Stanza.Parser.t list Sexp.Of_sexp.t
}
let make ver f = (ver, f)
type instance =
{ extension : t
; version : Syntax.Version.t
; loc : Loc.t
; parse_args : Stanza.Parser.t list Sexp.Of_sexp.t -> Stanza.Parser.t list
}
let extensions = Hashtbl.create 32
let register name versions =
let register syntax stanzas =
let name = Syntax.name syntax in
if Hashtbl.mem extensions name then
Exn.code_error "Dune_project.Extension.register: already registered"
[ "name", Sexp.To_sexp.string name ];
Hashtbl.add extensions name (Syntax.Versioned_parser.make versions)
Hashtbl.add extensions name { syntax; stanzas }
let lookup (name_loc, name) (ver_loc, ver) =
let instantiate ~loc ~parse_args (name_loc, name) (ver_loc, ver) =
match Hashtbl.find extensions name with
| None ->
Loc.fail name_loc "Unknown extension %S.%s" name
(hint name (Hashtbl.keys extensions))
| Some versions ->
Syntax.Versioned_parser.find_exn versions ~loc:ver_loc ~data_version:ver
| Some t ->
Syntax.check_supported t.syntax (ver_loc, ver);
{ extension = t
; version = ver
; loc
; parse_args
}
end
let make_parsing_context ~(lang : Lang.instance) ~extensions =
let acc = Univ_map.singleton (Syntax.key lang.lang.syntax) lang.version in
List.fold_left extensions ~init:acc
~f:(fun acc (ext : Extension.instance) ->
Univ_map.add acc (Syntax.key ext.extension.syntax) ext.version)
let key = Univ_map.Key.create ()
let set t = Sexp.Of_sexp.set key t
let get_exn () =
@ -197,12 +227,15 @@ let get_local_path p =
| Local p -> p
let anonymous = lazy (
let lang = Lang.get_exn "dune" in
let parsing_context = make_parsing_context ~lang ~extensions:[] in
{ kind = Dune
; name = Name.anonymous_root
; packages = Package.Name.Map.empty
; root = get_local_path Path.root
; version = None
; stanza_parser = Sexp.Of_sexp.sum (snd (Lang.latest "dune"))
; stanza_parser =
Sexp.Of_sexp.(set_many parsing_context (sum lang.lang.stanzas))
; project_file = None
})
@ -230,7 +263,7 @@ let name ~dir ~packages =
| Some x -> return x
| None -> return (default_name ~dir ~packages)
let parse ~dir ~lang_stanzas ~packages ~file =
let parse ~dir ~lang ~packages ~file =
record
(name ~dir ~packages >>= fun name ->
field_o "version" string >>= fun version ->
@ -238,41 +271,55 @@ let parse ~dir ~lang_stanzas ~packages ~file =
(loc >>= fun loc ->
located string >>= fun name ->
located Syntax.Version.t >>= fun ver ->
Extension.lookup name ver >>= fun stanzas ->
return (snd name, (loc, stanzas)))
(* We don't parse the arguments quite yet as we want to set
the version of extensions before parsing them. *)
capture >>= fun parse_args ->
return (Extension.instantiate ~loc ~parse_args name ver))
>>= fun extensions ->
let extensions_stanzas =
match String.Map.of_list extensions with
| Error (name, _, (loc, _)) ->
Loc.fail loc "Extension %S specified for the second time." name
| Ok _ ->
List.concat_map extensions ~f:(fun (_, (_, x)) -> x)
in
return
{ kind = Dune
; name
; root = get_local_path dir
; version
; packages
; stanza_parser = Sexp.Of_sexp.sum (lang_stanzas @ extensions_stanzas)
; project_file = Some file
})
match
String.Map.of_list
(List.map extensions ~f:(fun (e : Extension.instance) ->
(Syntax.name e.extension.syntax, e.loc)))
with
| Error (name, _, loc) ->
Loc.fail loc "Extension %S specified for the second time." name
| Ok _ ->
let parsing_context = make_parsing_context ~lang ~extensions in
let stanzas =
List.concat
(lang.lang.stanzas ::
List.map extensions ~f:(fun (ext : Extension.instance) ->
ext.parse_args
(Sexp.Of_sexp.set_many parsing_context ext.extension.stanzas)))
in
return
{ kind = Dune
; name
; root = get_local_path dir
; version
; packages
; stanza_parser = Sexp.Of_sexp.(set_many parsing_context (sum stanzas))
; project_file = Some file
})
let load_dune_project ~dir packages =
let fname = Path.relative dir filename in
Io.with_lexbuf_from_file fname ~f:(fun lb ->
let lang_stanzas = Lang.parse (Dune_lexer.first_line lb) in
let lang = Lang.parse (Dune_lexer.first_line lb) in
let sexp = Sexp.Parser.parse lb ~mode:Many_as_one in
Sexp.Of_sexp.parse (parse ~dir ~lang_stanzas ~packages ~file:fname)
Sexp.Of_sexp.parse (parse ~dir ~lang ~packages ~file:fname)
Univ_map.empty sexp)
let make_jbuilder_project ~dir packages =
let lang = Lang.get_exn "dune" in
let parsing_context = make_parsing_context ~lang ~extensions:[] in
{ kind = Jbuilder
; name = default_name ~dir ~packages
; root = get_local_path dir
; version = None
; packages
; stanza_parser = Sexp.Of_sexp.sum (snd (Lang.latest "dune"))
; stanza_parser =
Sexp.Of_sexp.(set_many parsing_context (sum lang.lang.stanzas))
; project_file = None
}
@ -311,8 +358,8 @@ let project_file t =
| Some file -> file
| None ->
let file = Path.relative (Path.of_local t.root) filename in
let maj, min = fst (Lang.latest "dune") in
let s = sprintf "(lang dune %d.%d)" maj min in
let ver = (Lang.get_exn "dune").version in
let s = sprintf "(lang dune %s)" (Syntax.Version.to_string ver) in
notify_user
(sprintf "creating file %s with this contents: %s"
(Path.to_string_maybe_quoted file) s);

View File

@ -41,42 +41,25 @@ type t = private
}
module Lang : sig
(** One version of a language *)
type t
(** [make version stanzas_parser] defines one version of a
language. Users will select this language by writing:
(** [register id stanzas_parser] register a new language. Users will
select this language by writing:
{[ (lang <name> <version>) ]}
as the first line of their [dune-project] file. [stanza_parsers]
defines what stanzas the user can write in [dune] files. *)
val make : Syntax.Version.t -> Stanza.Parser.t list -> t
val version : t -> Syntax.Version.t
(** Register all the supported versions of a language *)
val register : string -> t list -> unit
(** Latest version of the following language *)
val latest : string -> t
val register : Syntax.t -> Stanza.Parser.t list -> unit
end
module Extension : sig
(** One version of an extension *)
type t
(** [make version parser] defines one version of an extension. Users will
(** [register id parser] registers a new extension. Users will
enable this extension by writing:
{[ (using <name> <version> <args>) ]}
in their [dune-project] file. [parser] is used to describe
what [<args>] might be. *)
val make : Syntax.Version.t -> Stanza.Parser.t list Sexp.Of_sexp.t -> t
(** Register all the supported versions of an extension *)
val register : string -> t list -> unit
what [<args>] might be. *)
val register : Syntax.t -> Stanza.Parser.t list Sexp.Of_sexp.t -> unit
end
(** Load a project description from the following directory. [files]

View File

@ -22,6 +22,14 @@ module Backend = struct
let loc t = t.loc
(* The syntax of the driver sub-system is part of the main dune
syntax, so we simply don't create a new one.
If we wanted to make the ppx system an extension, then we
would create a new one.
*)
let syntax = Jbuild.syntax
open Sexp.Of_sexp
let parse =
@ -41,11 +49,6 @@ module Backend = struct
; generate_runner
; extends
})
let parsers =
Syntax.Versioned_parser.make
[ (1, 0), parse
]
end
type t =
@ -125,6 +128,8 @@ include Sub_system.Register_end_point(
let loc t = t.loc
let backends t = Option.map t.backend ~f:(fun x -> [x])
let syntax = Jbuild.syntax
open Sexp.Of_sexp
let parse =
@ -145,11 +150,6 @@ include Sub_system.Register_end_point(
; backend
; libraries
})
let parsers =
Syntax.Versioned_parser.make
[ (1, 0), parse
]
end
let gen_rules c ~(info:Info.t) ~backends =

View File

@ -20,12 +20,11 @@ let parse_sub_systems sexps =
Loc.fail loc "%S present twice" (Sub_system_name.to_string name))
|> Sub_system_name.Map.mapi ~f:(fun name (_, version, data) ->
let (module M) = Jbuild.Sub_system_info.get name in
let vloc, ver = version in
let parser =
Syntax.Versioned_parser.find_exn M.parsers ~loc:vloc
~data_version:ver
Syntax.check_supported M.syntax version;
let parsing_context =
Univ_map.singleton (Syntax.key M.syntax) (snd version)
in
M.T (Sexp.Of_sexp.parse parser Univ_map.empty data))
M.T (Sexp.Of_sexp.parse M.parse parsing_context data))
let of_sexp =
let open Sexp.Of_sexp in

View File

@ -5,6 +5,12 @@ open Sexp.Of_sexp
syntax for the various supported version of the specification.
*)
let syntax =
Syntax.create ~name:"dune"
[ (0, 0) (* Jbuild syntax *)
; (1, 0)
]
(* Deprecated *)
module Jbuild_version = struct
type t =
@ -575,9 +581,10 @@ module Sub_system_info = struct
module type S = sig
type t
type sub_system += T of t
val name : Sub_system_name.t
val loc : t -> Loc.t
val parsers : t Sexp.Of_sexp.t Syntax.Versioned_parser.t
val name : Sub_system_name.t
val loc : t -> Loc.t
val syntax : Syntax.t
val parse : t Sexp.Of_sexp.t
end
let all = Sub_system_name.Table.create ~default_value:None
@ -588,8 +595,6 @@ module Sub_system_info = struct
module Register(M : S) : sig end = struct
open M
let parse = snd (Syntax.Versioned_parser.last M.parsers)
let () =
match Sub_system_name.Table.get all name with
| Some _ ->
@ -1346,10 +1351,7 @@ module Stanzas = struct
]
let () =
let open Dune_project.Lang in
register "dune"
[ make (1, 0) dune
]
Dune_project.Lang.register syntax dune
exception Include_loop of Path.t * (Loc.t * Path.t) list

View File

@ -2,6 +2,11 @@
open Import
(** Syntax identifier for the Dune language. [(0, X)] correspond to
the Jbuild language while versions from [(1, 0)] correspond to the
Dune one. *)
val syntax : Syntax.t
(** Ppx preprocessors *)
module Pp : sig
type t = private string
@ -139,10 +144,14 @@ module Sub_system_info : sig
(** Name of the sub-system *)
val name : Sub_system_name.t
(** Location of the S-expression passed to [of_sexp] or [short]. *)
(** Location of the parameters in the jbuild/dune file. *)
val loc : t -> Loc.t
val parsers : t Sexp.Of_sexp.t Syntax.Versioned_parser.t
(** Syntax for jbuild/dune files *)
val syntax : Syntax.t
(** Parse parameters written by the user in jbuid/dune files *)
val parse : t Sexp.Of_sexp.t
end
module Register(M : S) : sig end

View File

@ -32,6 +32,14 @@ module Driver = struct
let loc t = t.loc
(* The syntax of the driver sub-system is part of the main dune
syntax, so we simply don't create a new one.
If we wanted to make the ppx system an extension, then we
would create a new one.
*)
let syntax = Jbuild.syntax
open Sexp.Of_sexp
let parse =
@ -49,10 +57,6 @@ module Driver = struct
; main
; replaces
})
let parsers =
Syntax.Versioned_parser.make
[ (1, 0), parse ]
end
(* The [lib] field is lazy so that we don't need to fill it for

View File

@ -23,38 +23,71 @@ module Version = struct
pa = da && db <= pb
end
module Versioned_parser = struct
type 'a t = (int * 'a) Int.Map.t
module Supported_versions = struct
type t = int Int.Map.t
let make l =
if List.is_empty l then
Exn.code_error "Syntax.Versioned_parser.make got empty list" [];
let make l : t =
match
List.map l ~f:(fun ((major, minor), p) -> (major, (minor, p)))
List.map l ~f:(fun (major, minor) -> (major, minor))
|> Int.Map.of_list
with
| Ok x -> x
| Error _ ->
Exn.code_error
"Syntax.Versioned_parser.make"
[ "versions", Sexp.To_sexp.list Version.sexp_of_t (List.map l ~f:fst) ]
"Syntax.create"
[ "versions", Sexp.To_sexp.list Version.sexp_of_t l ]
let last t =
let major, (minor, p) = Option.value_exn (Int.Map.max_binding t) in
((major, minor), p)
let greatest_supported_version t = Option.value_exn (Int.Map.max_binding t)
let find_exn t ~loc ~data_version:(major, minor) =
match
Option.bind (Int.Map.find t major) ~f:(fun (minor', p) ->
Option.some_if (minor' >= minor) p)
with
| None ->
Loc.fail loc "Version %s is not supported.\n\
Supported versions:\n\
%s"
(Version.to_string (major, minor))
(String.concat ~sep:"\n"
(Int.Map.to_list t |> List.map ~f:(fun (major, (minor, _)) ->
sprintf "- %u.0 to %u.%u" major major minor)))
| Some p -> p
let is_supported t (major, minor) =
match Int.Map.find t major with
| Some minor' -> minor' >= minor
| None -> false
let supported_ranges t =
Int.Map.to_list t |> List.map ~f:(fun (major, minor) ->
((major, 0), (major, minor)))
end
type t =
{ name : string
; key : Version.t Univ_map.Key.t
; supported_versions : Supported_versions.t
}
let create ~name supported_versions =
{ name
; key = Univ_map.Key.create ()
; supported_versions = Supported_versions.make supported_versions
}
let name t = t.name
let check_supported t (loc, ver) =
if not (Supported_versions.is_supported t.supported_versions ver) then
Loc.fail loc "Version %s of %s is not supported.\n\
Supported versions:\n\
%s"
(Version.to_string ver) t.name
(String.concat ~sep:"\n"
(List.map (Supported_versions.supported_ranges t.supported_versions)
~f:(fun (a, b) ->
sprintf "- %s to %s"
(Version.to_string a)
(Version.to_string b))))
let greatest_supported_version t =
Supported_versions.greatest_supported_version t.supported_versions
let key t = t.key
let set t ver parser =
Sexp.Of_sexp.set t.key ver parser
let get_exn t =
let open Sexp.Of_sexp in
get t.key >>| function
| Some x -> x
| None ->
Exn.code_error "Syntax identifier is unset"
[ "name", Sexp.To_sexp.string t.name ]

View File

@ -1,5 +1,6 @@
(** Management of syntaxes *)
open Stdune
(** Versioned syntaxes *)
module Version : sig
(** A syntax version.
@ -11,20 +12,33 @@ module Version : sig
include Sexp.Sexpable with type t := t
val to_string : t -> string
(** Whether the parser can read the data or not *)
val can_read : parser_version:t -> data_version:t -> bool
end
module Versioned_parser : sig
(** Versioned parser *)
type 'a t
type t
(** Create a versionned parser. There must be exactly one parser per
major version. *)
val make : (Version.t * 'a) list -> 'a t
(** [create ~name supported_versions] defines a new
syntax. [supported_version] is the list of the last minor version
of each supported major version. *)
val create : name:string -> Version.t list -> t
val last : 'a t -> Version.t * 'a
(** Return the name of the syntax. *)
val name : t -> string
(** Find a parser that can parse data of this version *)
val find_exn : 'a t -> loc:Loc.t -> data_version:Version.t -> 'a
end
(** Check that the given version is supported and raise otherwise. *)
val check_supported : t -> Loc.t * Version.t -> unit
val greatest_supported_version : t -> Version.t
val set
: t
-> Version.t
-> ('a, 'k) Sexp.Of_sexp.parser
-> ('a, 'k) Sexp.Of_sexp.parser
val get_exn : t -> (Version.t, 'k) Sexp.Of_sexp.parser
val key : t -> Version.t Univ_map.Key.t