[do not merge] test branch for case/cond

CHANGES.md

@@ -3,6 +3,9 @@ Unreleased
 
 - Add `dune show rules` as alias of the `dune rules` command. (#8000, @Alizter)
 
+- Fix `%{deps}` to expand properly in `(cat ...)` when containing 2 or more
+  items. (#8196, @Alizter)
+
 - Add `dune show installed-libraries` as an alias of the `dune
   installed-libraries` command. (#8135, @Alizter)
 

otherlibs/stdune/src/path.ml

@@ -414,15 +414,6 @@ end = struct
 
   let to_dyn t = Dyn.variant "External" [ Dyn.string t ]
 
-  (* let rec cd_dot_dot t = match Unix.readlink t with | exception _ ->
-     Filename.dirname t | t -> cd_dot_dot t
-
-     let relative initial_t path = let rec loop t components = match components
-     with | [] | ["." | ".."] -> die "invalid filename concatenation: %s / %s"
-     initial_t path | [fn] -> Filename.concat t fn | "." :: rest -> loop t rest
-     | ".." :: rest -> loop (cd_dot_dot t) rest | comp :: rest -> loop
-     (Filename.concat t comp) rest in loop initial_t (explode_path path) *)
-
   let relative x y =
     match y with
     | "." -> x

src/dune_lang/action.ml

@@ -160,6 +160,8 @@ type t =
   | Patch of String_with_vars.t
   | Substitute of String_with_vars.t * String_with_vars.t
   | Withenv of String_with_vars.t Env_update.t list * t
+  | Case of String_with_vars.t * (String_with_vars.t * t) list * t
+  | Cond of (Blang.t * t) list * t
 
 let is_dev_null t = String_with_vars.is_pform t (Var Dev_null)
 
@@ -231,6 +233,66 @@ let decode_with_accepted_exit_codes =
 
 let sw = String_with_vars.decode
 
+module type Pattern = sig
+  type t
+
+  val decode : t Decoder.t
+
+  val equal_no_loc : t -> t -> bool
+end
+
+let decode_case_cond (type pattern) (module P : Pattern with type t = pattern) t
+    =
+  let open Decoder in
+  let+ cases =
+    repeat1 @@ enter
+    @@ let+ pat =
+         (let+ loc, _ = located (keyword "_") in
+          `Default loc)
+         <|> let+ loc, pat = located P.decode in
+             `Case (loc, pat)
+       and+ branch = t in
+       (pat, branch)
+  in
+  (* we need to check that there is at most one default case and that it
+     appears last *)
+  let cases, default =
+    match List.rev cases with
+    | [] -> Code_error.raise "decode_case_cond: empty cases list" []
+    | (`Case (loc, _), _) :: _ ->
+      User_error.raise ~loc
+        ~hints:[ Pp.text "Add a (_ (...)) case at the end." ]
+        [ Pp.text "Only the default case can be at the end." ]
+    | (`Default default_loc, default) :: l ->
+      let err_duplicate_case loc1 loc2 msg =
+        User_error.raise
+          [ Pp.text msg
+          ; Pp.map_tags ~f:(fun _ -> User_message.Style.Loc) (Loc.pp loc1)
+          ; Pp.map_tags ~f:(fun _ -> User_message.Style.Loc) (Loc.pp loc2)
+          ]
+      in
+      let rec loop (patterns : (Loc.t * P.t) list) cases =
+        match cases with
+        | [] -> []
+        (* The default case has already been handled, any other is an error *)
+        | (`Default loc, _) :: _ ->
+          err_duplicate_case loc default_loc "Multiple default cases."
+        (* If a pattern has been seen before, it's an error *)
+        | (`Case (loc, pat), _) :: _
+          when List.mem (List.map ~f:snd patterns) pat ~equal:P.equal_no_loc ->
+          let other_loc =
+            List.find_exn patterns ~f:(fun (_, x) -> P.equal_no_loc pat x)
+            |> fst
+          in
+          err_duplicate_case loc other_loc "Duplicate case."
+        (* If a pattern is new, we add it to the list of seen patterns *)
+        | (`Case (loc, pat), branch) :: cases ->
+          (pat, branch) :: loop ((loc, pat) :: patterns) cases
+      in
+      (loop [] l, default)
+  in
+  (cases, default)
+
 let cstrs_dune_file t =
   let open Decoder in
   [ ( "run"
@@ -331,6 +393,15 @@ let cstrs_dune_file t =
     , Syntax.since Stanza.syntax (2, 7)
       >>> let+ script = sw in
           Cram script )
+  ; ( "case"
+    , Syntax.since Stanza.syntax (3, 10)
+      >>> let+ arg = sw
+          and+ cases, default = decode_case_cond (module String_with_vars) t in
+          Case (arg, cases, default) )
+  ; ( "cond"
+    , Syntax.since Stanza.syntax (3, 10)
+      >>> let+ cases, default = decode_case_cond (module Blang) t in
+          Cond (cases, default) )
   ]
 
 let decode_dune_file = Decoder.fix @@ fun t -> Decoder.sum (cstrs_dune_file t)
@@ -415,6 +486,17 @@ let rec encode =
   | Substitute (i, o) -> List [ atom "substitute"; sw i; sw o ]
   | Withenv (ops, t) ->
     List [ atom "withenv"; List (List.map ~f:Env_update.encode ops); encode t ]
+  | Case (var, cases, default) ->
+    List
+      ([ atom "case"; sw var ]
+      @ List.map cases ~f:(fun (var, t) -> List [ sw var; encode t ])
+      @ [ List [ atom "_"; encode default ] ])
+  | Cond (cases, default) ->
+    List
+      (atom "cond"
+       :: List.map cases ~f:(fun (cond, t) ->
+              List [ Blang.encode cond; encode t ])
+      @ [ List [ atom "_"; encode default ] ])
 
 (* In [Action_exec] we rely on one-to-one mapping between the cwd-relative paths
    seen by the action and [Path.t] seen by dune.
@@ -427,7 +509,17 @@ let rec encode =
    Moreover, we also check that 'dynamic-run' is not used within
    'with-exit-codes', since the meaning of this interaction is not clear. *)
 let ensure_at_most_one_dynamic_run ~loc action =
-  let rec loop : t -> bool = function
+  let rec ensure_at_most_one_dynamic_run_list ts =
+    List.fold_left ts ~init:false ~f:(fun acc t ->
+        let have_dyn = loop t in
+        if acc && have_dyn then
+          User_error.raise ~loc
+            [ Pp.text
+                "Multiple 'dynamic-run' commands within single action are not \
+                 supported."
+            ]
+        else acc || have_dyn)
+  and loop : t -> bool = function
     | Dynamic_run _ -> true
     | Chdir (_, t)
     | Setenv (_, _, t)
@@ -452,16 +544,13 @@ let ensure_at_most_one_dynamic_run ~loc action =
     | Patch _
     | Cram _ -> false
     | Pipe (_, ts) | Progn ts | Concurrent ts ->
-      List.fold_left ts ~init:false ~f:(fun acc t ->
-          let have_dyn = loop t in
-          if acc && have_dyn then
-            User_error.raise ~loc
-              [ Pp.text
-                  "Multiple 'dynamic-run' commands within single action are \
-                   not supported."
-              ]
-          else acc || have_dyn)
+      ensure_at_most_one_dynamic_run_list ts
+    | Case (_, cases, default) ->
+      ensure_at_most_one_dynamic_run_list (default :: List.map ~f:snd cases)
+    | Cond (cases, default) ->
+      ensure_at_most_one_dynamic_run_list (default :: List.map ~f:snd cases)
   in
+
   ignore (loop action)
 
 let validate ~loc t = ensure_at_most_one_dynamic_run ~loc t
@@ -501,6 +590,16 @@ let rec map_string_with_vars t ~f =
       ( List.map ops ~f:(fun (op : _ Env_update.t) ->
             { op with value = f op.value })
       , map_string_with_vars t ~f )
+  | Case (sw, cases, default) ->
+    Case
+      ( f sw
+      , List.map cases ~f:(fun (sw, t) -> (f sw, map_string_with_vars t ~f))
+      , map_string_with_vars default ~f )
+  | Cond (cases, default) ->
+    Cond
+      ( List.map cases ~f:(fun (cond, t) ->
+            (Blang.map_string_with_vars cond ~f, map_string_with_vars t ~f))
+      , map_string_with_vars default ~f )
 
 let remove_locs = map_string_with_vars ~f:String_with_vars.remove_locs
 

src/dune_lang/action.mli

@@ -124,6 +124,8 @@ type t =
   | Patch of String_with_vars.t
   | Substitute of String_with_vars.t * String_with_vars.t
   | Withenv of String_with_vars.t Env_update.t list * t
+  | Case of String_with_vars.t * (String_with_vars.t * t) list * t
+  | Cond of (Blang.t * t) list * t
 
 val encode : t Encoder.t
 

src/dune_lang/blang.ml

@@ -15,6 +15,25 @@ module Op = struct
     | (Eq | Gte | Lte), Eq | (Neq | Lt | Lte), Lt | (Neq | Gt | Gte), Gt -> true
     | _, _ -> false
 
+  let compare a b : Ordering.t =
+    match (a, b) with
+    | Eq, Eq -> Eq
+    | Eq, _ -> Lt
+    | _, Eq -> Gt
+    | Gt, Gt -> Eq
+    | Gt, _ -> Gt
+    | _, Gt -> Lt
+    | Gte, Gte -> Eq
+    | Gte, _ -> Gt
+    | _, Gte -> Lt
+    | Lte, Lte -> Eq
+    | Lte, _ -> Lt
+    | _, Lte -> Gt
+    | Lt, Lt -> Eq
+    | Lt, _ -> Lt
+    | _, Lt -> Gt
+    | Neq, Neq -> Eq
+
   let to_dyn =
     let open Dyn in
     function
@@ -24,6 +43,16 @@ module Op = struct
     | Lte -> string "Lte"
     | Lt -> string "Lt"
     | Neq -> string "Neq"
+
+  let all =
+    [ ("=", Eq); (">=", Gte); ("<=", Lte); (">", Gt); ("<", Lt); ("<>", Neq) ]
+
+  let encode x =
+    atom
+    @@
+    match List.assoc (List.map ~f:Tuple.T2.swap all) x with
+    | Some x -> x
+    | None -> Code_error.raise "Unknown op" []
 end
 
 type t =
@@ -34,6 +63,15 @@ type t =
   | Or of t list
   | Compare of Op.t * String_with_vars.t * String_with_vars.t
 
+let rec map_string_with_vars t ~f =
+  match t with
+  | Const _ -> t
+  | Not t -> Not (map_string_with_vars t ~f)
+  | Expr e -> Expr (f e)
+  | And t -> And (List.map ~f:(map_string_with_vars ~f) t)
+  | Or t -> Or (List.map ~f:(map_string_with_vars ~f) t)
+  | Compare (o, s1, s2) -> Compare (o, f s1, f s2)
+
 let true_ = Const true
 
 let rec to_dyn =
@@ -48,13 +86,21 @@ let rec to_dyn =
     variant "Compare"
       [ Op.to_dyn o; String_with_vars.to_dyn s1; String_with_vars.to_dyn s2 ]
 
-let ops =
-  [ ("=", Op.Eq); (">=", Gte); ("<=", Lte); (">", Gt); ("<", Lt); ("<>", Neq) ]
+let rec encode =
+  let open Encoder in
+  function
+  | Const b -> bool b
+  | Not t -> List [ atom "not"; encode t ]
+  | Expr e -> String_with_vars.encode e
+  | And t -> List (atom "and" :: List.map ~f:encode t)
+  | Or t -> List (atom "or" :: List.map ~f:encode t)
+  | Compare (o, s1, s2) ->
+    List [ Op.encode o; String_with_vars.encode s1; String_with_vars.encode s2 ]
 
 let decode_gen decode_string =
   let open Decoder in
   let ops =
-    List.map ops ~f:(fun (name, op) ->
+    List.map Op.all ~f:(fun (name, op) ->
         ( name
         , let+ x = decode_string
           and+ y = decode_string in
@@ -77,3 +123,27 @@ let decode_gen decode_string =
 let decode = decode_gen String_with_vars.decode
 
 let decode_manually f = decode_gen (String_with_vars.decode_manually f)
+
+let rec compare_no_loc a b : Ordering.t =
+  let open Ordering.O in
+  match (a, b) with
+  | Const a, Const b -> Bool.compare a b
+  | Const _, _ -> Lt
+  | _, Const _ -> Gt
+  | Not a, Not b -> compare_no_loc a b
+  | Not _, _ -> Lt
+  | _, Not _ -> Gt
+  | Expr a, Expr b -> String_with_vars.compare_no_loc a b
+  | Expr _, _ -> Lt
+  | _, Expr _ -> Gt
+  | And a, And b | Or a, Or b -> List.compare ~compare:compare_no_loc a b
+  | And _, _ -> Lt
+  | _, And _ -> Gt
+  | Compare (o1, s1, s2), Compare (o2, s3, s4) ->
+    let= () = Op.compare o1 o2 in
+    let= () = String_with_vars.compare_no_loc s1 s3 in
+    String_with_vars.compare_no_loc s2 s4
+  | Compare _, _ -> Lt
+  | _, Compare _ -> Gt
+
+let equal_no_loc a b = Ordering.is_eq (compare_no_loc a b)

src/dune_lang/blang.mli

@@ -21,10 +21,17 @@ type t =
   | Or of t list
   | Compare of Op.t * String_with_vars.t * String_with_vars.t
 
+val equal_no_loc : t -> t -> bool
+
 val true_ : t
 
 val to_dyn : t -> Dyn.t
 
+val map_string_with_vars :
+  t -> f:(String_with_vars.t -> String_with_vars.t) -> t
+
+val encode : t Encoder.t
+
 val decode : t Decoder.t
 
 (** Resolve variables manually. For complex cases such as [enabled_if] *)