enabled_if (#819)

# Problem

The problem this PR is trying to solve is a bit specific to dune, but it's likely that it will be encountered by other projects as well. Currently, dune has a complicated script for generating test definitions that make sure tests run only in environments which support them. For example, some tests may not run on win32. A mechanism to enable tests conditionally would fix these problems.

# Proposal

Add an `enabled_if` field to aliases to toggle the execution of the alias. This field will be valued by a little EDSL for expressing boolean expressions. Here's an example of the kind of conditions we'd express with it:

```
(alias
 ((name runtest)
  (deps (foo.exe))
  (action (run ${<}))
  (enabled_if (and (<> ${os} win32) (>= ${ocaml_version} 4.0.5)))))
```

# Progress

This stalled a bit since I'm not sure how to do handle type safety here. Ideally, we only allow numbers and versions to be compared with `>=`, `<`, etc. I guess we really need to annotate which variables are comparable and making sure that we don't compare numbers to strings or versions.

CHANGES.md

@@ -9,6 +9,9 @@ next
   now allowed in toplevel position in the workspace file, or for individual
   contexts. This feature requires `(dune lang 1.1)` (#1038, @rgrinberg)
 
+- Add ``enabled_if`` field for aliases and tests. This field controls whether
+  the test will be ran using a boolean expression language. (#819, @rgrinberg)
+
 1.0.1 (19/07/2018)
 ------------------
 

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
-      | None ->
-        of_sexp_errorf loc ~hint:{ on = s
-                                 ; candidates = String.Map.keys atom_table
-                                 }
-          "Unknown action or rule field."
-      | Some Field -> fields long_form
-      | Some Action -> short_form
-    end
+        match String.Map.find atom_table s with
+        | None ->
+          of_sexp_errorf loc ~hint:{ on = s
+                                   ; candidates = String.Map.keys atom_table
+                                   }
+            "Unknown action or rule field."
+        | Some Field -> fields long_form
+        | Some Action -> short_form
+      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
-    ; locks   : String_with_vars.t list
-    ; package : Package.t option
-    ; deps    : Dep_conf.t Bindings.t
+    { exes       : Executables.t
+    ; locks      : String_with_vars.t list
+    ; package    : Package.t option
+    ; 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
-    ; locks   : String_with_vars.t list
-    ; package : Package.t option
-    ; deps    : Dep_conf.t Bindings.t
+    { exes       : Executables.t
+    ; locks      : String_with_vars.t list
+    ; package    : Package.t option
+    ; 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 module S = Sexp.To_sexp in
-    Sexp.List
-      [ Sexp.unsafe_atom_of_string "user-alias"
-      ; Jbuild.Bindings.sexp_of_t Jbuild.Dep_conf.sexp_of_t alias_conf.deps
-      ; S.option Action.Unexpanded.sexp_of_t
-          (Option.map alias_conf.action ~f:snd)
-      ]
+  let enabled =
+    match alias_conf.enabled_if with
+    | None -> true
+    | Some blang ->
+      let f : String_with_vars.t Blang.expander =
+        { f = fun ~mode sw ->
+            ( 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
-    ~dir
-    ~name:alias_conf.name
-    ~stamp
-    ~locks:(interpret_locks sctx ~dir ~scope alias_conf.locks)
-    (SC.Deps.interpret_named sctx ~scope ~dir alias_conf.deps
-     >>>
-     match alias_conf.action with
-     | None -> Build.progn []
-     | 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)
+  if enabled then
+    let stamp =
+      let module S = Sexp.To_sexp in
+      Sexp.List
+        [ Sexp.unsafe_atom_of_string "user-alias"
+        ; Jbuild.Bindings.sexp_of_t Jbuild.Dep_conf.sexp_of_t alias_conf.deps
+        ; S.option Action.Unexpanded.sexp_of_t
+            (Option.map alias_conf.action ~f:snd)
+        ]
+    in
+    add_alias sctx
+      ~dir
+      ~name:alias_conf.name
+      ~stamp
+      ~locks:(interpret_locks sctx ~dir ~scope alias_conf.locks)
+      (SC.Deps.interpret_named sctx ~scope ~dir alias_conf.deps
+       >>>
+       match alias_conf.action with
+       | None -> Build.progn []
+       | 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