unikernel/duniverse/dune_/bin/dune_init.ml

@@ -0,0 +1,611 @@
+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