2018-05-02 11:56:12 +00:00
|
|
|
open Import
|
|
|
|
open Sexp.Of_sexp
|
|
|
|
|
2018-05-22 16:29:54 +00:00
|
|
|
module Kind = struct
|
2018-05-15 08:46:07 +00:00
|
|
|
type t =
|
2018-05-22 16:29:54 +00:00
|
|
|
| Dune
|
2018-05-15 08:46:07 +00:00
|
|
|
| Jbuilder
|
|
|
|
end
|
|
|
|
|
2018-05-15 13:07:02 +00:00
|
|
|
module Name : sig
|
|
|
|
type t = private
|
|
|
|
| Named of string
|
|
|
|
| Anonymous of Path.t
|
|
|
|
|
|
|
|
val compare : t -> t -> Ordering.t
|
|
|
|
|
|
|
|
val to_string_hum : t -> string
|
|
|
|
|
|
|
|
val named_of_sexp : t Sexp.Of_sexp.t
|
|
|
|
val sexp_of_t : t Sexp.To_sexp.t
|
|
|
|
|
|
|
|
val encode : t -> string
|
|
|
|
val decode : string -> t
|
|
|
|
|
|
|
|
val anonymous : Path.t -> t option
|
|
|
|
val named : string -> t option
|
|
|
|
|
|
|
|
val anonymous_root : t
|
|
|
|
end = struct
|
|
|
|
type t =
|
|
|
|
| Named of string
|
|
|
|
| Anonymous of Path.t
|
|
|
|
|
|
|
|
let anonymous_root = Anonymous Path.root
|
|
|
|
|
|
|
|
let compare a b =
|
|
|
|
match a, b with
|
|
|
|
| Named x, Named y -> String.compare x y
|
|
|
|
| Anonymous x, Anonymous y -> Path.compare x y
|
|
|
|
| Named _, Anonymous _ -> Lt
|
|
|
|
| Anonymous _, Named _ -> Gt
|
|
|
|
|
|
|
|
let to_string_hum = function
|
|
|
|
| Named s -> s
|
|
|
|
| Anonymous p -> sprintf "<anonymous %s>" (Path.to_string_maybe_quoted p)
|
|
|
|
|
|
|
|
let sexp_of_t = function
|
|
|
|
| Named s -> Sexp.To_sexp.string s
|
|
|
|
| Anonymous p ->
|
|
|
|
List [ Sexp.unsafe_atom_of_string "anonymous"
|
|
|
|
; Path.sexp_of_t p
|
|
|
|
]
|
|
|
|
|
|
|
|
let validate name =
|
|
|
|
let len = String.length name in
|
|
|
|
len > 0 &&
|
|
|
|
String.for_all name ~f:(function
|
|
|
|
| '.' | '/' -> false
|
|
|
|
| _ -> true)
|
|
|
|
|
|
|
|
let named name =
|
|
|
|
if validate name then
|
|
|
|
Some (Named name)
|
|
|
|
else
|
|
|
|
None
|
|
|
|
|
|
|
|
let anonymous path =
|
2018-06-02 11:14:44 +00:00
|
|
|
if Path.is_managed path then
|
2018-05-15 13:07:02 +00:00
|
|
|
Some (Anonymous path)
|
|
|
|
else
|
|
|
|
None
|
|
|
|
|
2018-06-15 05:20:03 +00:00
|
|
|
let named_of_sexp =
|
2018-06-18 16:58:45 +00:00
|
|
|
Sexp.Of_sexp.plain_string (fun ~loc s ->
|
2018-06-15 05:20:03 +00:00
|
|
|
if validate s then
|
2018-06-18 16:58:45 +00:00
|
|
|
Named s
|
2018-06-15 05:20:03 +00:00
|
|
|
else
|
2018-06-18 17:06:32 +00:00
|
|
|
Sexp.Of_sexp.of_sexp_errorf loc "invalid project name")
|
2018-05-15 13:07:02 +00:00
|
|
|
|
|
|
|
let encode = function
|
|
|
|
| Named s -> s
|
|
|
|
| Anonymous p ->
|
|
|
|
if Path.is_root p then
|
|
|
|
"."
|
|
|
|
else
|
|
|
|
"." ^ String.map (Path.to_string p)
|
|
|
|
~f:(function
|
|
|
|
| '/' -> '.'
|
|
|
|
| c -> c)
|
|
|
|
|
|
|
|
let decode =
|
|
|
|
let invalid s =
|
|
|
|
(* Users would see this error if they did "dune build
|
|
|
|
_build/default/.ppx/..." *)
|
|
|
|
die "Invalid encoded project name: %S" s
|
|
|
|
in
|
|
|
|
fun s ->
|
|
|
|
match s with
|
|
|
|
| "" -> invalid s
|
|
|
|
| "." -> anonymous_root
|
|
|
|
| _ when s.[0] = '.' ->
|
|
|
|
let p =
|
|
|
|
Path.of_string
|
|
|
|
(String.split s ~on:'.'
|
|
|
|
|> List.tl
|
|
|
|
|> String.concat ~sep:"/")
|
|
|
|
in
|
2018-06-02 11:14:44 +00:00
|
|
|
if not (Path.is_managed p) then invalid s;
|
2018-05-15 13:07:02 +00:00
|
|
|
Anonymous p
|
|
|
|
| _ when validate s -> Named s
|
|
|
|
| _ -> invalid s
|
|
|
|
end
|
|
|
|
|
2018-06-20 12:28:45 +00:00
|
|
|
module Project_file = struct
|
|
|
|
type t =
|
|
|
|
{ file : Path.t
|
|
|
|
; mutable exists : bool
|
|
|
|
}
|
|
|
|
end
|
|
|
|
|
2018-05-02 11:56:12 +00:00
|
|
|
type t =
|
2018-06-20 12:28:45 +00:00
|
|
|
{ kind : Kind.t
|
|
|
|
; name : Name.t
|
|
|
|
; root : Path.Local.t
|
|
|
|
; version : string option
|
|
|
|
; packages : Package.t Package.Name.Map.t
|
|
|
|
; stanza_parser : Stanza.t list Sexp.Of_sexp.t
|
|
|
|
; project_file : Project_file.t
|
2018-05-02 11:56:12 +00:00
|
|
|
}
|
|
|
|
|
2018-05-22 16:29:54 +00:00
|
|
|
module Lang = struct
|
2018-06-19 12:02:35 +00:00
|
|
|
type t =
|
|
|
|
{ syntax : Syntax.t
|
|
|
|
; stanzas : Stanza.Parser.t list
|
|
|
|
}
|
2018-05-22 16:29:54 +00:00
|
|
|
|
2018-06-19 12:02:35 +00:00
|
|
|
type instance =
|
|
|
|
{ lang : t
|
|
|
|
; version : Syntax.Version.t
|
|
|
|
}
|
2018-05-22 16:29:54 +00:00
|
|
|
|
|
|
|
let langs = Hashtbl.create 32
|
|
|
|
|
2018-06-19 12:02:35 +00:00
|
|
|
let register syntax stanzas =
|
|
|
|
let name = Syntax.name syntax in
|
2018-05-22 16:29:54 +00:00
|
|
|
if Hashtbl.mem langs name then
|
|
|
|
Exn.code_error "Dune_project.Lang.register: already registered"
|
|
|
|
[ "name", Sexp.To_sexp.string name ];
|
2018-06-19 12:02:35 +00:00
|
|
|
Hashtbl.add langs name { syntax; stanzas }
|
2018-05-22 16:29:54 +00:00
|
|
|
|
|
|
|
let parse first_line =
|
|
|
|
let { Dune_lexer.
|
2018-06-19 12:02:35 +00:00
|
|
|
lang = (name_loc, name)
|
2018-05-22 16:29:54 +00:00
|
|
|
; version = (ver_loc, ver)
|
|
|
|
} = first_line
|
|
|
|
in
|
2018-06-15 05:20:03 +00:00
|
|
|
let ver =
|
2018-06-19 10:53:16 +00:00
|
|
|
Sexp.Of_sexp.parse Syntax.Version.t Univ_map.empty
|
2018-06-20 05:29:18 +00:00
|
|
|
(Atom (ver_loc, Sexp.Atom.of_string ver)) in
|
2018-05-22 16:29:54 +00:00
|
|
|
match Hashtbl.find langs name with
|
|
|
|
| None ->
|
|
|
|
Loc.fail name_loc "Unknown language %S.%s" name
|
|
|
|
(hint name (Hashtbl.keys langs))
|
2018-06-19 12:02:35 +00:00
|
|
|
| Some t ->
|
|
|
|
Syntax.check_supported t.syntax (ver_loc, ver);
|
|
|
|
{ lang = t
|
|
|
|
; version = ver
|
|
|
|
}
|
|
|
|
|
|
|
|
let get_exn name =
|
|
|
|
let lang = Option.value_exn (Hashtbl.find langs name) in
|
|
|
|
{ lang
|
|
|
|
; version = Syntax.greatest_supported_version lang.syntax
|
|
|
|
}
|
2018-05-22 16:29:54 +00:00
|
|
|
end
|
|
|
|
|
2018-06-20 12:28:45 +00:00
|
|
|
module Project_file_edit = struct
|
|
|
|
open Project_file
|
|
|
|
|
|
|
|
let notify_user s =
|
|
|
|
kerrf ~f:print_to_console "@{<warning>Info@}: %s\n" s
|
|
|
|
|
|
|
|
let ensure_exists t =
|
|
|
|
if not t.exists then begin
|
|
|
|
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 t.file) s);
|
|
|
|
Io.write_file t.file (s ^ "\n") ~binary:false;
|
|
|
|
t.exists <- true
|
|
|
|
end
|
|
|
|
|
|
|
|
let get t =
|
|
|
|
ensure_exists t;
|
|
|
|
t.file
|
|
|
|
|
|
|
|
let append t str =
|
|
|
|
let file = get t in
|
|
|
|
let prev = Io.read_file file ~binary:false in
|
|
|
|
notify_user
|
|
|
|
(sprintf "appending this line to %s: %s"
|
|
|
|
(Path.to_string_maybe_quoted file) str);
|
|
|
|
Io.with_file_out file ~binary:false ~f:(fun oc ->
|
|
|
|
List.iter [prev; str] ~f:(fun s ->
|
|
|
|
output_string oc s;
|
|
|
|
let len = String.length s in
|
|
|
|
if len > 0 && s.[len - 1] <> '\n' then output_char oc '\n'))
|
|
|
|
end
|
|
|
|
|
|
|
|
let ensure_project_file_exists t =
|
|
|
|
Project_file_edit.ensure_exists t.project_file
|
|
|
|
|
|
|
|
let append_to_project_file t str =
|
|
|
|
Project_file_edit.append t.project_file str
|
|
|
|
|
2018-05-22 16:29:54 +00:00
|
|
|
module Extension = struct
|
2018-06-19 12:02:35 +00:00
|
|
|
type t =
|
|
|
|
{ syntax : Syntax.t
|
|
|
|
; stanzas : Stanza.Parser.t list Sexp.Of_sexp.t
|
|
|
|
}
|
2018-05-22 16:29:54 +00:00
|
|
|
|
2018-06-19 12:02:35 +00:00
|
|
|
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
|
|
|
|
}
|
2018-05-22 16:29:54 +00:00
|
|
|
|
|
|
|
let extensions = Hashtbl.create 32
|
|
|
|
|
2018-06-19 12:02:35 +00:00
|
|
|
let register syntax stanzas =
|
|
|
|
let name = Syntax.name syntax in
|
2018-05-22 16:29:54 +00:00
|
|
|
if Hashtbl.mem extensions name then
|
|
|
|
Exn.code_error "Dune_project.Extension.register: already registered"
|
|
|
|
[ "name", Sexp.To_sexp.string name ];
|
2018-06-19 12:02:35 +00:00
|
|
|
Hashtbl.add extensions name { syntax; stanzas }
|
2018-05-22 16:29:54 +00:00
|
|
|
|
2018-06-19 12:02:35 +00:00
|
|
|
let instantiate ~loc ~parse_args (name_loc, name) (ver_loc, ver) =
|
2018-06-14 07:51:27 +00:00
|
|
|
match Hashtbl.find extensions name with
|
|
|
|
| None ->
|
|
|
|
Loc.fail name_loc "Unknown extension %S.%s" name
|
|
|
|
(hint name (Hashtbl.keys extensions))
|
2018-06-19 12:02:35 +00:00
|
|
|
| Some t ->
|
|
|
|
Syntax.check_supported t.syntax (ver_loc, ver);
|
|
|
|
{ extension = t
|
|
|
|
; version = ver
|
|
|
|
; loc
|
|
|
|
; parse_args
|
|
|
|
}
|
2018-06-20 12:28:45 +00:00
|
|
|
|
|
|
|
(* Extensions that are not selected in the dune-project file are
|
|
|
|
automatically available at their latest version. When used, dune
|
|
|
|
will automatically edit the dune-project file. *)
|
|
|
|
let automatic ~project_file ~f =
|
|
|
|
Hashtbl.foldi extensions ~init:[] ~f:(fun name ext acc ->
|
|
|
|
if f name then
|
|
|
|
let version = Syntax.greatest_supported_version ext.syntax in
|
|
|
|
let parse_args p =
|
|
|
|
let open Sexp.Of_sexp in
|
|
|
|
let dune_project_edited = ref false in
|
|
|
|
parse p Univ_map.empty (List (Loc.none, []))
|
|
|
|
|> List.map ~f:(fun (name, p) ->
|
|
|
|
(name,
|
|
|
|
return () >>= fun () ->
|
|
|
|
if not !dune_project_edited then begin
|
|
|
|
dune_project_edited := true;
|
|
|
|
Project_file_edit.append project_file
|
|
|
|
(Sexp.to_string
|
|
|
|
(List [ Sexp.atom "using"
|
|
|
|
; Sexp.atom name
|
|
|
|
; Sexp.atom (Syntax.Version.to_string version)
|
|
|
|
]))
|
|
|
|
end;
|
|
|
|
p))
|
|
|
|
in
|
|
|
|
{ extension = ext
|
|
|
|
; version
|
|
|
|
; loc = Loc.none
|
|
|
|
; parse_args
|
|
|
|
} :: acc
|
|
|
|
else
|
|
|
|
acc)
|
2018-05-22 16:29:54 +00:00
|
|
|
end
|
2018-05-16 15:21:08 +00:00
|
|
|
|
2018-06-19 12:02:35 +00:00
|
|
|
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)
|
|
|
|
|
2018-06-19 11:12:48 +00:00
|
|
|
let key = Univ_map.Key.create ()
|
|
|
|
let set t = Sexp.Of_sexp.set key t
|
|
|
|
let get_exn () =
|
|
|
|
let open Sexp.Of_sexp in
|
|
|
|
get key >>| function
|
|
|
|
| Some t -> t
|
|
|
|
| None ->
|
|
|
|
Exn.code_error "Current project is unset" []
|
|
|
|
|
2018-05-02 11:56:12 +00:00
|
|
|
let filename = "dune-project"
|
|
|
|
|
2018-06-12 09:49:39 +00:00
|
|
|
let get_local_path p =
|
|
|
|
match Path.kind p with
|
|
|
|
| External _ -> assert false
|
|
|
|
| Local p -> p
|
|
|
|
|
2018-06-19 11:12:48 +00:00
|
|
|
let anonymous = lazy (
|
2018-06-19 12:02:35 +00:00
|
|
|
let lang = Lang.get_exn "dune" in
|
|
|
|
let parsing_context = make_parsing_context ~lang ~extensions:[] in
|
2018-06-19 11:12:48 +00:00
|
|
|
{ kind = Dune
|
|
|
|
; name = Name.anonymous_root
|
|
|
|
; packages = Package.Name.Map.empty
|
|
|
|
; root = get_local_path Path.root
|
|
|
|
; version = None
|
2018-06-19 12:02:35 +00:00
|
|
|
; stanza_parser =
|
|
|
|
Sexp.Of_sexp.(set_many parsing_context (sum lang.lang.stanzas))
|
2018-06-20 12:28:45 +00:00
|
|
|
; project_file = { file = Path.relative Path.root filename; exists = false }
|
2018-06-19 11:12:48 +00:00
|
|
|
})
|
2018-05-22 16:29:54 +00:00
|
|
|
|
2018-05-15 08:46:07 +00:00
|
|
|
let default_name ~dir ~packages =
|
|
|
|
match Package.Name.Map.choose packages with
|
2018-05-15 13:07:02 +00:00
|
|
|
| None -> Option.value_exn (Name.anonymous dir)
|
|
|
|
| Some (_, pkg) ->
|
|
|
|
let pkg =
|
|
|
|
Package.Name.Map.fold packages ~init:pkg ~f:(fun pkg acc ->
|
|
|
|
if acc.Package.name <= pkg.Package.name then
|
|
|
|
acc
|
|
|
|
else
|
|
|
|
pkg)
|
|
|
|
in
|
|
|
|
let name = Package.Name.to_string pkg.name in
|
|
|
|
match Name.named name with
|
|
|
|
| Some x -> x
|
|
|
|
| None ->
|
|
|
|
Loc.fail (Loc.in_file (Path.to_string (Package.opam_file pkg)))
|
|
|
|
"%S is not a valid opam package name."
|
|
|
|
name
|
2018-05-15 08:46:07 +00:00
|
|
|
|
|
|
|
let name ~dir ~packages =
|
2018-05-15 13:07:02 +00:00
|
|
|
field_o "name" Name.named_of_sexp >>= function
|
|
|
|
| Some x -> return x
|
2018-05-22 16:29:54 +00:00
|
|
|
| None -> return (default_name ~dir ~packages)
|
2018-05-02 11:56:12 +00:00
|
|
|
|
2018-06-19 12:02:35 +00:00
|
|
|
let parse ~dir ~lang ~packages ~file =
|
2018-05-02 13:58:24 +00:00
|
|
|
record
|
2018-05-31 15:36:55 +00:00
|
|
|
(name ~dir ~packages >>= fun name ->
|
2018-05-02 15:55:18 +00:00
|
|
|
field_o "version" string >>= fun version ->
|
2018-06-18 16:58:45 +00:00
|
|
|
multi_field "using"
|
|
|
|
(loc >>= fun loc ->
|
|
|
|
located string >>= fun name ->
|
|
|
|
located Syntax.Version.t >>= fun ver ->
|
2018-06-19 12:02:35 +00:00
|
|
|
(* 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))
|
2018-06-14 07:51:27 +00:00
|
|
|
>>= fun extensions ->
|
2018-06-19 12:02:35 +00:00
|
|
|
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
|
2018-06-20 12:28:45 +00:00
|
|
|
| Ok map ->
|
|
|
|
let project_file : Project_file.t = { file; exists = true } in
|
|
|
|
let extensions =
|
|
|
|
extensions @
|
|
|
|
Extension.automatic ~project_file
|
|
|
|
~f:(fun name -> not (String.Map.mem map name))
|
|
|
|
in
|
2018-06-19 12:02:35 +00:00
|
|
|
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))
|
2018-06-20 12:28:45 +00:00
|
|
|
; project_file
|
2018-06-19 12:02:35 +00:00
|
|
|
})
|
2018-05-02 11:56:12 +00:00
|
|
|
|
2018-05-15 08:46:07 +00:00
|
|
|
let load_dune_project ~dir packages =
|
2018-05-02 11:56:12 +00:00
|
|
|
let fname = Path.relative dir filename in
|
2018-05-31 15:36:55 +00:00
|
|
|
Io.with_lexbuf_from_file fname ~f:(fun lb ->
|
2018-06-19 12:02:35 +00:00
|
|
|
let lang = Lang.parse (Dune_lexer.first_line lb) in
|
2018-05-31 15:36:55 +00:00
|
|
|
let sexp = Sexp.Parser.parse lb ~mode:Many_as_one in
|
2018-06-19 12:02:35 +00:00
|
|
|
Sexp.Of_sexp.parse (parse ~dir ~lang ~packages ~file:fname)
|
2018-06-19 10:53:16 +00:00
|
|
|
Univ_map.empty sexp)
|
2018-05-15 08:46:07 +00:00
|
|
|
|
|
|
|
let make_jbuilder_project ~dir packages =
|
2018-06-19 12:02:35 +00:00
|
|
|
let lang = Lang.get_exn "dune" in
|
|
|
|
let parsing_context = make_parsing_context ~lang ~extensions:[] in
|
2018-06-19 11:12:48 +00:00
|
|
|
{ kind = Jbuilder
|
|
|
|
; name = default_name ~dir ~packages
|
|
|
|
; root = get_local_path dir
|
|
|
|
; version = None
|
|
|
|
; packages
|
2018-06-19 12:02:35 +00:00
|
|
|
; stanza_parser =
|
|
|
|
Sexp.Of_sexp.(set_many parsing_context (sum lang.lang.stanzas))
|
2018-06-20 12:28:45 +00:00
|
|
|
; project_file = { file = Path.relative dir filename; exists = false }
|
2018-06-19 11:12:48 +00:00
|
|
|
}
|
2018-05-15 08:46:07 +00:00
|
|
|
|
|
|
|
let load ~dir ~files =
|
|
|
|
let packages =
|
|
|
|
String.Set.fold files ~init:[] ~f:(fun fn acc ->
|
|
|
|
match Filename.split_extension fn with
|
|
|
|
| (pkg, ".opam") when pkg <> "" ->
|
|
|
|
let version_from_opam_file =
|
|
|
|
let opam = Opam_file.load (Path.relative dir fn) in
|
|
|
|
match Opam_file.get_field opam "version" with
|
|
|
|
| Some (String (_, s)) -> Some s
|
|
|
|
| _ -> None
|
|
|
|
in
|
|
|
|
let name = Package.Name.of_string pkg in
|
|
|
|
(name,
|
|
|
|
{ Package. name
|
|
|
|
; path = dir
|
|
|
|
; version_from_opam_file
|
|
|
|
}) :: acc
|
|
|
|
| _ -> acc)
|
|
|
|
|> Package.Name.Map.of_list_exn
|
|
|
|
in
|
|
|
|
if String.Set.mem files filename then
|
|
|
|
Some (load_dune_project ~dir packages)
|
|
|
|
else if not (Package.Name.Map.is_empty packages) then
|
|
|
|
Some (make_jbuilder_project ~dir packages)
|
|
|
|
else
|
|
|
|
None
|