Add enabled_if to aliases/tests

This field controls whether the alias/test will be run or not. Boolean
expressions are defined using the Blang.t type. This type represents simple
boolean expressions that become useful when we allow to interpolate variables
into them.

Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>

doc/dune-files.rst

@@ -569,6 +569,10 @@ The syntax is as follows:
 - ``(locks (<lock-names>))`` specify that the action must be run while
   holding the following locks. See the `Locks`_ section for more details.
 
+- ``(enabled_if <blang expression>)`` specifies the boolean condition that must
+  be true for the tests to run. The condition is specified using the blang_, and
+  the field allows for variables_ to appear in the expressions.
+
 The typical use of the ``alias`` stanza is to define tests:
 
 .. code:: scheme
@@ -824,6 +828,36 @@ doesn't start by `-`, you can simply quote it: ``("x" y z)``.
 Most fields using the ordered set language also support `Variables expansion`_.
 Variables are expanded after the set language is interpreted.
 
+.. _blang:
+
+Boolean Language
+----------------
+
+The boolean language allows the user to define simple boolean expressions that
+dune can evaluate. Here's a semi formal specification of the language:
+
+.. code::
+
+   op := '=' | '<' | '>' | '<>' | '>=' | '<='
+
+   expr := (and <expr>+)
+         | (or <expr>+)
+         | (<op> <template> <template>)
+         | <template>
+
+After an expression is evaluated, it must be exactly the string ``true`` or
+``false`` to be considered as a boolean. Any other value will be treated as an
+error.
+
+Here's a simple example of a condition that expresses running on OSX and having
+an flambda compiler with the help of variable expansion:
+
+.. code:: scheme
+
+   (and %{ocamlc-config:flambda} (= %{ocamlc-config:system} macosx))
+
+.. _variables:
+
 Variables expansion
 -------------------
 

src/blang.ml

