Merge branch 'master' into run-with-accepted-exit-codes

bin/alias.ml

@@ -1,7 +1,7 @@
 open Stdune
 
 type t =
-  { name : string
+  { name : Dune.Alias.Name.t
   ; recursive : bool
   ; dir : Path.Source.t
   ; contexts : Dune.Context.t list
@@ -18,7 +18,7 @@ let to_log_string { name; recursive; dir; contexts = _ } =
     else
       "@@" )
     (Path.Source.to_string_maybe_quoted dir)
-    name
+    (Dune.Alias.Name.to_string name)
 
 let in_dir ~name ~recursive ~contexts dir =
   let checked = Util.check_path contexts dir in
@@ -50,5 +50,5 @@ let of_string common ~recursive s ~contexts =
       ]
   else
     let dir = Path.parent_exn path in
-    let name = Path.basename path in
+    let name = Dune.Alias.Name.of_string (Path.basename path) in
     in_dir ~name ~recursive ~contexts dir

bin/alias.mli

@@ -1,14 +1,18 @@
 open Stdune
 
 type t = private
-  { name : string
+  { name : Dune.Alias.Name.t
   ; recursive : bool
   ; dir : Path.Source.t
   ; contexts : Dune.Context.t list
   }
 
 val in_dir :
-  name:string -> recursive:bool -> contexts:Dune.Context.t list -> Path.t -> t
+     name:Dune.Alias.Name.t
+  -> recursive:bool
+  -> contexts:Dune.Context.t list
+  -> Path.t
+  -> t
 
 val of_string :
   Common.t -> recursive:bool -> string -> contexts:Dune.Context.t list -> t

bin/arg.ml

@@ -29,9 +29,17 @@ module Dep = struct
 
   let file s = Dep_conf.File (String_with_vars.make_text Loc.none s)
 
-  let alias s = Dep_conf.Alias (String_with_vars.make_text Loc.none s)
+  let make_alias_sw ~dir s =
+    let path =
+      Dune.Alias.Name.to_string s
+      |> Stdune.Path.Local.relative dir
+      |> Stdune.Path.Local.to_string
+    in
+    String_with_vars.make_text Loc.none path
+
+  let alias ~dir s = Dep_conf.Alias (make_alias_sw ~dir s)
 
-  let alias_rec s = Dep_conf.Alias_rec (String_with_vars.make_text Loc.none s)
+  let alias_rec ~dir s = Dep_conf.Alias_rec (make_alias_sw ~dir s)
 
   let parse_alias s =
     if not (String.is_prefix s ~prefix:"@") then
@@ -44,15 +52,19 @@ module Dep = struct
           (1, true)
       in
       let s = String.drop s pos in
-      Some (recursive, s)
+      let dir, alias =
+        let path = Stdune.Path.Local.of_string s in
+        Dune.Alias.Name.parse_local_path (Loc.none, path)
+      in
+      Some (recursive, dir, alias)
 
   let dep_parser =
     Dune_lang.Syntax.set Stanza.syntax Stanza.latest_version Dep_conf.decode
 
   let parser s =
     match parse_alias s with
-    | Some (true, s) -> `Ok (alias_rec s)
-    | Some (false, s) -> `Ok (alias s)
+    | Some (true, dir, name) -> `Ok (alias_rec ~dir name)
+    | Some (false, dir, name) -> `Ok (alias ~dir name)
     | None -> (
       match
         Dune_lang.Decoder.parse dep_parser Univ_map.empty

bin/arg.mli

@@ -18,9 +18,9 @@ module Dep : sig
 
   val file : string -> t
 
-  val alias : string -> t
+  val alias : dir:Stdune.Path.Local.t -> Dune.Alias.Name.t -> t
 
-  val alias_rec : string -> t
+  val alias_rec : dir:Stdune.Path.Local.t -> Dune.Alias.Name.t -> t
 
   val to_string_maybe_quoted : t -> string
 end

bin/common.ml

@@ -248,7 +248,8 @@ module Options_implied_by_dash_p = struct
     and+ default_target =
       Arg.(
         value
-        & opt dep (Dep.alias "default")
+        & opt dep
+            (Dep.alias ~dir:Stdune.Path.Local.root Dune.Alias.Name.default)
         & info [ "default-target" ] ~docs ~docv:"TARGET"
             ~doc:
               {|Set the default target that when none is specified to
@@ -295,7 +296,8 @@ module Options_implied_by_dash_p = struct
     ; ignore_promoted_rules = true
     ; config_file = No_config
     ; profile = Some Profile.Release
-    ; default_target = Arg.Dep.alias_rec "install"
+    ; default_target =
+        Arg.Dep.alias_rec ~dir:Path.Local.root Dune.Alias.Name.install
     ; always_show_command_line = true
     ; promote_install_files = true
     }

bin/main.ml

@@ -63,20 +63,13 @@ let runtest =
     Common.set_common common
       ~targets:
         (List.map dirs ~f:(fun s ->
-             let prefix =
-               match s with
-               | ""
-               | "." ->
-                 ""
-               | dir when dir.[String.length dir - 1] = '/' -> dir
-               | dir -> dir ^ "/"
-             in
-             Arg.Dep.alias_rec (prefix ^ "runtest")));
+             let dir = Path.Local.of_string s in
+             Arg.Dep.alias_rec ~dir Dune.Alias.Name.runtest));
     let targets (setup : Main.build_system) =
       List.map dirs ~f:(fun dir ->
           let dir = Path.(relative root) (Common.prefix_target common dir) in
           Target.Alias
-            (Alias.in_dir ~name:"runtest" ~recursive:true
+            (Alias.in_dir ~name:Dune.Alias.Name.runtest ~recursive:true
                ~contexts:setup.workspace.contexts dir))
     in
     run_build_command ~common ~targets

bin/target.ml

@@ -64,7 +64,7 @@ let resolve_path path ~(setup : Dune.Main.build_system) =
     if Dune.File_tree.dir_exists src then
       Some
         [ Alias
-            (Alias.in_dir ~name:"default" ~recursive:true
+            (Alias.in_dir ~name:Dune.Alias.Name.default ~recursive:true
                ~contexts:setup.workspace.contexts path)
         ]
     else

src/dune/alias.ml

@@ -1,31 +1,124 @@
 open! Stdune
 open Import
 
+module Name : sig
+  type t
+
+  include Dune_lang.Conv.S with type t := t
+
+  val equal : t -> t -> bool
+
+  val hash : t -> int
+
+  val compare : t -> t -> Ordering.t
+
+  val of_string : string -> t
+
+  val parse_string_exn : Loc.t * string -> t
+
+  val to_string : t -> string
+
+  val to_dyn : t -> Dyn.t
+
+  val default : t
+
+  val runtest : t
+
+  val install : t
+
+  val all : t
+
+  val parse_local_path : Loc.t * Path.Local.t -> Path.Local.t * t
+
+  module Map : Map.S with type key = t
+end = struct
+  include String
+
+  let of_string_opt_loose s = Option.some_if (Filename.basename s = s) s
+
+  let of_string_opt = function
+    (* The [""] case is caught by of_string_opt_loose. But there's no harm in
+       being more explicit about it *)
+    | ""
+    | "."
+    | "/"
+    | ".." ->
+      None
+    | s -> of_string_opt_loose s
+
+  let invalid_alias = Pp.textf "%S is not a valid alias name"
+
+  let parse_string_exn ~syntax (loc, s) =
+    let of_string_opt =
+      if syntax >= (2, 0) then
+        of_string_opt
+      else
+        of_string_opt_loose
+    in
+    match of_string_opt s with
+    | None -> User_error.raise ~loc [ invalid_alias s ]
+    | Some s -> s
+
+  let encode = Dune_lang.Encoder.string
+
+  let decode =
+    let open Dune_lang.Decoder in
+    let* syntax = Dune_lang.Syntax.get_exn Stanza.syntax in
+    plain_string (fun ~loc s -> parse_string_exn ~syntax (loc, s))
+
+  let parse_string_exn = parse_string_exn ~syntax:Stanza.latest_version
+
+  let of_string s =
+    match of_string_opt s with
+    | Some s -> s
+    | None ->
+      Code_error.raise "invalid alias name" [ ("s", Dyn.Encoder.string s) ]
+
+  let to_string s = s
+
+  let default = "default"
+
+  let runtest = "runtest"
+
+  let install = "install"
+
+  let all = "all"
+
+  let to_dyn = String.to_dyn
+
+  let parse_local_path (loc, p) =
+    match Path.Local.parent p with
+    | Some dir -> (dir, Path.Local.basename p)
+    | None ->
+      User_error.raise ~loc
+        [ Pp.textf "Invalid alias path: %S"
+            (Path.Local.to_string_maybe_quoted p)
+        ]
+end
+
 module T : sig
   type t = private
     { dir : Path.Build.t
-    ; name : string
+    ; name : Name.t
     }
 
-  val make : string -> dir:Path.Build.t -> t
+  val make : Name.t -> dir:Path.Build.t -> t
 
   val of_user_written_path : loc:Loc.t -> Path.t -> t
 end = struct
   type t =
     { dir : Path.Build.t
-    ; name : string
+    ; name : Name.t
     }
 
   let make name ~dir =
-    if String.contains name '/' then
-      Code_error.raise "Alias0.make: Invalid alias"
-        [ ("name", Dyn.Encoder.string name); ("dir", Path.Build.to_dyn dir) ];
     { dir; name }
 
   let of_user_written_path ~loc path =
     match Path.as_in_build_dir path with
     | Some path ->
-      { dir = Path.Build.parent_exn path; name = Path.Build.basename path }
+      let name = Name.of_string (Path.Build.basename path) in
+      { dir = Path.Build.parent_exn path; name }
     | None ->
       User_error.raise ~loc
         [ Pp.text "Invalid alias!"
@@ -37,19 +130,20 @@ end
 include T
 
 let compare x y =
-  match String.compare x.name y.name with
+  match Name.compare x.name y.name with
   | (Lt | Gt) as x -> x
   | Eq -> Path.Build.compare x.dir y.dir
 
 let equal x y = compare x y = Eq
 
-let hash { dir; name } = Tuple.T2.hash Path.Build.hash String.hash (dir, name)
+let hash { dir; name } = Tuple.T2.hash Path.Build.hash Name.hash (dir, name)
 
-let pp fmt t = Path.Build.pp fmt (Path.Build.relative t.dir t.name)
+let pp fmt t =
+  Path.Build.pp fmt (Path.Build.relative t.dir (Name.to_string t.name))
 
 let to_dyn { dir; name } =
   let open Dyn in
-  Record [ ("dir", Path.Build.to_dyn dir); ("name", String name) ]
+  Record [ ("dir", Path.Build.to_dyn dir); ("name", Name.to_dyn name) ]
 
 let suffix = "-" ^ String.make 32 '0'
 
@@ -64,9 +158,9 @@ let stamp_file_dir t =
   let local = Path.Build.local t.dir in
   Path.Build.append_local alias_dir local
 
-let fully_qualified_name t = Path.Build.relative t.dir t.name
+let fully_qualified_name t = Path.Build.relative t.dir (Name.to_string t.name)
 
-let stamp_file t = Path.Build.relative (stamp_file_dir t) (t.name ^ suffix)
+let stamp_file t = Path.Build.relative (stamp_file_dir t) ((Name.to_string t.name) ^ suffix)
 
 let find_dir_specified_on_command_line ~dir =
   match File_tree.find_dir dir with
@@ -77,32 +171,32 @@ let find_dir_specified_on_command_line ~dir =
       ]
   | Some dir -> dir
 
-let standard_aliases = Table.create (module String) 7
+let standard_aliases = Table.create (module Name) 7
 
 let is_standard name = Table.mem standard_aliases name
 
 let make_standard name =
   Table.add_exn standard_aliases name ();
   make name
 
-let default = make_standard "default"
+let default = make_standard Name.default
 
-let runtest = make_standard "runtest"
+let runtest = make_standard Name.runtest
 
-let install = make_standard "install"
+let install = make_standard Name.install
 
-let doc = make_standard "doc"
+let doc = make_standard (Name.of_string "doc")
 
-let private_doc = make_standard "doc-private"
+let private_doc = make_standard (Name.of_string "doc-private")
 
-let lint = make_standard "lint"
+let lint = make_standard (Name.of_string "lint")
 
-let all = make_standard "all"
+let all = make_standard (Name.of_string "all")
 
-let check = make_standard "check"
+let check = make_standard (Name.of_string "check")
 
-let fmt = make_standard "fmt"
+let fmt = make_standard (Name.of_string "fmt")
 
 let encode { dir; name } =
   let open Dune_lang.Encoder in
-  record [ ("dir", Dpath.encode (Path.build dir)); ("name", string name) ]
+  record [ ("dir", Dpath.encode (Path.build dir)); ("name", Name.encode name) ]