From 5d1d3a2eae63c5871c20d7f4efbe7bf1f454da34 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Tue, 19 Jun 2018 12:12:48 +0100 Subject: [PATCH] Pass the project through the user context Signed-off-by: Jeremie Dimino --- src/dune_project.ml | 101 +++++++++++++++++++------------------------ src/dune_project.mli | 36 +++++++-------- src/jbuild.ml | 67 +++++++++++++++------------- 3 files changed, 96 insertions(+), 108 deletions(-) diff --git a/src/dune_project.ml b/src/dune_project.ml index a250d242..e7650c22 100644 --- a/src/dune_project.ml +++ b/src/dune_project.ml @@ -112,19 +112,17 @@ end = struct end type t = - { kind : Kind.t - ; name : Name.t - ; root : Path.Local.t - ; version : string option - ; packages : Package.t Package.Name.Map.t - ; mutable stanza_parser : Stanza.t list Sexp.Of_sexp.t - ; mutable project_file : Path.t option + { 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 + ; mutable project_file : Path.t option } -type project = t - module Lang = struct - type t = Syntax.Version.t * (project -> Stanza.Parser.t list) + type t = Syntax.Version.t * Stanza.Parser.t list let make ver f = (ver, f) @@ -161,9 +159,7 @@ module Lang = struct end module Extension = struct - type maker = project -> Stanza.Parser.t list Sexp.Of_sexp.t - - type t = Syntax.Version.t * maker + type t = Syntax.Version.t * Stanza.Parser.t list Sexp.Of_sexp.t let make ver f = (ver, f) @@ -184,6 +180,15 @@ module Extension = struct Syntax.Versioned_parser.find_exn versions ~loc:ver_loc ~data_version:ver end +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" [] + let filename = "dune-project" let get_local_path p = @@ -191,23 +196,15 @@ let get_local_path p = | External _ -> assert false | Local p -> p -let fake_stanza_parser = - let open Sexp.Of_sexp in - return () >>| fun _ -> assert false - -let anonymous = lazy( - let t = - { kind = Dune - ; name = Name.anonymous_root - ; packages = Package.Name.Map.empty - ; root = get_local_path Path.root - ; version = None - ; stanza_parser = fake_stanza_parser - ; project_file = None - } - in - t.stanza_parser <- Sexp.Of_sexp.sum (snd (Lang.latest "dune") t); - t) +let anonymous = lazy ( + { 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")) + ; project_file = None + }) let default_name ~dir ~packages = match Package.Name.Map.choose packages with @@ -237,21 +234,11 @@ let parse ~dir ~lang_stanzas ~packages ~file = record (name ~dir ~packages >>= fun name -> field_o "version" string >>= fun version -> - let t = - { kind = Dune - ; name - ; root = get_local_path dir - ; version - ; packages - ; stanza_parser = fake_stanza_parser - ; project_file = Some file - } - in multi_field "using" (loc >>= fun loc -> located string >>= fun name -> located Syntax.Version.t >>= fun ver -> - Extension.lookup name ver t >>= fun stanzas -> + Extension.lookup name ver >>= fun stanzas -> return (snd name, (loc, stanzas))) >>= fun extensions -> let extensions_stanzas = @@ -261,8 +248,15 @@ let parse ~dir ~lang_stanzas ~packages ~file = | Ok _ -> List.concat_map extensions ~f:(fun (_, (_, x)) -> x) in - t.stanza_parser <- Sexp.Of_sexp.sum (lang_stanzas t @ extensions_stanzas); - return t) + 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 + }) let load_dune_project ~dir packages = let fname = Path.relative dir filename in @@ -273,18 +267,14 @@ let load_dune_project ~dir packages = Univ_map.empty sexp) let make_jbuilder_project ~dir packages = - let t = - { kind = Jbuilder - ; name = default_name ~dir ~packages - ; root = get_local_path dir - ; version = None - ; packages - ; stanza_parser = fake_stanza_parser - ; project_file = None - } - in - t.stanza_parser <- Sexp.Of_sexp.sum (snd (Lang.latest "dune") t); - t + { 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")) + ; project_file = None + } let load ~dir ~files = let packages = @@ -344,4 +334,3 @@ let append_to_project_file t str = output_string oc s; let len = String.length s in if len > 0 && s.[len - 1] <> '\n' then output_char oc '\n')) - diff --git a/src/dune_project.mli b/src/dune_project.mli index 1837a150..1e990eee 100644 --- a/src/dune_project.mli +++ b/src/dune_project.mli @@ -31,18 +31,16 @@ end (* CR-soon diml: make this abstract *) type t = private - { kind : Kind.t - ; name : Name.t - ; root : Path.Local.t - ; version : string option - ; packages : Package.t Package.Name.Map.t - ; mutable stanza_parser : Stanza.t list Sexp.Of_sexp.t - ; mutable project_file : Path.t option + { 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 + ; mutable project_file : Path.t option } module Lang : sig - type project = t - (** One version of a language *) type t @@ -53,10 +51,7 @@ module Lang : sig 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 - -> (project -> Stanza.Parser.t list) - -> t + val make : Syntax.Version.t -> Stanza.Parser.t list -> t val version : t -> Syntax.Version.t @@ -65,11 +60,9 @@ module Lang : sig (** Latest version of the following language *) val latest : string -> t -end with type project := t +end module Extension : sig - type project = t - (** One version of an extension *) type t @@ -80,14 +73,11 @@ module Extension : sig in their [dune-project] file. [parser] is used to describe what [] might be. *) - val make - : Syntax.Version.t - -> (project -> Stanza.Parser.t list Sexp.Of_sexp.t) - -> t + 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 -end with type project := t +end (** Load a project description from the following directory. [files] is the set of files in this directory. *) @@ -105,3 +95,7 @@ val ensure_project_file_exists : t -> unit (** Append the following text to the project file *) val append_to_project_file : t -> string -> unit + +(** Set the project we are currently parsing dune files for *) +val set : t -> ('a, 'k) Sexp.Of_sexp.parser -> ('a, 'k) Sexp.Of_sexp.parser +val get_exn : unit -> (t, 'k) Sexp.Of_sexp.parser diff --git a/src/jbuild.ml b/src/jbuild.ml index d8c0f5a4..a7e4003c 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -154,13 +154,15 @@ module Pkg = struct (hint name_s (Package.Name.Map.keys project.packages |> List.map ~f:Package.Name.to_string))) - let t p = + let t = + Dune_project.get_exn () >>= fun p -> located Package.Name.t >>| fun (loc, name) -> match resolve p name with | Ok x -> x | Error e -> Loc.fail loc "%s" e - let field p = + let field = + Dune_project.get_exn () >>= fun p -> map_validate (field_o "package" string) ~f:(function | None -> default p | Some name -> resolve p (Package.Name.of_string name)) @@ -550,7 +552,8 @@ module Public_lib = struct ; sub_dir : string option } - let public_name_field project = + let public_name_field = + Dune_project.get_exn () >>= fun project -> map_validate (field_o "public_name" string) ~f:(function | None -> Ok None | Some s -> @@ -701,11 +704,11 @@ module Library = struct ; sub_systems : Sub_system_info.t Sub_system_name.Map.t } - let v1 project = + let v1 = record (Buildable.v1 >>= fun buildable -> field "name" library_name >>= fun name -> - Public_lib.public_name_field project >>= fun public -> + Public_lib.public_name_field >>= fun public -> field_o "synopsis" string >>= fun synopsis -> field "install_c_headers" (list string) ~default:[] >>= fun install_c_headers -> field "ppx_runtime_libraries" (list (located string)) ~default:[] >>= fun ppx_runtime_libraries -> @@ -723,6 +726,7 @@ module Library = struct field "self_build_stubs_archive" (option string) ~default:None >>= fun self_build_stubs_archive -> field_b "no_dynlink" >>= fun no_dynlink -> Sub_system_info.record_parser () >>= fun sub_systems -> + Dune_project.get_exn () >>= fun project -> return { name ; public @@ -782,11 +786,11 @@ module Install_conf = struct ; package : Package.t } - let v1 project = + let v1 = record (field "section" Install.Section.t >>= fun section -> field "files" (list file) >>= fun files -> - Pkg.field project >>= fun package -> + Pkg.field >>= fun package -> return { section ; files @@ -902,7 +906,7 @@ module Executables = struct ; buildable : Buildable.t } - let common project names public_names ~syntax ~multi = + let common names public_names ~syntax ~multi = Buildable.v1 >>= fun buildable -> (match (syntax : File_tree.Dune_file.Kind.t) with | Dune -> @@ -974,7 +978,7 @@ module Executables = struct (if multi then "s" else ""); return (t, None)) | files -> - Pkg.field project >>= fun package -> + Pkg.field >>= fun package -> return (t, Some { Install_conf. section = Bin; files; package }) let public_name = @@ -982,7 +986,7 @@ module Executables = struct | "-" -> None | s -> Some s - let multi ~syntax project = + let multi ~syntax = record (field "names" (list (located string)) >>= fun names -> map_validate (field_o "public_names" (list public_name)) ~f:(function @@ -994,13 +998,13 @@ module Executables = struct Error "The list of public names must be of the same \ length as the list of names") >>= fun public_names -> - common ~syntax project names public_names ~multi:true) + common ~syntax names public_names ~multi:true) - let single ~syntax project = + let single ~syntax = record (field "name" (located string) >>= fun name -> field_o "public_name" string >>= fun public_name -> - common ~syntax project [name] [public_name] ~multi:false) + common ~syntax [name] [public_name] ~multi:false) end module Rule = struct @@ -1181,11 +1185,11 @@ module Alias_conf = struct else s) - let v1 project = + let v1 = record (field "name" alias_name >>= fun name -> field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> - field_o "package" (Pkg.t project) >>= fun package -> + field_o "package" Pkg.t >>= fun package -> field_o "action" (located Action.Unexpanded.t) >>= fun action -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> return @@ -1211,9 +1215,9 @@ module Documentation = struct ; mld_files: Ordered_set_lang.t } - let v1 project = + let v1 = record - (Pkg.field project >>= fun package -> + (Pkg.field >>= fun package -> field "mld_files" Ordered_set_lang.t ~default:Ordered_set_lang.standard >>= fun mld_files -> return @@ -1289,12 +1293,12 @@ module Stanzas = struct type constructors = (string * Stanza.t list Sexp.Of_sexp.t) list - let common project ~syntax : constructors = + let common ~syntax : constructors = [ "library", - (Library.v1 project >>| fun x -> + (Library.v1 >>| fun x -> [Library x]) - ; "executable" , Executables.single project ~syntax >>| execs - ; "executables", Executables.multi project ~syntax >>| execs + ; "executable" , Executables.single ~syntax >>| execs + ; "executables", Executables.multi ~syntax >>| execs ; "rule", (loc >>= fun loc -> Rule.v1 >>| fun x -> @@ -1312,10 +1316,10 @@ module Stanzas = struct Menhir.v1 >>| fun x -> [Menhir { x with loc }]) ; "install", - (Install_conf.v1 project >>| fun x -> + (Install_conf.v1 >>| fun x -> [Install x]) ; "alias", - (Alias_conf.v1 project >>| fun x -> + (Alias_conf.v1 >>| fun x -> [Alias x]) ; "copy_files", (Copy_files.v1 >>| fun glob -> @@ -1328,20 +1332,20 @@ module Stanzas = struct relative_file >>| fun fn -> [Include (loc, fn)]) ; "documentation", - (Documentation.v1 project >>| fun d -> + (Documentation.v1 >>| fun d -> [Documentation d]) ] - let dune project = - common project ~syntax:Dune @ + let dune = + common ~syntax:Dune @ [ "env", (loc >>= fun loc -> repeat Env.rule >>| fun rules -> [Env { loc; rules }]) ] - let jbuild project = - common project ~syntax:Jbuild @ + let jbuild = + common ~syntax:Jbuild @ [ "jbuild_version", (Jbuild_version.t >>| fun _ -> []) ] @@ -1371,9 +1375,10 @@ module Stanzas = struct let parse ~file ~kind (project : Dune_project.t) sexps = let stanza_parser = - match (kind : File_tree.Dune_file.Kind.t) with - | Jbuild -> sum (jbuild project) - | Dune -> project.stanza_parser + Dune_project.set project + (match (kind : File_tree.Dune_file.Kind.t) with + | Jbuild -> sum jbuild + | Dune -> project.stanza_parser) in let stanzas = try