Refactor Jbuild.Scope_info.Name and Dune_project.name (#775)

src/dune_project.ml

@@ -7,9 +7,113 @@ module Lang = struct
     | Dune of Syntax.Version.t
 end
 
+module Name : sig
+  type t = private
+    | Named     of string
+    | Anonymous of Path.t
+
+  val compare : t -> t -> Ordering.t
+
+  val to_string_hum : t -> string
+
+  val named_of_sexp : t Sexp.Of_sexp.t
+  val sexp_of_t : t Sexp.To_sexp.t
+
+  val encode : t -> string
+  val decode : string -> t
+
+  val anonymous : Path.t -> t option
+  val named : string -> t option
+
+  val anonymous_root : t
+end = struct
+  type t =
+    | Named     of string
+    | Anonymous of Path.t
+
+  let anonymous_root = Anonymous Path.root
+
+  let compare a b =
+    match a, b with
+    | Named     x, Named     y -> String.compare x y
+    | Anonymous x, Anonymous y -> Path.compare   x y
+    | Named     _, Anonymous _ -> Lt
+    | Anonymous _, Named     _ -> Gt
+
+  let to_string_hum = function
+    | Named     s -> s
+    | Anonymous p -> sprintf "<anonymous %s>" (Path.to_string_maybe_quoted p)
+
+  let sexp_of_t = function
+    | Named s -> Sexp.To_sexp.string s
+    | Anonymous p ->
+      List [ Sexp.unsafe_atom_of_string "anonymous"
+           ; Path.sexp_of_t p
+           ]
+
+  let validate name =
+    let len = String.length name in
+    len > 0 &&
+    String.for_all name ~f:(function
+      | '.' | '/' -> false
+      | _         -> true)
+
+  let named name =
+    if validate name then
+      Some (Named name)
+    else
+      None
+
+  let anonymous path =
+    if Path.is_local path then
+      Some (Anonymous path)
+    else
+      None
+
+  let named_of_sexp sexp =
+    let s = string sexp in
+    if validate s then
+      Named s
+    else
+      of_sexp_error sexp "invalid project name"
+
+  let encode = function
+    | Named     s -> s
+    | Anonymous p ->
+      if Path.is_root p then
+        "."
+      else
+        "." ^ String.map (Path.to_string p)
+                ~f:(function
+                  | '/' -> '.'
+                  | c   -> c)
+
+  let decode =
+    let invalid s =
+      (* Users would see this error if they did "dune build
+         _build/default/.ppx/..." *)
+      die "Invalid encoded project name: %S" s
+    in
+    fun s ->
+      match s with
+      | "" -> invalid s
+      | "." -> anonymous_root
+      | _ when s.[0] = '.' ->
+        let p =
+          Path.of_string
+            (String.split s ~on:'.'
+             |> List.tl
+             |> String.concat ~sep:"/")
+        in
+        if not (Path.is_local p) then invalid s;
+        Anonymous p
+      | _ when validate s -> Named s
+      | _ -> invalid s
+end
+
 type t =
   { lang     : Lang.t
-  ; name     : string
+  ; name     : Name.t
   ; root     : Path.t
   ; version  : string option
   ; packages : Package.t Package.Name.Map.t
@@ -35,16 +139,26 @@ let lang =
 
 let default_name ~dir ~packages =
   match Package.Name.Map.choose packages with
-  | None ->
-    "_" ^ String.concat ~sep:"_" (Path.explode_exn dir)
-  | Some (name, _) ->
-    Package.Name.to_string
-      (Package.Name.Map.fold packages ~init:name ~f:(fun pkg acc ->
-         min acc pkg.Package.name))
+  | None -> Option.value_exn (Name.anonymous dir)
+  | Some (_, pkg) ->
+    let pkg =
+      Package.Name.Map.fold packages ~init:pkg ~f:(fun pkg acc ->
+        if acc.Package.name <= pkg.Package.name then
+          acc
+        else
+          pkg)
+    in
+    let name = Package.Name.to_string pkg.name in
+    match Name.named name with
+    | Some x -> x
+    | None ->
+      Loc.fail (Loc.in_file (Path.to_string (Package.opam_file pkg)))
+        "%S is not a valid opam package name."
+        name
 
 let name ~dir ~packages =
-  field_o "name" string >>= function
-  | Some s -> return s
+  field_o "name" Name.named_of_sexp >>= function
+  | Some x -> return x
   | None -> return (default_name ~dir ~packages)
 
 let parse ~dir packages =

src/dune_project.mli

@@ -8,9 +8,33 @@ module Lang : sig
     | Dune of Syntax.Version.t
 end
 
+module Name : sig
+  (** Invariants:
+      - Named     s -> s <> "" and s does not contain '.' or '/'
+      - Anonymous p -> p is a local path in the source tree
+  *)
+  type t = private
+    | Named     of string
+    | Anonymous of Path.t
+
+  val compare : t -> t -> Ordering.t
+
+  (** Convert to a string that is suitable for human readable messages *)
+  val to_string_hum : t -> string
+
+  val sexp_of_t : t -> Sexp.t
+
+  (** Convert to/from an encoded string that is suitable to use in filenames *)
+  val encode : t -> string
+  val decode : string -> t
+
+  (** [Anonymous Path.root] *)
+  val anonymous_root : t
+end
+
 type t =
   { lang     : Lang.t
-  ; name     : string
+  ; name     : Name.t
   ; root     : Path.t
   ; version  : string option
   ; packages : Package.t Package.Name.Map.t

src/install_rules.ml

@@ -194,7 +194,7 @@ module Gen(P : Install_params) = struct
             | "ppx_driver" | "ppx_type_conv" -> true
             | _ -> false) then
             pps @ [match Scope.name scope with
-              | Some "ppxlib" ->
+              | Named "ppxlib" ->
                 Loc.none, Pp.of_string "ppxlib.runner"
               | _ ->
                 Loc.none, Pp.of_string "ppx_driver.runner"]

src/jbuild.ml

@@ -90,20 +90,7 @@ let c_name, cxx_name =
    make "C++" "cpp")
 
 module Scope_info = struct
-  module Name = struct
-    type t = string option
-
-    let compare : t -> t -> Ordering.t = compare
-
-    let of_string = function
-      | "" -> None
-      | s  -> Some s
-
-    let to_string = function
-      | None -> ""
-      | Some "" -> assert false
-      | Some s -> s
-  end
+  module Name = Dune_project.Name
 
   type t =
     { name     : Name.t
@@ -114,7 +101,7 @@ module Scope_info = struct
     }
 
   let anonymous =
-    { name     = None
+    { name     = Name.anonymous_root
     ; packages = Package.Name.Map.empty
     ; root     = Path.root
     ; version  = None
@@ -122,7 +109,7 @@ module Scope_info = struct
     }
 
   let make (project : Dune_project.t) =
-    { name     = Some project.name
+    { name     = project.name
     ; packages = project.packages
     ; root     = project.root
     ; version  = project.version

src/jbuild.mli

@@ -10,22 +10,10 @@ module Jbuild_version : sig
 end
 
 module Scope_info : sig
-  module Name : sig
-    (* CR-someday diml: change to [private string] and encode [None]
-       as [""] *)
-    (** [None] is the for the {!anonymous} scope *)
-    type t = string option
-
-    val compare : t -> t -> Ordering.t
-
-    val of_string : string -> t
-    val to_string : t -> string
-  end
+  module Name = Dune_project.Name
 
   type t =
-    { name     : string option (** First package name in alphabetical
-                                   order. [None] for the global
-                                   scope. *)
+    { name     : Name.t
     ; packages : Package.t Package.Name.Map.t
     ; root     : Path.t
     ; version  : string option

src/lib.ml

@@ -17,7 +17,7 @@ module Status = struct
        | Installed -> "installed"
        | Public _ -> "public"
        | Private s ->
-         sprintf "private (%s)" (Jbuild.Scope_info.Name.to_string s))
+         sprintf "private (%s)" (Jbuild.Scope_info.Name.to_string_hum s))
 
   let is_private = function
     | Private _ -> true

src/scope.ml

@@ -42,10 +42,11 @@ module DB = struct
     | Some x -> x
     | None ->
       Exn.code_error "Scope.DB.find_by_name"
-        [ "name"   , Sexp.To_sexp.(option string) name
+        [ "name"   , Dune_project.Name.sexp_of_t name
         ; "context", Sexp.To_sexp.string t.context
         ; "names",
-          Sexp.To_sexp.(list (option string)) (Scope_name_map.keys t.by_name)
+          Sexp.To_sexp.(list Dune_project.Name.sexp_of_t)
+            (Scope_name_map.keys t.by_name)
         ]
 
   let create ~scopes ~context ~installed_libs internal_libs =
@@ -57,7 +58,7 @@ module DB = struct
       | Ok x -> x
       | Error (_name, scope1, scope2) ->
         let to_sexp (scope : Jbuild.Scope_info.t) =
-          Sexp.To_sexp.(pair (option string) Path.sexp_of_t)
+          Sexp.To_sexp.(pair Dune_project.Name.sexp_of_t Path.sexp_of_t)
             (scope.name, scope.root)
         in
         Exn.code_error "Scope.DB.create got two scopes with the same name"

src/scope.mli

@@ -7,7 +7,7 @@ open Stdune
 type t
 
 val root : t -> Path.t
-val name : t -> string option
+val name : t -> Dune_project.Name.t
 val info : t -> Jbuild.Scope_info.t
 
 (** Return the library database associated to this scope *)
@@ -28,6 +28,6 @@ module DB : sig
     -> (Path.t * Jbuild.Library.t) list
     -> t * Lib.DB.t
 
-  val find_by_dir  : t -> Path.t        -> scope
-  val find_by_name : t -> string option -> scope
+  val find_by_dir  : t -> Path.t              -> scope
+  val find_by_name : t -> Dune_project.Name.t -> scope
 end with type scope := t

src/stdune/string.ml

@@ -166,14 +166,24 @@ let longest_map l ~f =
 
 let longest l = longest_map l ~f:(fun x -> x)
 
-let exists s ~f =
-  try
-    for i=0 to length s - 1 do
-      if (f s.[i]) then raise_notrace Exit
-    done;
-    false
-  with Exit ->
-    true
+
+let exists =
+  let rec loop s i len f =
+    if i = len then
+      false
+    else
+      f (unsafe_get s i) || loop s (i + 1) len f
+  in
+  fun s ~f ->
+    loop s 0 (length s) f
+
+let for_all =
+  let rec loop s i len f =
+    i = len ||
+    (f (unsafe_get s i) && loop s (i + 1) len f)
+  in
+  fun s ~f ->
+    loop s 0 (length s) f
 
 let maybe_quoted s =
   let escaped = escaped s in
@@ -182,6 +192,5 @@ let maybe_quoted s =
   else
     Printf.sprintf {|"%s"|} escaped
 
-
 module Set = Set.Make(T)
 module Map = Map.Make(T)

src/stdune/string.mli

@@ -39,6 +39,7 @@ val longest : string list -> int
 val longest_map : 'a list -> f:('a -> string) -> int
 
 val exists : t -> f:(char -> bool) -> bool
+val for_all : t -> f:(char -> bool) -> bool
 
 (** [maybe_quoted s] is [s] if [s] doesn't need escaping according to OCaml
     lexing conventions and [sprintf "%S" s] otherwise. *)

src/super_context.ml

@@ -536,10 +536,10 @@ module Scope_key = struct
       (key, public_libs sctx)
     | Some (key, scope) ->
       ( key
-      , Scope.libs (find_scope_by_name sctx (Scope_info.Name.of_string scope)))
+      , Scope.libs (find_scope_by_name sctx (Scope_info.Name.decode scope)))
 
   let to_string key scope =
-    sprintf "%s@%s" key (Scope_info.Name.to_string scope)
+    sprintf "%s@%s" key (Scope_info.Name.encode scope)
 end
 
 let parse_bang var : bool * string =

src/super_context.mli

@@ -65,8 +65,8 @@ val ocaml_flags
 (** Dump a directory environment in a readable form *)
 val dump_env : t -> dir:Path.t -> (unit, Sexp.t list) Build.t
 
-val find_scope_by_dir  : t -> Path.t        -> Scope.t
-val find_scope_by_name : t -> string option -> Scope.t
+val find_scope_by_dir  : t -> Path.t              -> Scope.t
+val find_scope_by_name : t -> Dune_project.Name.t -> Scope.t
 
 val expand_vars
   :  t

test/blackbox-tests/test-cases/merlin-tests/run.t

@@ -23,7 +23,7 @@
   B $LIB_PREFIX/lib/findlib
   B $LIB_PREFIX/lib/ocaml
   FLG -open Foo -w -40 -open Bar -w -40
-  FLG -ppx '$PPX/fooppx@/ppx.exe --as-ppx --cookie '\''library-name="foo"'\'''
+  FLG -ppx '$PPX/fooppx@./ppx.exe --as-ppx --cookie '\''library-name="foo"'\'''
   S .
   S $LIB_PREFIX/lib/bytes
   S $LIB_PREFIX/lib/findlib

test/blackbox-tests/test-cases/ppx-rewriter/run.t

@@ -3,7 +3,7 @@
         ocamlc ppx/.fooppx.objs/fooppx.{cmi,cmo,cmt}
       ocamlopt ppx/.fooppx.objs/fooppx.{cmx,o}
       ocamlopt ppx/fooppx.{a,cmxa}
-      ocamlopt .ppx/fooppx@/ppx.exe
+      ocamlopt .ppx/fooppx@./ppx.exe
            ppx w_omp_driver.pp.ml
       ocamldep w_omp_driver.pp.ml.d
         ocamlc .w_omp_driver.eobjs/w_omp_driver.{cmi,cmo,cmt}