Merge pull request #3265 from rgrinberg/fix-3264

Remove wrong validation for switch names

CHANGES.md

@@ -1,16 +1,16 @@
-2.5.0 (unreleased)
+Unreleased
 ------------------
 
 - Add a `--release` option meaning the same as `-p` but without the
   package filtering. This is useful for custom `dune` invocation in opam
   files where we don't want `-p` (#3260, @diml)
 
-2.4.1 (unreleased)
-------------------
-
 - Fix a bug introduced in 2.4.0 causing `.bc` programs to be built
   with `-custom` by default (#3269, fixes #3262, @diml)
 
+- Allow contexts to be defined with local switches in workspace files (#3265,
+  fix #3264, @rgrinberg)
+
 2.4.0 (06/03/2020)
 ------------------
 

src/dune/context.ml

@@ -6,7 +6,7 @@ module Kind = struct
   module Opam = struct
     type t =
       { root : string option
-      ; switch : Context_name.t
+      ; switch : string
       }
   end
 
@@ -18,10 +18,7 @@ module Kind = struct
     | Default -> Dyn.Encoder.string "default"
     | Opam o ->
       Dyn.Encoder.(
-        record
-          [ ("root", option string o.root)
-          ; ("switch", Context_name.to_dyn o.switch)
-          ])
+        record [ ("root", option string o.root); ("switch", string o.switch) ])
 end
 
 module Env_nodes = struct
@@ -643,7 +640,7 @@ let create_for_opam ~root ~env ~env_nodes ~targets ~profile ~switch ~name
       ; ( match root with
         | None -> []
         | Some root -> [ "--root"; root ] )
-      ; [ "--switch"; Context_name.to_string switch; "--sexp" ]
+      ; [ "--switch"; switch; "--sexp" ]
       ; ( if version < (2, 0, 0) then
           []
         else

src/dune/context.mli

@@ -26,7 +26,7 @@ module Kind : sig
   module Opam : sig
     type t =
       { root : string option
-      ; switch : Context_name.t
+      ; switch : string
       }
   end
 

src/dune/workspace.ml

@@ -22,9 +22,10 @@ module Context = struct
       | _, _ -> false
 
     let t =
-      map string ~f:(function
-        | "native" -> Native
-        | s -> Named (Context_name.parse_string_exn (Loc.none, s)))
+      let+ context_name = Context_name.decode in
+      match Context_name.to_string context_name with
+      | "native" -> Native
+      | _ -> Named context_name
 
     let add ts x =
       match x with
@@ -158,7 +159,7 @@ module Context = struct
   module Opam = struct
     type t =
       { base : Common.t
-      ; switch : Context_name.t
+      ; switch : string
       ; root : string option
       ; merlin : bool
       }
@@ -167,29 +168,38 @@ module Context = struct
       let open Dyn.Encoder in
       record
         [ ("base", Common.to_dyn base)
-        ; ("switch", Context_name.to_dyn switch)
+        ; ("switch", string switch)
         ; ("root", option string root)
         ; ("merlin", bool merlin)
         ]
 
     let equal { base; switch; root; merlin } t =
       Common.equal base t.base
-      && Context_name.equal switch t.switch
+      && String.equal switch t.switch
       && Option.equal String.equal root t.root
       && Bool.equal merlin t.merlin
 
     let t ~profile ~x =
-      let+ switch = field "switch" Context_name.decode
+      let+ loc_switch, switch = field "switch" (located string)
       and+ name = field_o "name" Context_name.decode
       and+ root = field_o "root" string
       and+ merlin = field_b "merlin"
       and+ base = Common.t ~profile in
-      let default =
-        (* TODO this needs proper error handling with locations *)
-        let name = Context_name.to_string switch ^ Common.fdo_suffix base in
-        Context_name.parse_string_exn (Loc.none, name)
+      let name =
+        match name with
+        | Some s -> s
+        | None -> (
+          let name = switch ^ Common.fdo_suffix base in
+          match Context_name.of_string_opt name with
+          | Some s -> s
+          | None ->
+            User_error.raise ~loc:loc_switch
+              [ Pp.textf "Generated context name %S is invalid" name
+              ; Pp.text
+                  "Please specify a context name manually with the (name ..) \
+                   field"
+              ] )
       in
-      let name = Option.value ~default name in
       let base = { base with targets = Target.add base.targets x; name } in
       { base; switch; root; merlin }
   end

src/dune/workspace.mli

@@ -34,7 +34,9 @@ module Context : sig
   module Opam : sig
     type t =
       { base : Common.t
-      ; switch : Context_name.t
+            (** Either a switch name or a path to a local switch. This argument
+                is left opaque as we leave to opam to interpret it. *)
+      ; switch : string
       ; root : string option
       ; merlin : bool
       }

src/stdune/ordering.ml

@@ -36,11 +36,13 @@ let is_eq = function
 let min f x y =
   match f x y with
   | Eq
-  | Lt -> x
+  | Lt ->
+    x
   | Gt -> y
 
 let max f x y =
   match f x y with
   | Eq
-  | Gt -> x
+  | Gt ->
+    x
   | Lt -> y