@@ -0,0 +1,45 @@
+open! Stdune
+
+module Op = struct
+  type t =
+    | Eq
+    | Gt
+    | Gte
+    | Lte
+    | Lt
+    | Neq
+
+  let eval t (x : Ordering.t) =
+    match t, x with
+    | (Eq | Gte | Lte) , Eq
+    | (Lt | Lte) , Lt
+    | (Gt | Gte) , Gt -> true
+    | _, _ -> false
+end
+
+type 'a t =
+  | Expr of 'a
+  | And of 'a t list
+  | Or of 'a t list
+  | Compare of Op.t * 'a * 'a
+
+type 'a expander =
+  { f : 'value. mode:'value String_with_vars.Mode.t
+      -> 'a
+      -> Loc.t * 'value
+  }
+
+let rec eval_bool t ~dir ~(f : 'a expander) =
+  match t with
+  | Expr a ->
+    begin match f.f ~mode:Single a with
+    | _, String "true" -> true
+    | _, String "false" -> false
+    | loc, _ -> Loc.fail loc "This value must be either true or false"
+    end
+  | And xs -> List.for_all ~f:(eval_bool ~f ~dir) xs
+  | Or xs -> List.exists ~f:(eval_bool ~f ~dir) xs
+  | Compare (op, x, y) ->
+    let ((_, x), (_, y)) = (f.f ~mode:Many x, f.f ~mode:Many y) in
+    Value.L.compare_vals ~dir x y
+    |> Op.eval op

src/blang.mli

@@ -0,0 +1,25 @@
+open Stdune
+
+module Op : sig
+  type t =
+    | Eq
+    | Gt
+    | Gte
+    | Lte
+    | Lt
+    | Neq
+end
+
+type 'a t =
+  | Expr of 'a
+  | And of 'a t list
+  | Or of 'a t list
+  | Compare of Op.t * 'a * 'a
+
+type 'a expander =
+  { f : 'value. mode:'value String_with_vars.Mode.t
+      -> 'a
+      -> Loc.t * 'value
+  }
+
+val eval_bool : 'a t -> dir:Path.t -> f:'a expander -> bool

src/gen_rules.ml

@@ -590,6 +590,7 @@ module Gen(P : Install_rules.Params) = struct
         ; package = t.package
         ; deps = t.deps
         ; action = None
+        ; enabled_if = t.enabled_if
         } in
       match test_kind (loc, s) with
       | `Regular ->

src/jbuild.ml

@@ -316,7 +316,7 @@ module Dep_conf = struct
         ; "universe"   , return Universe
         ; "files_recursively_in",
           (let%map () =
-            Syntax.renamed_in Stanza.syntax (1, 0) ~to_:"source_tree"
+             Syntax.renamed_in Stanza.syntax (1, 0) ~to_:"source_tree"
            and x = sw in
            Source_tree x)
         ; "source_tree",
@@ -378,6 +378,45 @@ module Preprocess = struct
     | _ -> []
 end
 
+module Blang = struct
+  type 'a t = 'a Blang.t
+
+  open Blang
+  let ops =
+    [ "=", Op.Eq
+    ; ">=", Gte
+    ; "<=", Lt
+    ; ">", Gt
+    ; "<", Lt
+    ; "<>", Neq
+    ]
+
+  let t =
+    let ops =
+      List.map ops ~f:(fun (name, op) ->
+        ( name
+        , (let%map x = String_with_vars.t
+           and y = String_with_vars.t
+           in
+           Compare (op, x, y))))
+    in
+    let t =
+      fix begin fun (t : String_with_vars.t Blang.t Sexp.Of_sexp.t) ->
+        if_list
+          ~then_:(
+            [ "or", repeat t >>| (fun x -> Or x)
+            ; "and", repeat t >>| (fun x -> And x)
+            ] @ ops
+            |> sum)
+          ~else_:(String_with_vars.t >>| fun v -> Expr v)
+      end
+    in
+    let%map () = Syntax.since Stanza.syntax (1, 1)
+    and t = t
+    in
+    t
+end
+
 module Per_module = struct
   include Per_item.Make(Module.Name)
 
@@ -1336,15 +1375,15 @@ module Rule = struct
   let dune_syntax =
     peek_exn >>= function
     | List (_, Atom (loc, A s) :: _) -> begin
-      match String.Map.find atom_table s with
+        match String.Map.find atom_table s with
-      | None ->
+        | None ->
-        of_sexp_errorf loc ~hint:{ on = s
+          of_sexp_errorf loc ~hint:{ on = s
-                                 ; candidates = String.Map.keys atom_table
+                                   ; candidates = String.Map.keys atom_table
-                                 }
+                                   }
-          "Unknown action or rule field."
+            "Unknown action or rule field."
-      | Some Field -> fields long_form
+        | Some Field -> fields long_form
-      | Some Action -> short_form
+        | Some Action -> short_form
-    end
+      end
     | sexp ->
       of_sexp_errorf (Sexp.Ast.loc sexp)
         "S-expression of the form (<atom> ...) expected"
@@ -1500,6 +1539,7 @@ module Alias_conf = struct
     ; action  : (Loc.t * Action.Unexpanded.t) option
     ; locks   : String_with_vars.t list
     ; package : Package.t option
+    ; enabled_if : String_with_vars.t Blang.t option
     }
 
   let alias_name =
@@ -1516,21 +1556,24 @@ module Alias_conf = struct
        and action = field_o "action" (located Action.Unexpanded.t)
        and locks = field "locks" (list String_with_vars.t) ~default:[]
        and deps = field "deps" (Bindings.t Dep_conf.t) ~default:Bindings.empty
+       and enabled_if = field_o "enabled_if" Blang.t
        in
        { name
        ; deps
        ; action
        ; package
        ; locks
+       ; enabled_if
        })
 end
 
 module Tests = struct
   type t =
-    { exes    : Executables.t
+    { exes       : Executables.t
-    ; locks   : String_with_vars.t list
+    ; locks      : String_with_vars.t list
-    ; package : Package.t option
+    ; package    : Package.t option
-    ; deps    : Dep_conf.t Bindings.t
+    ; deps       : Dep_conf.t Bindings.t
+    ; enabled_if : String_with_vars.t Blang.t option
     }
 
   let gen_parse names =
@@ -1543,6 +1586,7 @@ module Tests = struct
        and modes = field "modes" Executables.Link_mode.Set.t
                      ~default:Executables.Link_mode.Set.default
        and deps = field "deps" (Bindings.t Dep_conf.t) ~default:Bindings.empty
+       and enabled_if = field_o "enabled_if" Blang.t
        in
        { exes =
            { Executables.
@@ -1555,6 +1599,7 @@ module Tests = struct
        ; locks
        ; package
        ; deps
+       ; enabled_if
        })
 
   let multi = gen_parse (field "names" (list (located string)))

src/jbuild.mli

@@ -335,6 +335,7 @@ module Alias_conf : sig
     ; action  : (Loc.t * Action.Unexpanded.t) option
     ; locks   : String_with_vars.t list
     ; package : Package.t option
+    ; enabled_if : String_with_vars.t Blang.t option
     }
 end
 
@@ -355,10 +356,11 @@ end
 
 module Tests : sig
   type t =
-    { exes    : Executables.t
+    { exes       : Executables.t
-    ; locks   : String_with_vars.t list
+    ; locks      : String_with_vars.t list
-    ; package : Package.t option
+    ; package    : Package.t option
-    ; deps    : Dep_conf.t Bindings.t
+    ; deps       : Dep_conf.t Bindings.t
+    ; enabled_if : String_with_vars.t Blang.t option
     }
 end
 

src/simple_rules.ml

@@ -70,32 +70,45 @@ let add_alias sctx ~dir ~name ~stamp ?(locks=[]) build =
   SC.add_alias_action sctx alias ~locks ~stamp build
 
 let alias sctx ~dir ~scope (alias_conf : Alias_conf.t) =
-  let stamp =
+  let enabled =
-    let module S = Sexp.To_sexp in
+    match alias_conf.enabled_if with
-    Sexp.List
+    | None -> true
-      [ Sexp.unsafe_atom_of_string "user-alias"
+    | Some blang ->
-      ; Jbuild.Bindings.sexp_of_t Jbuild.Dep_conf.sexp_of_t alias_conf.deps
+      let f : String_with_vars.t Blang.expander =
-      ; S.option Action.Unexpanded.sexp_of_t
+        { f = fun ~mode sw ->
-          (Option.map alias_conf.action ~f:snd)
+            ( String_with_vars.loc sw
-      ]
+            , Super_context.expand_vars sctx ~scope ~mode ~dir sw
+            )
+        } in
+      Blang.eval_bool blang ~dir ~f
   in
-  add_alias sctx
+  if enabled then
-    ~dir
+    let stamp =
-    ~name:alias_conf.name
+      let module S = Sexp.To_sexp in
-    ~stamp
+      Sexp.List
-    ~locks:(interpret_locks sctx ~dir ~scope alias_conf.locks)
+        [ Sexp.unsafe_atom_of_string "user-alias"
-    (SC.Deps.interpret_named sctx ~scope ~dir alias_conf.deps
+        ; Jbuild.Bindings.sexp_of_t Jbuild.Dep_conf.sexp_of_t alias_conf.deps
-     >>>
+        ; S.option Action.Unexpanded.sexp_of_t
-     match alias_conf.action with
+            (Option.map alias_conf.action ~f:snd)
-     | None -> Build.progn []
+        ]
-     | Some (loc, action) ->
+    in
-       SC.Action.run
+    add_alias sctx
-         sctx
+      ~dir
-         action
+      ~name:alias_conf.name
-         ~loc
+      ~stamp
-         ~dir
+      ~locks:(interpret_locks sctx ~dir ~scope alias_conf.locks)
-         ~dep_kind:Required
+      (SC.Deps.interpret_named sctx ~scope ~dir alias_conf.deps
-         ~bindings:(Pform.Map.of_bindings alias_conf.deps)
+       >>>
-         ~targets:Alias
+       match alias_conf.action with
-         ~targets_dir:dir
+       | None -> Build.progn []
-         ~scope)
+       | Some (loc, action) ->
+         SC.Action.run
+           sctx
+           action
+           ~loc
+           ~dir
+           ~dep_kind:Required
+           ~bindings:(Pform.Map.of_bindings alias_conf.deps)
+           ~targets:Alias
+           ~targets_dir:dir
+           ~scope)

src/stdune/bool.ml

@@ -0,0 +1,10 @@
+type t = bool
+
+let compare x y =
+  match x, y with
+  | true, true
+  | false, false -> Ordering.Eq
+  | true, false -> Gt
+  | false, true -> Lt
+
+let to_string = string_of_bool

src/stdune/bool.mli

@@ -0,0 +1,5 @@
+type t = bool
+
+val compare : t -> t -> Ordering.t
+
+val to_string : t -> string

src/stdune/sexp.ml

@@ -446,7 +446,6 @@ module Of_sexp = struct
     String.Map.iteri map ~f:(Hashtbl.add tbl);
     tbl
 
-
   let find_cstr cstrs loc name ctx values =
     match List.assoc cstrs name with
     | Some t ->

src/stdune/stdune.ml

@@ -18,6 +18,7 @@ module Set        = Set
 module Staged     = Staged
 module String     = String
 module Char       = Char
+module Bool       = Bool
 module Sexp       = Sexp
 module Path       = Path
 module Fmt        = Fmt

src/super_context.mli

@@ -79,6 +79,14 @@ 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 -> Dune_project.Name.t -> Scope.t
 
+val expand_vars
+  :  t
+  -> mode:'a String_with_vars.Mode.t
+  -> scope:Scope.t
+  -> dir:Path.t -> ?bindings:Pform.Map.t
+  -> String_with_vars.t
+  -> 'a
+
 val expand_vars_string
   :  t
   -> scope:Scope.t

src/value.ml

@@ -1,10 +1,17 @@
-open Stdune
+open Import
 
 type t =
   | String of string
   | Dir of Path.t
   | Path of Path.t
 
+let sexp_of_t =
+  let open Sexp.To_sexp in
+  function
+  | String s -> (pair string string) ("string", s)
+  | Path p -> (pair string Path.sexp_of_t) ("path", p)
+  | Dir p -> (pair string Path.sexp_of_t) ("dir", p)
+
 let string_of_path ~dir p = Path.reach ~from:dir p
 
 let to_string t ~dir =
@@ -13,6 +20,17 @@ let to_string t ~dir =
   | Dir p
   | Path p -> string_of_path ~dir p
 
+let compare_vals ~dir x y =
+  match x, y with
+  | String x, String y ->
+    String.compare x y
+  | (Path x | Dir x), (Path y | Dir y) ->
+    Path.compare x y
+  | String x, (Path _ | Dir _) ->
+    String.compare x (to_string ~dir y)
+  | (Path _ | Dir _), String y ->
+    String.compare (to_string ~dir x) y
+
 let to_path ?error_loc t ~dir =
   match t with
   | String s -> Path.relative ?error_loc dir s
@@ -22,6 +40,9 @@ let to_path ?error_loc t ~dir =
 module L = struct
   let to_strings t ~dir = List.map t ~f:(to_string ~dir)
 
+  let compare_vals ~dir =
+    List.compare ~compare:(compare_vals ~dir)
+
   let concat ts ~dir =
     List.map ~f:(to_string ~dir) ts
     |> String.concat ~sep:" "

src/value.mli

@@ -5,6 +5,8 @@ type t =
   | Dir of Path.t
   | Path of Path.t
 
+val sexp_of_t : t Sexp.To_sexp.t
+
 val to_string : t -> dir:Path.t -> string
 
 val to_path : ?error_loc:Loc.t -> t -> dir:Path.t -> Path.t
@@ -12,6 +14,16 @@ val to_path : ?error_loc:Loc.t -> t -> dir:Path.t -> Path.t
 module L : sig
   val strings : string list -> t list
 
+  (** [compare_vals ~dir a b] is a more efficient version of:
+
+      {[
+        List.compare ~compare:String.compare
+          (to_string ~dir a)
+          (to_string ~dir b)
+      ]}
+  *)
+  val compare_vals : dir:Path.t -> t list -> t list -> Ordering.t
+
   val paths : Path.t list -> t list
 
   val deps_only : t list -> Path.t list