Add dune init command

Towards completion of ocaml#159

Signed-off-by: Shon Feder <[email protected]>

bin/main.ml

@@ -899,6 +899,44 @@ let utop =
   in
   (term, Term.info "utop" ~doc ~man )
 
+module Init = struct
+  open Init
+  let lib =
+    let doc = "The project is intended to be a library" in
+    (Kind.Library, Arg.info ["lib"; "library"] ~doc)
+
+  let bin =
+    let doc = "The project is intended to be an executable" in
+    (Kind.Executable, Arg.info ["bin"; "binary"] ~doc)
+
+  let init =
+    let doc = "Initialize a new dune project" in
+    let man =
+      [ `S "DESCRIPTION"
+      ; `P {|$(b,dune init NAME [PATH] [{--lib,--bin}] ) initialize a new dune
+             project named $(b,NAME) from the default template.|}
+      ; `P {|If the optional $(b,PATH) is provided, the project will be created
+             there. Otherwise, it is created in a directory $(b,NAME) relative
+             to the current working directory.|}
+      ; `P {|The flags $(b,--lib) and $(b,--bin) specify whether the created
+             project should be set up as a library or as an executable program
+             (respectively). The defaults behavior is to create libraries.|}
+      ] in
+    let term =
+      let%map common = Common.term
+      and name =
+        Arg.(required & pos 0 (some string) None & Arg.info [] ~docv:"NAME")
+      and kind =
+        Arg.(last & vflag_all [Kind.Library] [lib; bin])
+      and path =
+        Arg.(value & pos 1 (some string) None & Arg.info [] ~docv:"PATH" )
+      in
+      Common.set_dirs common;
+      make_project name kind path
+    in
+    (term, Term.info "init" ~doc ~man)
+end
+
 let promote =
   let doc = "Promote files from the last run" in
   let man =
@@ -1147,6 +1185,7 @@ let all =
   ; subst
   ; rules
   ; utop
+  ; Init.init
   ; promote
   ; printenv
   ; Help.help

src/dune_project.ml

@@ -164,14 +164,17 @@ module Project_file_edit = struct
   let notify_user s =
     kerrf ~f:print_to_console "@{<warning>Info@}: %s\n" s
 
+  let lang_stanza () =
+    let ver = (Lang.get_exn "dune").version in
+    sprintf "(lang dune %s)" (Syntax.Version.to_string ver)
+
   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
+      let content = lang_stanza () 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;
+           (Path.to_string_maybe_quoted t.file) content);
+      Io.write_file t.file (content ^ "\n") ~binary:false;
       t.exists <- true
     end
 
@@ -192,6 +195,8 @@ module Project_file_edit = struct
         if len > 0 && s.[len - 1] <> '\n' then output_char oc '\n'))
 end
 
+let lang_stanza = Project_file_edit.lang_stanza
+
 let ensure_project_file_exists t =
   Project_file_edit.ensure_exists t.project_file
 

src/dune_project.mli

@@ -95,6 +95,9 @@ val filename : string
     the workspace contains no [dune-project] or [<package>.opam] files. *)
 val anonymous : t Lazy.t
 
+(** Generate an appropriate project [lang] stanza *)
+val lang_stanza : unit -> string
+
 (** Check that the dune-project file exists and create it otherwise. *)
 val ensure_project_file_exists : t -> unit
 

src/init.ml

