611 lines
18 KiB
OCaml
611 lines
18 KiB
OCaml
open Import
|
|
|
|
(** Because the dune_init utility deals with the addition of stanzas and fields
|
|
to dune projects and files, we need to inspect and manipulate the concrete
|
|
syntax tree (CST) a good deal. *)
|
|
module Cst = Dune_lang.Cst
|
|
|
|
(** Abstractions around the kinds of files handled during initialization *)
|
|
module File = struct
|
|
type dune =
|
|
{ path : Path.t
|
|
; name : string
|
|
; content : Cst.t list
|
|
}
|
|
|
|
type text =
|
|
{ path : Path.t
|
|
; name : string
|
|
; content : string
|
|
}
|
|
|
|
type t =
|
|
| Dune of dune
|
|
| Text of text
|
|
|
|
let make_text path name content = Text { path; name; content }
|
|
|
|
let full_path = function
|
|
| Dune { path; name; _ } | Text { path; name; _ } -> Path.relative path name
|
|
;;
|
|
|
|
(** Inspection and manipulation of stanzas in a file *)
|
|
module Stanza = struct
|
|
let pp s =
|
|
match Cst.to_sexp s with
|
|
| None -> Pp.nop
|
|
| Some s -> Dune_lang.pp s
|
|
;;
|
|
|
|
let libraries_conflict (a : Library.t) (b : Library.t) = a.name = b.name
|
|
|
|
let executables_conflict (a : Dune_rules.Executables.t) (b : Dune_rules.Executables.t)
|
|
=
|
|
let a_names = String.Set.of_list_map ~f:snd (Nonempty_list.to_list a.names) in
|
|
let b_names = String.Set.of_list_map ~f:snd (Nonempty_list.to_list b.names) in
|
|
String.Set.inter a_names b_names |> String.Set.is_empty |> not
|
|
;;
|
|
|
|
let tests_conflict (a : Dune_rules.Tests.t) (b : Dune_rules.Tests.t) =
|
|
executables_conflict a.exes b.exes
|
|
;;
|
|
|
|
let stanzas_conflict (a : Stanza.t) (b : Stanza.t) =
|
|
match Stanza.repr a, Stanza.repr b with
|
|
| Dune_rules.Executables.T a, Dune_rules.Executables.T b -> executables_conflict a b
|
|
| Library.T a, Library.T b -> libraries_conflict a b
|
|
| Dune_rules.Tests.T a, Dune_rules.Tests.T b -> tests_conflict a b
|
|
(* NOTE No other stanza types currently supported *)
|
|
| _ -> false
|
|
;;
|
|
|
|
let csts_conflict project (a : Cst.t) (b : Cst.t) =
|
|
let of_ast = Dune_rules.Stanzas.of_ast project in
|
|
(let open Option.O in
|
|
let* a_ast = Cst.abstract a in
|
|
let+ b_ast = Cst.abstract b in
|
|
let a_asts = of_ast a_ast in
|
|
let b_asts = of_ast b_ast in
|
|
List.exists ~f:(fun x -> List.exists ~f:(stanzas_conflict x) a_asts) b_asts)
|
|
|> Option.value ~default:false
|
|
;;
|
|
|
|
(* TODO(shonfeder): replace with stanza merging *)
|
|
let find_conflicting project new_stanzas existing_stanzas =
|
|
let conflicting_stanza stanza =
|
|
match List.find ~f:(csts_conflict project stanza) existing_stanzas with
|
|
| Some conflict -> Some (stanza, conflict)
|
|
| None -> None
|
|
in
|
|
List.find_map ~f:conflicting_stanza new_stanzas
|
|
;;
|
|
|
|
let add (project : Dune_project.t) stanzas = function
|
|
| Text f -> Text f (* Adding a stanza to a text file isn't meaningful *)
|
|
| Dune f ->
|
|
(match find_conflicting project stanzas f.content with
|
|
| None -> Dune { f with content = f.content @ stanzas }
|
|
| Some (a, b) ->
|
|
User_error.raise
|
|
[ Pp.text "Updating existing stanzas is not yet supported."
|
|
; Pp.text "A preexisting dune stanza conflicts with a generated stanza:"
|
|
; Pp.nop
|
|
; Pp.text "Generated stanza:"
|
|
; pp a
|
|
; Pp.nop
|
|
; Pp.text "Pre-existing stanza:"
|
|
; pp b
|
|
])
|
|
;;
|
|
end
|
|
|
|
(* Stanza *)
|
|
|
|
let create_dir path =
|
|
try Path.mkdir_p path with
|
|
| Unix.Unix_error (EACCES, _, _) ->
|
|
User_error.raise
|
|
[ Pp.textf
|
|
"A project directory cannot be created or accessed: Lacking permissions \
|
|
needed to create directory %s"
|
|
(Path.to_string_maybe_quoted path)
|
|
]
|
|
;;
|
|
|
|
let load_dune_file ~path =
|
|
let name = "dune" in
|
|
let full_path = Path.relative path name in
|
|
let content =
|
|
if not (Path.exists full_path)
|
|
then []
|
|
else if Path.is_directory full_path
|
|
then
|
|
User_error.raise
|
|
[ Pp.textf
|
|
"\"%s\" already exists and is a directory"
|
|
(Path.to_absolute_filename full_path)
|
|
]
|
|
else (
|
|
match Io.with_lexbuf_from_file ~f:Dune_lang.Format.parse full_path with
|
|
| Dune_lang.Format.Sexps content -> content
|
|
| Dune_lang.Format.OCaml_syntax _ ->
|
|
User_error.raise
|
|
[ Pp.textf
|
|
"Cannot load dune file %s because it uses OCaml syntax"
|
|
(Path.to_string_maybe_quoted full_path)
|
|
])
|
|
in
|
|
Dune { path; name; content }
|
|
;;
|
|
|
|
let write_dune_file (dune_file : dune) =
|
|
let path = Path.relative dune_file.path dune_file.name in
|
|
let version =
|
|
Dune_lang.Syntax.greatest_supported_version_exn Dune_lang.Stanza.syntax
|
|
in
|
|
Io.with_file_out
|
|
~binary:true
|
|
(* Why do we pass [~binary:true] but not anywhere else when formatting? *)
|
|
path
|
|
~f:(fun oc ->
|
|
let fmt = Format.formatter_of_out_channel oc in
|
|
Format.fprintf
|
|
fmt
|
|
"%a%!"
|
|
Pp.to_fmt
|
|
(Dune_lang.Format.pp_top_sexps ~version dune_file.content))
|
|
;;
|
|
|
|
let write f =
|
|
let path = full_path f in
|
|
match f with
|
|
| Dune f -> Ok (write_dune_file f)
|
|
| Text f ->
|
|
if Path.exists path
|
|
then Error path
|
|
else Ok (Io.write_file ~binary:false path f.content)
|
|
;;
|
|
end
|
|
|
|
(** The context in which the initialization is executed *)
|
|
module Init_context = struct
|
|
open Dune_config_file
|
|
|
|
type t =
|
|
{ dir : Path.t
|
|
; project : Dune_project.t
|
|
; defaults : Dune_config.Project_defaults.t
|
|
}
|
|
|
|
let make path defaults =
|
|
let open Memo.O in
|
|
let+ project =
|
|
(* CR-someday rgrinberg: why not get the project from the source tree? *)
|
|
Dune_project.load
|
|
~dir:Path.Source.root
|
|
~files:Filename.Set.empty
|
|
~infer_from_opam_files:true
|
|
~load_opam_file_with_contents:Dune_pkg.Opam_file.load_opam_file_with_contents
|
|
>>| function
|
|
| Some p -> p
|
|
| None ->
|
|
Dune_project.anonymous
|
|
~dir:Path.Source.root
|
|
Package_info.empty
|
|
Package.Name.Map.empty
|
|
in
|
|
let dir =
|
|
match path with
|
|
| None -> Path.root
|
|
| Some p -> Path.of_string p
|
|
in
|
|
File.create_dir dir;
|
|
{ dir; project; defaults }
|
|
;;
|
|
end
|
|
|
|
let check_module_name name =
|
|
let s = Dune_lang.Atom.to_string name in
|
|
let (_ : Dune_rules.Module_name.t) =
|
|
Dune_rules.Module_name.of_string_user_error (Loc.none, s) |> User_error.ok_exn
|
|
in
|
|
()
|
|
;;
|
|
|
|
module Public_name = struct
|
|
include Lib_name
|
|
module Pkg = Dune_lang.Package_name.Opam_compatible
|
|
|
|
let is_opam_compatible l =
|
|
Lib_name.package_name l |> Dune_lang.Package_name.is_opam_compatible
|
|
;;
|
|
|
|
let of_string_user_error (loc, s) =
|
|
let open Result.O in
|
|
let* l = of_string_user_error (loc, s) in
|
|
if is_opam_compatible l
|
|
then Ok l
|
|
else
|
|
Error
|
|
(User_error.make
|
|
[ Pp.text
|
|
"Public names are composed of an opam package name and optional \
|
|
dot-separated string suffixes."
|
|
; Pkg.description_of_valid_string
|
|
])
|
|
;;
|
|
|
|
let of_name_exn name =
|
|
let s = Dune_lang.Atom.to_string name in
|
|
of_string_user_error (Loc.none, s) |> User_error.ok_exn
|
|
;;
|
|
end
|
|
|
|
module Component = struct
|
|
module Options = struct
|
|
module Common = struct
|
|
type t =
|
|
{ name : Dune_lang.Atom.t
|
|
; public : Public_name.t option
|
|
; libraries : Dune_lang.Atom.t list
|
|
; pps : Dune_lang.Atom.t list
|
|
}
|
|
|
|
let package_name common =
|
|
let name =
|
|
match common.public with
|
|
| None -> Dune_lang.Atom.to_string common.name
|
|
| Some public -> Public_name.to_string public
|
|
in
|
|
Package.Name.of_string name
|
|
;;
|
|
end
|
|
|
|
module Executable = struct
|
|
type t = unit
|
|
end
|
|
|
|
module Library = struct
|
|
type t = { inline_tests : bool }
|
|
end
|
|
|
|
module Project = struct
|
|
module Template = struct
|
|
type t =
|
|
| Exec
|
|
| Lib
|
|
|
|
let of_string = function
|
|
| "executable" -> Some Exec
|
|
| "library" -> Some Lib
|
|
| _ -> None
|
|
;;
|
|
|
|
let commands = [ "executable", Exec; "library", Lib ]
|
|
end
|
|
|
|
module Pkg = struct
|
|
type t =
|
|
| Opam
|
|
| Esy
|
|
|
|
let commands = [ "opam", Opam; "esy", Esy ]
|
|
end
|
|
|
|
type t =
|
|
{ template : Template.t
|
|
; inline_tests : bool
|
|
; pkg : Pkg.t
|
|
}
|
|
end
|
|
|
|
module Test = struct
|
|
type t = unit
|
|
end
|
|
|
|
type 'options t =
|
|
{ context : Init_context.t
|
|
; common : Common.t
|
|
; options : 'options
|
|
}
|
|
end
|
|
|
|
(* Options *)
|
|
|
|
type 'options t =
|
|
| Executable : Options.Executable.t Options.t -> Options.Executable.t t
|
|
| Library : Options.Library.t Options.t -> Options.Library.t t
|
|
| Project : Options.Project.t Options.t -> Options.Project.t t
|
|
| Test : Options.Test.t Options.t -> Options.Test.t t
|
|
|
|
(** Internal representation of the files comprising a component *)
|
|
type target =
|
|
{ dir : Path.t
|
|
; files : File.t list
|
|
}
|
|
|
|
(** Creates Dune language CST stanzas describing components *)
|
|
module Stanza_cst = struct
|
|
open Dune_lang
|
|
|
|
module Field = struct
|
|
let inline_tests = Encoder.field_b "inline_tests"
|
|
let pps_encoder pps = Encoder.list Encoder.string ("pps" :: pps)
|
|
|
|
let preprocess_field = function
|
|
| [] -> []
|
|
| pps -> [ Encoder.field "preprocess" pps_encoder pps ]
|
|
;;
|
|
|
|
let common (options : Options.Common.t) =
|
|
[ Encoder.field "name" Encoder.string (Atom.to_string options.name)
|
|
; Encoder.field_l
|
|
"libraries"
|
|
Encoder.string
|
|
(List.map ~f:Atom.to_string options.libraries)
|
|
]
|
|
@ preprocess_field (List.map ~f:Atom.to_string options.pps)
|
|
;;
|
|
end
|
|
|
|
(* Make CST representation of a stanza for the given `kind` *)
|
|
let make kind common_options fields =
|
|
Encoder.named_record_fields kind (fields @ Field.common common_options)
|
|
(* Convert to a CST *)
|
|
|> Dune_lang.Ast.add_loc ~loc:Loc.none
|
|
|> Cst.concrete
|
|
(* Package as a list CSTs *) |> List.singleton
|
|
;;
|
|
|
|
let add_to_list_set elem set =
|
|
if List.mem ~equal:Dune_lang.Atom.equal set elem then set else elem :: set
|
|
;;
|
|
|
|
let public_name_field = Encoder.field_o "public_name" Public_name.encode
|
|
|
|
let executable (common : Options.Common.t) (() : Options.Executable.t) =
|
|
make "executable" common [ public_name_field common.public ]
|
|
;;
|
|
|
|
let library (common : Options.Common.t) { Options.Library.inline_tests } =
|
|
check_module_name common.name;
|
|
let common =
|
|
if inline_tests
|
|
then (
|
|
let pps =
|
|
add_to_list_set (Dune_lang.Atom.of_string "ppx_inline_test") common.pps
|
|
in
|
|
{ common with pps })
|
|
else common
|
|
in
|
|
make
|
|
"library"
|
|
common
|
|
[ public_name_field common.public; Field.inline_tests inline_tests ]
|
|
;;
|
|
|
|
let test common (() : Options.Test.t) = make "test" common []
|
|
|
|
(* A list of CSTs for dune-project file content *)
|
|
let dune_project
|
|
~opam_file_gen
|
|
~(defaults : Dune_config_file.Dune_config.Project_defaults.t)
|
|
dir
|
|
(common : Options.Common.t)
|
|
=
|
|
let cst =
|
|
let package =
|
|
Package.create
|
|
~name:(Options.Common.package_name common)
|
|
~loc:Loc.none
|
|
~version:None
|
|
~conflicts:[]
|
|
~depopts:[]
|
|
~info:Package_info.empty
|
|
~sites:Site.Map.empty
|
|
~allow_empty:false
|
|
~deprecated_package_names:Package.Name.Map.empty
|
|
~has_opam_file:(Exists false)
|
|
~original_opam_file:None
|
|
~dir
|
|
~synopsis:(Some "A short synopsis")
|
|
~description:(Some "A longer description")
|
|
~tags:[ "add topics"; "to describe"; "your"; "project" ]
|
|
~depends:
|
|
[ { Package_dependency.name = Package.Name.of_string "ocaml"
|
|
; constraint_ = None
|
|
}
|
|
]
|
|
in
|
|
let packages = Package.Name.Map.singleton (Package.name package) package in
|
|
let info =
|
|
Package_info.example
|
|
~authors:defaults.authors
|
|
~maintainers:defaults.maintainers
|
|
~license:defaults.license
|
|
in
|
|
Dune_project.anonymous ~dir info packages
|
|
|> Dune_project.set_generate_opam_files opam_file_gen
|
|
|> Dune_project.encode
|
|
|> List.map ~f:(fun exp ->
|
|
exp |> Dune_lang.Ast.add_loc ~loc:Loc.none |> Cst.concrete)
|
|
in
|
|
List.append
|
|
cst
|
|
[ Cst.Comment
|
|
( Loc.none
|
|
, [ " See the complete stanza docs at \
|
|
https://dune.readthedocs.io/en/stable/reference/dune-project/index.html"
|
|
] )
|
|
]
|
|
;;
|
|
end
|
|
|
|
(* TODO Support for merging in changes to an existing stanza *)
|
|
let add_stanza_to_dune_file ~(project : Dune_project.t) ~dir stanza =
|
|
File.load_dune_file ~path:dir |> File.Stanza.add project stanza
|
|
;;
|
|
|
|
(* Functions to make the various components, represented as lists of files *)
|
|
module Make = struct
|
|
let bin ({ context; common; options } : Options.Executable.t Options.t) =
|
|
let dir = context.dir in
|
|
let bin_dune =
|
|
Stanza_cst.executable common options
|
|
|> add_stanza_to_dune_file ~project:context.project ~dir
|
|
in
|
|
let bin_ml =
|
|
let name = sprintf "%s.ml" (Dune_lang.Atom.to_string common.name) in
|
|
let content = sprintf "let () = print_endline \"Hello, World!\"\n" in
|
|
File.make_text dir name content
|
|
in
|
|
let files = [ bin_dune; bin_ml ] in
|
|
[ { dir; files } ]
|
|
;;
|
|
|
|
let src ({ context; common; options } : Options.Library.t Options.t) =
|
|
let dir = context.dir in
|
|
let lib_dune =
|
|
Stanza_cst.library common options
|
|
|> add_stanza_to_dune_file ~project:context.project ~dir
|
|
in
|
|
let files = [ lib_dune ] in
|
|
[ { dir; files } ]
|
|
;;
|
|
|
|
let test ({ context; common; options } : Options.Test.t Options.t) =
|
|
(* Marking the current absence of test-specific options *)
|
|
let dir = context.dir in
|
|
let test_dune =
|
|
Stanza_cst.test common options
|
|
|> add_stanza_to_dune_file ~project:context.project ~dir
|
|
in
|
|
let test_ml =
|
|
let name = sprintf "%s.ml" (Dune_lang.Atom.to_string common.name) in
|
|
let content = "" in
|
|
File.make_text dir name content
|
|
in
|
|
let files = [ test_dune; test_ml ] in
|
|
[ { dir; files } ]
|
|
;;
|
|
|
|
let dune_project_file dir ({ context; common; options } : Options.Project.t Options.t)
|
|
=
|
|
let opam_file_gen =
|
|
match options.pkg with
|
|
| Opam -> true
|
|
| Esy -> false
|
|
in
|
|
let content =
|
|
Stanza_cst.dune_project
|
|
~opam_file_gen
|
|
~defaults:context.defaults
|
|
Path.(as_in_source_tree_exn context.dir)
|
|
common
|
|
in
|
|
File.Dune { path = dir; content; name = "dune-project" }
|
|
;;
|
|
|
|
let proj_exec dir ({ context; common; options } : Options.Project.t Options.t) =
|
|
let lib_target =
|
|
src
|
|
{ context = { context with dir = Path.relative dir "lib" }
|
|
; options = { inline_tests = options.inline_tests }
|
|
; common = { common with public = None }
|
|
}
|
|
in
|
|
let test_target =
|
|
let test_name = "test_" ^ Dune_lang.Atom.to_string common.name in
|
|
test
|
|
{ context = { context with dir = Path.relative dir "test" }
|
|
; options = ()
|
|
; common = { common with name = Dune_lang.Atom.of_string test_name }
|
|
}
|
|
in
|
|
let bin_target =
|
|
(* Add the lib_target as a library to the executable*)
|
|
let libraries = Stanza_cst.add_to_list_set common.name common.libraries in
|
|
bin
|
|
{ context = { context with dir = Path.relative dir "bin" }
|
|
; options = ()
|
|
; common = { common with libraries; name = Dune_lang.Atom.of_string "main" }
|
|
}
|
|
in
|
|
bin_target @ lib_target @ test_target
|
|
;;
|
|
|
|
let proj_lib dir ({ context; common; options } : Options.Project.t Options.t) =
|
|
let lib_target =
|
|
src
|
|
{ context = { context with dir = Path.relative dir "lib" }
|
|
; options = { inline_tests = options.inline_tests }
|
|
; common
|
|
}
|
|
in
|
|
let test_target =
|
|
let test_name = "test_" ^ Dune_lang.Atom.to_string common.name in
|
|
test
|
|
{ context = { context with dir = Path.relative dir "test" }
|
|
; options = ()
|
|
; common = { common with name = Dune_lang.Atom.of_string test_name }
|
|
}
|
|
in
|
|
lib_target @ test_target
|
|
;;
|
|
|
|
let proj ({ common; options; _ } as opts : Options.Project.t Options.t) =
|
|
let ({ template; pkg; _ } : Options.Project.t) = options in
|
|
let dir = Path.Source.root in
|
|
let proj_target =
|
|
let package_files =
|
|
match (pkg : Options.Project.Pkg.t) with
|
|
| Opam ->
|
|
let name = Options.Common.package_name common in
|
|
let opam_file = Path.source @@ Package_name.file name ~dir in
|
|
[ File.make_text (Path.parent_exn opam_file) (Path.basename opam_file) "" ]
|
|
| Esy -> [ File.make_text (Path.source dir) "package.json" "" ]
|
|
in
|
|
let dir = Path.source dir in
|
|
{ dir; files = dune_project_file dir opts :: package_files }
|
|
in
|
|
let component_targets =
|
|
(match (template : Options.Project.Template.t) with
|
|
| Exec -> proj_exec
|
|
| Lib -> proj_lib)
|
|
(Path.source dir)
|
|
opts
|
|
in
|
|
proj_target :: component_targets
|
|
;;
|
|
end
|
|
|
|
let report_uncreated_file = function
|
|
| Ok _ -> ()
|
|
| Error path ->
|
|
let open Pp.O in
|
|
User_warning.emit
|
|
[ Pp.textf "File "
|
|
++ Pp.tag
|
|
User_message.Style.Kwd
|
|
(Pp.verbatim (Path.to_string_maybe_quoted path))
|
|
++ Pp.text " was not created because it already exists"
|
|
]
|
|
;;
|
|
|
|
(** Creates a component, writing the files to disk *)
|
|
let create target =
|
|
File.create_dir target.dir;
|
|
List.map ~f:File.write target.files
|
|
;;
|
|
|
|
let init (type options) (t : options t) =
|
|
let target =
|
|
match t with
|
|
| Executable params -> Make.bin params
|
|
| Library params -> Make.src params
|
|
| Project params -> Make.proj params
|
|
| Test params -> Make.test params
|
|
in
|
|
List.concat_map ~f:create target |> List.iter ~f:report_uncreated_file
|
|
;;
|
|
end
|