unikernel/duniverse/dune_/bin/init.ml

@@ -0,0 +1,341 @@
+open Import
+open Dune_init
+
+(** {1 Helper functions} *)
+
+(** {2 Cmdliner Argument Converters} *)
+
+let atom_parser s =
+  match Dune_lang.Atom.parse s with
+  | Some s -> Ok s
+  | None -> Error (`Msg "expected a valid dune atom")
+;;
+
+let atom_printer ppf a = Format.pp_print_string ppf (Dune_lang.Atom.to_string a)
+
+let component_name_parser s =
+  (* TODO refactor to use Lib_name.Local.conv *)
+  let err_msg () =
+    User_error.make
+      [ Pp.textf "invalid component name `%s'" s; Lib_name.Local.valid_format_doc ]
+    |> User_message.to_string
+    |> fun m -> `Msg m
+  in
+  let open Result.O in
+  let* atom = atom_parser s in
+  let* _ =
+    match Lib_name.Local.of_string_opt s with
+    | None -> Error (err_msg ())
+    | Some s -> Ok s
+  in
+  Ok atom
+;;
+
+let project_name_parser s =
+  (* TODO refactor Dune_project_name to be Stringlike *)
+  match Dune_project_name.named Loc.none s with
+  | v -> Ok v
+  | exception User_error.E _ ->
+    User_error.make
+      [ Pp.textf "invalid project name `%s'" s
+      ; Pp.text
+          "Project names must start with a letter and be composed only of letters, \
+           numbers, '-' or '_'"
+      ]
+    |> User_message.to_string
+    |> fun m -> Error (`Msg m)
+;;
+
+let project_name_printer ppf p =
+  Format.pp_print_string ppf (Dune_project_name.to_string_hum p)
+;;
+
+let atom_conv = Arg.conv (atom_parser, atom_printer)
+let component_name_conv = Arg.conv (component_name_parser, atom_printer)
+let project_name_conv = Arg.conv (project_name_parser, project_name_printer)
+
+(** {2 Status reporting} *)
+
+let print_completion kind name =
+  let open Pp.O in
+  Console.print_user_message
+    (User_message.make
+       [ Pp.tag User_message.Style.Ok (Pp.verbatim "Success")
+         ++ Pp.textf ": initialized %s component named " kind
+         ++ Pp.tag User_message.Style.Kwd (Pp.verbatim (Dune_lang.Atom.to_string name))
+       ])
+;;
+
+(** {1 CLI} *)
+
+let path =
+  let docv = "PATH" in
+  Arg.(value & pos 1 (some string) None & info [] ~docv)
+;;
+
+let context_cwd : Init_context.t Term.t =
+  let+ builder = Common.Builder.term
+  and+ path = path in
+  let builder = Common.Builder.set_default_root_is_cwd builder true in
+  let common, config = Common.init builder in
+  let project_defaults = config.project_defaults in
+  Scheduler.go_with_rpc_server ~common ~config (fun () ->
+    Memo.run (Init_context.make path project_defaults))
+;;
+
+module Public_name = struct
+  type t =
+    | Use_name
+    | Public_name of Public_name.t
+
+  let public_name_to_string = function
+    | Use_name -> "<default>"
+    | Public_name p -> Public_name.to_string p
+  ;;
+
+  let public_name default_name = function
+    | None -> None
+    | Some Use_name -> Some (Public_name.of_name_exn default_name)
+    | Some (Public_name n) -> Some n
+  ;;
+
+  let conv =
+    let parser s =
+      if String.is_empty s
+      then Ok Use_name
+      else (
+        match Public_name.of_string_user_error (Loc.none, s) with
+        | Ok n -> Ok (Public_name n)
+        | Error e -> Error (`Msg (User_message.to_string e)))
+    in
+    let printer ppf public_name =
+      Format.pp_print_string ppf (public_name_to_string public_name)
+    in
+    Arg.conv (parser, printer)
+  ;;
+end
+
+let libraries =
+  let docv = "LIBRARIES" in
+  let doc = "A comma separated list of libraries on which the component depends" in
+  Arg.(value & opt (list atom_conv) [] & info [ "libs" ] ~docv ~doc)
+;;
+
+let pps =
+  let docv = "PREPROCESSORS" in
+  let doc = "A comma separated list of ppx preprocessors used by the component" in
+  Arg.(value & opt (list atom_conv) [] & info [ "ppx" ] ~docv ~doc)
+;;
+
+let public : Public_name.t option Term.t =
+  let docv = "PUBLIC_NAME" in
+  let doc =
+    "If called with an argument, make the component public under the given PUBLIC_NAME. \
+     If supplied without an argument, use NAME."
+  in
+  Arg.(
+    value
+    & opt ~vopt:(Some Public_name.Use_name) (some Public_name.conv) None
+    & info [ "public" ] ~docv ~doc)
+;;
+
+let common : Component.Options.Common.t Term.t =
+  let+ name =
+    let docv = "NAME" in
+    Arg.(required & pos 0 (some component_name_conv) None & info [] ~docv)
+  and+ public = public
+  and+ libraries = libraries
+  and+ pps = pps in
+  let public = Public_name.public_name name public in
+  { Component.Options.Common.name; public; libraries; pps }
+;;
+
+let project_common : Component.Options.Common.t Term.t =
+  let+ project_name =
+    let docv = "NAME" in
+    Arg.(required & pos 0 (some project_name_conv) None & info [] ~docv)
+  and+ libraries = libraries
+  and+ pps = pps in
+  let public = Dune_project_name.to_string_hum project_name in
+  let name =
+    String.map
+      ~f:(function
+        | '-' -> '_'
+        | c -> c)
+      public
+    |> Dune_lang.Atom.of_string
+  in
+  let public =
+    Some (Dune_lang.Atom.of_string public |> Dune_init.Public_name.of_name_exn)
+  in
+  { Component.Options.Common.name; public; libraries; pps }
+;;
+
+let inline_tests : bool Term.t =
+  let docv = "USE_INLINE_TESTS" in
+  let doc =
+    "Whether to use inline tests. Only applicable for $(b,library) and $(b,project) \
+     components."
+  in
+  Arg.(value & flag & info [ "inline-tests" ] ~docv ~doc)
+;;
+
+let opt_default ~default term = Term.(const (Option.value ~default) $ term)
+
+let executable =
+  let doc = "A binary executable." in
+  let man = [] in
+  let kind = "executable" in
+  Cmd.v (Cmd.info kind ~doc ~man)
+  @@ let+ context = context_cwd
+     and+ common = common in
+     Component.init (Executable { context; common; options = () });
+     print_completion kind common.name
+;;
+
+let library =
+  let doc = "An OCaml library." in
+  let man = [] in
+  let kind = "library" in
+  Cmd.v (Cmd.info kind ~doc ~man)
+  @@ let+ context = context_cwd
+     and+ common = common
+     and+ inline_tests = inline_tests in
+     Component.init (Library { context; common; options = { inline_tests } });
+     print_completion kind common.name
+;;
+
+let test =
+  let doc =
+    "A test harness. (For inline tests, use the $(b,--inline-tests) flag along with the \
+     other component kinds.)"
+  in
+  let man = [] in
+  let kind = "test" in
+  Cmd.v (Cmd.info kind ~doc ~man)
+  @@ let+ context = context_cwd
+     and+ common = common in
+     Component.init (Test { context; common; options = () });
+     print_completion kind common.name
+;;
+
+let project =
+  let module Builder = Common.Builder in
+  let doc =
+    "A project is a predefined composition of components arranged in a standard \
+     directory structure. The kind of project initialized is determined by the value of \
+     the $(b,--kind) flag and defaults to an executable project, composed of a library, \
+     an executable, and a test component."
+  in
+  let man = [] in
+  Cmd.v (Cmd.info "project" ~doc ~man)
+  @@ let+ common_builder = Builder.term
+     and+ path = path
+     and+ common = project_common
+     and+ inline_tests = inline_tests
+     and+ template =
+       let docv = "PROJECT_KIND" in
+       let doc =
+         "The kind of project to initialize. Valid options are $(b,e[xecutable]) or \
+          $(b,l[ibrary]). Defaults to $(b,executable). Only applicable for $(b,project) \
+          components."
+       in
+       opt_default
+         ~default:Component.Options.Project.Template.Exec
+         Arg.(
+           value
+           & opt (some (enum Component.Options.Project.Template.commands)) None
+           & info [ "kind" ] ~docv ~doc)
+     and+ pkg =
+       let docv = "PACKAGE_MANAGER" in
+       let doc =
+         "Which package manager to use. Valid options are $(b,o[pam]) or $(b,e[sy]). \
+          Defaults to $(b,opam). Only applicable for $(b,project) components."
+       in
+       opt_default
+         ~default:Component.Options.Project.Pkg.Opam
+         Arg.(
+           value
+           & opt (some (enum Component.Options.Project.Pkg.commands)) None
+           & info [ "pkg" ] ~docv ~doc)
+     in
+     let name =
+       match common.public with
+       | None -> Dune_lang.Atom.to_string common.name
+       | Some public -> Dune_init.Public_name.to_string public
+     in
+     let context =
+       let init_context = Init_context.make path in
+       let root =
+         match path with
+         (* If a path is given, we use that for the root during project
+            initialization, creating the path to it if needed. *)
+         | Some path -> path
+         (* Otherwise we will use the project's given name, and create a
+            directory accordingly. *)
+         | None -> name
+       in
+       let builder = Builder.set_root common_builder root in
+       let (_ : Fpath.mkdir_p_result) = Fpath.mkdir_p root in
+       let common, config = Common.init builder in
+       let project_defaults = config.project_defaults in
+       Scheduler.go_with_rpc_server ~common ~config (fun () ->
+         Memo.run @@ init_context project_defaults)
+     in
+     Component.init
+       (Project { context; common; options = { template; inline_tests; pkg } });
+     print_completion "project" (Dune_lang.Atom.of_string name)
+;;
+
+let group =
+  let doc = "Command group for initializing Dune components." in
+  let synopsis =
+    Common.command_synopsis
+      [ "init project NAME [PATH] [OPTION]... "
+      ; "init executable NAME [PATH] [OPTION]... "
+      ; "init library NAME [PATH] [OPTION]... "
+      ; "init test NAME [PATH] [OPTION]... "
+      ]
+  in
+  let man =
+    [ `Blocks synopsis
+    ; `S "DESCRIPTION"
+    ; `P
+        {|$(b,dune init COMPONENT NAME [PATH] [OPTION]...) initializes a new dune
+        configuration for a component of the kind specified by the subcommand
+        $(b,COMPONENT), named $(b,NAME), with fields determined by the supplied
+        $(b,OPTION)s.|}
+    ; `P
+        {|Run a subcommand with $(b, --help) for for details on it's supported arguments|}
+    ; `P
+        {|If the optional $(b,PATH) is provided, it must be a path to a directory, and
+        the component will be created there. Otherwise, it is created in a child of the
+        current working directory, called $(b, NAME). To initialize a component in the
+        current working directory, use `.` as the $(b,PATH).|}
+    ; `P
+        {|Any prefix of a $(b,COMMAND)'s name can be supplied in place of
+        full name (as illustrated in the synopsis).|}
+    ; `P
+        {|For more details, see https://dune.readthedocs.io/en/stable/usage.html#initializing-components|}
+    ; Common.examples
+        [ ( {|Generate a project skeleton for an executable named `myproj' in a
+            new directory named `myproj', depending on the bos library and
+            using inline tests along with ppx_inline_test |}
+          , {|dune init project myproj --libs bos --ppx ppx_inline_test --inline-tests|} )
+        ; ( {|Configure an executable component named `myexe' in a dune file in the
+            current directory|}
+          , {|dune init executable myexe|} )
+        ; ( {|Configure a library component named `mylib' in a dune file in the ./src
+            directory depending on the core and cmdliner libraries, the ppx_let
+            and ppx_inline_test preprocessors, and declared as using inline
+            tests|}
+          , {|dune init library mylib src --libs core,cmdliner --ppx ppx_let,ppx_inline_test --inline-tests|}
+          )
+        ; ( {|Configure a test component named `mytest' in a dune file in the
+            ./test directory that depends on `mylib'|}
+          , {|dune init test mytest test --libs mylib|} )
+        ]
+    ]
+  in
+  Cmd.group (Cmd.info "init" ~doc ~man) [ executable; project; library; test ]
+;;