@@ -0,0 +1,162 @@
+open! Stdune
+open! Import
+
+module Kind = struct
+  type t =
+    | Library
+    | Executable
+
+  let to_string = function
+    | Library -> "library"
+    | Executable -> "executable"
+end
+
+module File = struct
+  type t =
+    { path: Path.t
+    ; name: string
+    ; content: string }
+
+  let make path name content =
+    {path; name; content}
+
+  let full_path {path; name; _} =
+    Path.relative path name
+
+  let create file =
+    let path = full_path file in
+    if Path.exists path then
+      Error path
+    else
+      Ok (Io.write_file ~binary:false path file.content)
+end
+
+module Init_context = struct
+  type t =
+    { kind : Kind.t
+    ; pname : string
+    ; dir : Path.t }
+
+  let make pname kind path =
+    let dir =
+      match path with
+      | None -> Path.of_filename_relative_to_initial_cwd pname
+      | Some path ->
+        if Filename.is_relative path then
+          Path.of_filename_relative_to_initial_cwd path
+        else
+          Path.of_string path
+    in
+    {kind; pname; dir}
+end
+
+module Project_dir = struct
+  type t =
+    { dir : Path.t
+    ; files : File.t list }
+
+  let root (c : Init_context.t) =
+    let package_opam =
+      let name = Printf.sprintf "%s.opam" c.pname in
+      File.make c.dir name ""
+    in
+    {dir = c.dir; files = [package_opam]}
+
+  let lib (c : Init_context.t) =
+    let dir = Path.relative c.dir "src" in
+    let lib_dune =
+      let name = "dune" in
+      let content = Printf.sprintf "\
+  ;; Uncomment stanzas to include their functionality
+  (library
+    (name %s)
+    (public_name %s)
+    ;; (inline_tests)
+    ;; (libraries core)
+    ;; (preprocess (pps ppx_inline_test))
+  )
+  " c.pname c.pname
+      in
+      File.make dir name content
+    in
+    {dir; files = [lib_dune]}
+
+  let bin (c : Init_context.t) =
+    let dir = Path.relative c.dir "bin" in
+    let make_file = File.make dir
+    in
+    let bin_dune =
+      let name = "dune" in
+      let content = Printf.sprintf "\
+  (executable
+    (public_name %s)
+    (name main)
+    (libraries %s))
+  " c.pname c.pname
+      in
+      make_file name content
+    in
+    let bin_ml =
+      let name = "main.ml" in
+      let content = Printf.sprintf "let () = print_endline \"Hello, World!\"\n" in
+      make_file name content
+    in
+    let files = [bin_dune; bin_ml]
+    in
+    {dir; files}
+
+  let create_dir t =
+    try Path.mkdir_p t.dir with
+    | Unix.Unix_error (EACCES, _, _) ->
+      Exn.fatalf "A project directory cannot be created: \
+                  Lacking permissions needed to create directory %s"
+        (Path.to_string t.dir)
+
+  let report_uncreated_file = function
+    | Ok _ -> ()
+    | Error path ->
+      Errors.kerrf ~f:print_to_console
+        "@{<warning>Warning@}: file @{<kwd>%s@} was not created \
+         because it already exists\n"
+        (Path.to_string path)
+
+  let create_files t =
+    t.files
+    |> List.map ~f:File.create
+    |> List.iter ~f:report_uncreated_file
+
+  let create t =
+    create_dir t;
+    create_files t
+end
+
+let validate_project_name name =
+  match Lib_name.Local.of_string name with
+  | Ok _ -> ()
+  | _ -> Exn.fatalf "A project named '%s' cannot be created because it is an %s"
+           name Lib_name.Local.invalid_message
+
+let make_project_dirs (c : Init_context.t) =
+  (* dirs that are always included in a project *)
+  let project_dirs =
+    [
+      Project_dir.root c; (* The project dir should always be first *)
+      Project_dir.lib c;
+    ]
+  in
+  let project_dirs = match c.kind with
+    | Kind.Library -> project_dirs
+    | Kind.Executable -> project_dirs @ [Project_dir.bin c]
+  in
+  List.iter ~f:Project_dir.create project_dirs
+
+let print_completion (c : Init_context.t) =
+  Errors.kerrf ~f:print_to_console
+    "@{<ok>Success@}: initialized %s project @{<kwd>%s@}\n"
+    (Kind.to_string c.kind) c.pname
+
+let make_project pname kind path =
+  validate_project_name pname;
+  let context = Init_context.make pname kind path in
+  make_project_dirs context;
+  print_completion context

src/init.mli

@@ -0,0 +1,13 @@
+open! Stdune
+
+(** Supported kinds of projects for initialization *)
+module Kind : sig
+  type t =
+    | Library
+    | Executable
+end
+
+(** [make_project pname kind path] will make a project of the given [kind]
+    with the supplied [pname], at the optional [path] (defaulting to the
+    current working directory if the [path] is [None]). *)
+val make_project : string -> Kind.t -> string option -> unit