feature: case statements

We add a `(case ...)` constructor to dune_lang for actions which when
expanded will reduce down to the matching branch.

Signed-off-by: Ali Caglayan <alizter@gmail.com>

src/dune_lang/action.ml

@@ -160,6 +160,7 @@ 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
 
 let is_dev_null t = String_with_vars.is_pform t (Var Dev_null)
 
@@ -231,6 +232,60 @@ let decode_with_accepted_exit_codes =
 
 let sw = String_with_vars.decode
 
+let decode_case t =
+  let open Decoder in
+  let+ arg = sw
+  and+ cases =
+    repeat1 @@ enter
+    @@ let+ pat =
+         (let+ loc, _ = located (keyword "_") in
+          `Default loc)
+         <|> let+ pat = sw in
+             `Case 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: empty cases list" []
+    | (`Case pat, _) :: _ ->
+      User_error.raise ~loc:(String_with_vars.loc pat)
+        ~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 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 pat, _) :: _
+          when List.mem patterns pat ~equal:String_with_vars.equal_no_loc ->
+          let other_loc =
+            List.find_exn patterns ~f:(fun p ->
+                String_with_vars.equal_no_loc p pat)
+            |> String_with_vars.loc
+          in
+          err_duplicate_case (String_with_vars.loc pat) other_loc
+            "Duplicate case."
+        (* If a pattern is new, we add it to the list of seen patterns *)
+        | (`Case pat, branch) :: cases ->
+          (pat, branch) :: loop (pat :: patterns) cases
+      in
+      (loop [] l, default)
+  in
+  Case (arg, cases, default)
+
 let cstrs_dune_file t =
   let open Decoder in
   [ ( "run"
@@ -331,6 +386,7 @@ let cstrs_dune_file t =
     , Syntax.since Stanza.syntax (2, 7)
       >>> let+ script = sw in
           Cram script )
+  ; ("case", Syntax.since Stanza.syntax (3, 10) >>> decode_case t)
   ]
 
 let decode_dune_file = Decoder.fix @@ fun t -> Decoder.sum (cstrs_dune_file t)
@@ -415,6 +471,11 @@ 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 ] ])
 
 (* 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 +488,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,15 +523,9 @@ 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)
   in
   ignore (loop action)
 
@@ -501,6 +566,11 @@ 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 )
 
 let remove_locs = map_string_with_vars ~f:String_with_vars.remove_locs
 

src/dune_lang/action.mli

@@ -124,6 +124,7 @@ 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
 
 val encode : t Encoder.t
 

src/dune_rules/action_unexpanded.ml

@@ -484,6 +484,14 @@ let rec expand (t : Dune_lang.Action.t) ~context : Action.t Action_expander.t =
   | Withenv _ | Substitute _ | Patch _ ->
     (* these can only be provided by the package language which isn't expanded here *)
     assert false
+  | Case (arg, cases, default) -> (
+    let+ arg = E.string arg
+    and+ cases =
+      A.all (List.map ~f:(fun (k, a) -> A.both (E.string k) (expand a)) cases)
+    and+ default = expand default in
+    match List.assoc cases arg with
+    | Some a -> a
+    | None -> default)
 
 let expand_no_targets t ~loc ~chdir ~deps:deps_written_by_user ~expander ~what =
   let open Action_builder.O in

test/blackbox-tests/test-cases/actions/case.t

@@ -0,0 +1,149 @@
+Testing (case) action.
+
+  $ cat > dune-project << EOF
+  > (lang dune 3.10)
+  > EOF
+
+  $ cat > version << EOF
+  > 1
+  > EOF
+
+Basic usage:
+
+  $ cat > dune << EOF
+  > (rule
+  >  (alias foo)
+  >  (action
+  >   (case %{read-lines:version}
+  >    (1 (echo "version is 1"))
+  >    (2 (echo "version is 2"))
+  >    (3 (echo "version is 3"))
+  >    (_ (echo "shouldn't happen, got %{read-lines:version}")))))
+  > EOF
+
+  $ dune build @foo
+  version is 1
+
+  $ cat > version << EOF
+  > 2
+  > EOF
+  $ dune build @foo
+  version is 2
+
+  $ cat > version << EOF
+  > 3
+  > EOF
+  $ dune build @foo
+  version is 3
+
+  $ cat > version << EOF
+  > 4
+  > EOF
+  $ dune build @foo
+  shouldn't happen, got 4
+
+  $ cat > version << EOF
+  > 1
+  > EOF
+
+Missing default field:
+
+  $ cat > dune << EOF
+  > (rule
+  >  (alias foo)
+  >  (action
+  >   (case %{read-lines:version}
+  >    (1 (echo "version is 1")))))
+  > EOF
+
+  $ dune build @foo
+  File "dune", line 5, characters 4-5:
+  5 |    (1 (echo "version is 1")))))
+          ^
+  Error: Only the default case can be at the end.
+  Hint: Add a (_ (...)) case at the end.
+  [1]
+
+Two default fields:
+
+  $ cat > dune << EOF
+  > (rule
+  >  (alias foo)
+  >  (action
+  >   (case %{read-lines:version}
+  >    (_ (echo "version is 1"))
+  >    (2 (echo "version is 2"))
+  >    (_ (echo "version is 3")))))
+  > EOF
+
+  $ dune build @foo
+  Error: Multiple default cases.
+  File "dune", line 5, characters 4-5:
+  5 |    (_ (echo "version is 1"))
+          ^
+
+  File "dune", line 7, characters 4-5:
+  7 |    (_ (echo "version is 3")))))
+          ^
+
+  [1]
+
+Last case is not default case:
+
+  $ cat > dune << EOF
+  > (rule
+  >  (alias foo)
+  >  (action
+  >   (case %{read-lines:version}
+  >    (_ (echo "version is 1"))
+  >    (2 (echo "version is 2"))
+  >    (3 (echo "version is 3")))))
+  > EOF
+
+  $ dune build @foo
+  File "dune", line 7, characters 4-5:
+  7 |    (3 (echo "version is 3")))))
+          ^
+  Error: Only the default case can be at the end.
+  Hint: Add a (_ (...)) case at the end.
+  [1]
+
+Empty case:
+
+  $ cat > dune << EOF
+  > (rule
+  >  (alias foo)
+  >  (action
+  >   (case %{read-lines:version})))
+  > EOF
+
+  $ dune build @foo
+  File "dune", line 4, characters 2-30:
+  4 |   (case %{read-lines:version})))
+        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+  Error: Not enough arguments for case
+  [1]
+
+Duplicate cases:
+
+  $ cat > dune << EOF
+  > (rule
+  >  (alias foo)
+  >  (action
+  >   (case %{read-lines:version}
+  >    (1 (echo "version is 1"))
+  >    (1 (echo "version is 1"))
+  >    (_ (echo "shouldn't happen")))))
+  > EOF
+
+  $ dune build @foo
+  Error: Duplicate case.
+  File "dune", line 5, characters 4-5:
+  5 |    (1 (echo "version is 1"))
+          ^
+
+  File "dune", line 6, characters 4-5:
+  6 |    (1 (echo "version is 1"))
+          ^
+
+  [1]