From 3d9612f95c024db63050db502b43aea9d7c3cbe5 Mon Sep 17 00:00:00 2001
From: Rudi Grinberg <rudi.grinberg@gmail.com>
Date: Tue, 29 May 2018 15:11:52 +0700
Subject: [PATCH] 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    | 34 ++++++++++++++++++++
 src/blang.ml          | 45 ++++++++++++++++++++++++++
 src/blang.mli         | 25 +++++++++++++++
 src/gen_rules.ml      |  1 +
 src/jbuild.ml         | 73 ++++++++++++++++++++++++++++++++++---------
 src/jbuild.mli        | 10 +++---
 src/simple_rules.ml   | 69 +++++++++++++++++++++++-----------------
 src/stdune/bool.ml    | 10 ++++++
 src/stdune/bool.mli   |  5 +++
 src/stdune/sexp.ml    |  1 -
 src/stdune/stdune.ml  |  1 +
 src/super_context.mli |  8 +++++
 src/value.ml          | 23 +++++++++++++-
 src/value.mli         | 12 +++++++
 14 files changed, 269 insertions(+), 48 deletions(-)
 create mode 100644 src/blang.ml
 create mode 100644 src/blang.mli
 create mode 100644 src/stdune/bool.ml
 create mode 100644 src/stdune/bool.mli

diff --git a/doc/dune-files.rst b/doc/dune-files.rst
index 5cdfe664..9ed1feb4 100644
--- a/doc/dune-files.rst
+++ b/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
 -------------------
 
diff --git a/src/blang.ml b/src/blang.ml
new file mode 100644
index 00000000..6addc0d0
--- /dev/null
+++ b/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
diff --git a/src/blang.mli b/src/blang.mli
new file mode 100644
index 00000000..9b9d15c9
--- /dev/null
+++ b/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
diff --git a/src/gen_rules.ml b/src/gen_rules.ml
index 47ed8c90..357ef8ac 100644
--- a/src/gen_rules.ml
+++ b/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 ->
diff --git a/src/jbuild.ml b/src/jbuild.ml
index 5002c0ad..ce5de45a 100644
--- a/src/jbuild.ml
+++ b/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)))
diff --git a/src/jbuild.mli b/src/jbuild.mli
index 7713f3ee..2d36f9b2 100644
--- a/src/jbuild.mli
+++ b/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
 
diff --git a/src/simple_rules.ml b/src/simple_rules.ml
index 96fd9fc9..6f7107d4 100644
--- a/src/simple_rules.ml
+++ b/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)
diff --git a/src/stdune/bool.ml b/src/stdune/bool.ml
new file mode 100644
index 00000000..6400a5ac
--- /dev/null
+++ b/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
diff --git a/src/stdune/bool.mli b/src/stdune/bool.mli
new file mode 100644
index 00000000..d0ff8707
--- /dev/null
+++ b/src/stdune/bool.mli
@@ -0,0 +1,5 @@
+type t = bool
+
+val compare : t -> t -> Ordering.t
+
+val to_string : t -> string
diff --git a/src/stdune/sexp.ml b/src/stdune/sexp.ml
index c6b581f2..b3817f71 100644
--- a/src/stdune/sexp.ml
+++ b/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 ->
diff --git a/src/stdune/stdune.ml b/src/stdune/stdune.ml
index 4aadebec..bf38fdb9 100644
--- a/src/stdune/stdune.ml
+++ b/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
diff --git a/src/super_context.mli b/src/super_context.mli
index 02e630f6..b32f5fe4 100644
--- a/src/super_context.mli
+++ b/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
diff --git a/src/value.ml b/src/value.ml
index f3dc587b..45574dbf 100644
--- a/src/value.ml
+++ b/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:" "
diff --git a/src/value.mli b/src/value.mli
index ee7162dd..b5f90fef 100644
--- a/src/value.mli
+++ b/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