feat(library/init/meta/expr): add expr.has_local_in

library/init/meta/expr.lean

@@ -4,7 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura
 -/
 prelude
-import init.meta.level init.category.monad
+import init.meta.level init.category.monad init.meta.rb_map
 universes u v
 
 structure pos :=
@@ -128,6 +128,8 @@ meta constant expr.collect_univ_params : expr → list name
 /-- `occurs e t` returns `tt` iff `e` occurs in `t` -/
 meta constant expr.occurs        : expr → expr → bool
 
+meta constant expr.has_local_in : expr → name_set → bool
+
 /-- (reflected a) is a special opaque container for a closed `expr` representing `a`.
     It can only be obtained via type class inference, which will use the representation
     of `a` in the calling context. Local constants in the representation are replaced
@@ -391,3 +393,16 @@ meta def mfold {α : Type} {m : Type → Type} [monad m] (e : expr) (a : α) (fn
 fold e (return a) (λ e n a, a >>= fn e n)
 
 end expr
+
+@[reducible] meta def expr_map (data : Type) := rb_map expr data
+namespace expr_map
+export rb_map (hiding mk)
+
+meta def mk (data : Type) : expr_map data := rb_map.mk expr data
+end expr_map
+
+meta def mk_expr_map {data : Type} : expr_map data :=
+expr_map.mk data
+
+@[reducible] meta def expr_set := rb_set expr
+meta def mk_expr_set : expr_set := mk_rb_set

library/init/meta/rb_map.lean

@@ -4,13 +4,14 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura, Jeremy Avigad
 -/
 prelude
-import init.data.ordering init.function init.meta.name init.meta.format init.meta.expr
+import init.data.ordering init.function init.meta.name init.meta.format init.category.monad
 
 meta constant {u₁ u₂} rb_map : Type u₁ → Type u₂ → Type (max u₁ u₂)
 
 namespace rb_map
 meta constant mk_core {key : Type} (data : Type)        : (key → key → ordering) → rb_map key data
 meta constant size {key : Type} {data : Type}           : rb_map key data → nat
+meta constant empty {key : Type} {data : Type}          : rb_map key data → bool
 meta constant insert {key : Type} {data : Type}         : rb_map key data → key → data → rb_map key data
 meta constant erase  {key : Type} {data : Type}         : rb_map key data → key → rb_map key data
 meta constant contains {key : Type} {data : Type}       : rb_map key data → key → bool
@@ -78,16 +79,6 @@ end name_map
 meta def mk_name_map {data : Type} : name_map data :=
 name_map.mk data
 
-@[reducible] meta def expr_map (data : Type) := rb_map expr data
-namespace expr_map
-export rb_map (hiding mk)
-
-meta def mk (data : Type) : expr_map data := rb_map.mk expr data
-end expr_map
-
-meta def mk_expr_map {data : Type} : expr_map data :=
-expr_map.mk data
-
 open rb_map prod
 section
 open format
@@ -162,6 +153,9 @@ s.contains k
 meta def size {key} (s : rb_set key) : nat :=
 s.size
 
+meta def empty {key : Type} (s : rb_set key) : bool :=
+s.empty
+
 meta def fold {key α : Type} (s : rb_set key) (a : α) (fn : key → α → α) : α :=
 s.fold a (λ k _ a, fn k a)
 
@@ -176,9 +170,6 @@ meta instance {key} [has_to_format key] : has_to_format (rb_set key) :=
               to_fmt "}"⟩
 end rb_set
 
-@[reducible] meta def expr_set := rb_set expr
-meta def mk_expr_set : expr_set := mk_rb_set
-
 meta constant name_set : Type
 meta constant mk_name_set : name_set
 
@@ -187,6 +178,7 @@ meta constant insert         : name_set → name → name_set
 meta constant erase          : name_set → name → name_set
 meta constant contains       : name_set → name → bool
 meta constant size           : name_set → nat
+meta constant empty          : name_set → bool
 meta constant fold {α :Type} : name_set → α → (name → α → α) → α
 
 meta def to_list (s : name_set) : list name :=

src/library/locals.cpp

@@ -146,6 +146,23 @@ bool contains_local(expr const & e, name const & n) {
     return result;
 }
 
+bool contains_local(expr const & e, name_set const & s) {
+    if (!has_local(e))
+        return false;
+    bool result = false;
+    for_each(e, [&](expr const & e, unsigned) {
+            if (result || !has_local(e))  {
+                return false;
+            } else if (is_local(e) && s.contains(mlocal_name(e))) {
+                result = true;
+                return false;
+            } else {
+                return true;
+            }
+        });
+    return result;
+}
+
 optional<expr> depends_on(unsigned sz, expr const * es, expr const & h) {
     for (unsigned i = 0; i < sz; i++)
         if (depends_on(es[i], h))

src/library/locals.h

@@ -45,6 +45,9 @@ bool contains_local(expr const & l, T const & locals) {
                        [&](expr const & l1) { return mlocal_name(l1) == mlocal_name(l); });
 }
 
+/** \brief Return true iff \c e contains a local constant \c h s.t. mlocal_name(h) in s */
+bool contains_local(expr const & e, name_set const & s);
+
 /** \brief Return true iff \c e contains a local constant named \c n (it uses mlocal_name) */
 bool contains_local(expr const & e, name const & n);
 

src/library/vm/vm_expr.cpp

@@ -32,6 +32,7 @@ Author: Leonardo de Moura
 #include "library/vm/vm_list.h"
 #include "library/vm/vm_string.h"
 #include "library/vm/vm_pos_info.h"
+#include "library/vm/vm_rb_map.h"
 #include "library/compiler/simp_inductive.h"
 #include "library/compiler/nat_value.h"
 
@@ -465,6 +466,10 @@ vm_obj expr_pos(vm_obj const &, vm_obj const & e) {
     return mk_vm_none();
 }
 
+vm_obj expr_has_local_in(vm_obj const & e, vm_obj const & s) {
+    return mk_vm_bool(contains_local(to_expr(e), to_name_set(s)));
+}
+
 void initialize_vm_expr() {
     DECLARE_VM_BUILTIN(name({"expr", "var"}),              expr_var);
     DECLARE_VM_BUILTIN(name({"expr", "sort"}),             expr_sort);
@@ -501,6 +506,8 @@ void initialize_vm_expr() {
     DECLARE_VM_BUILTIN(name({"expr", "copy_pos_info"}),    expr_copy_pos_info);
     DECLARE_VM_BUILTIN(name({"expr", "occurs"}),           expr_occurs);
     DECLARE_VM_BUILTIN(name({"expr", "collect_univ_params"}), expr_collect_univ_params);
+    DECLARE_VM_BUILTIN(name({"expr", "has_local_in"}),     expr_has_local_in);
+
     DECLARE_VM_CASES_BUILTIN(name({"expr", "cases_on"}),   expr_cases_on);
 
     DECLARE_VM_BUILTIN(name("string", "reflect"),           reflect_string);

src/library/vm/vm_rb_map.cpp

@@ -92,6 +92,10 @@ vm_obj rb_map_size(vm_obj const &, vm_obj const &, vm_obj const & m) {
     return mk_vm_nat(to_map(m).size());
 }
 
+vm_obj rb_map_empty(vm_obj const &, vm_obj const &, vm_obj const & m) {
+    return mk_vm_bool(to_map(m).empty());
+}
+
 vm_obj rb_map_insert(vm_obj const &, vm_obj const &, vm_obj const & m, vm_obj const & k, vm_obj const & d) {
     return to_obj(insert(to_map(m), k, d));
 }
@@ -163,6 +167,10 @@ vm_obj name_set_size(vm_obj const & m) {
     return mk_vm_nat(to_name_set(m).size());
 }
 
+vm_obj name_set_empty(vm_obj const & m) {
+    return mk_vm_bool(to_name_set(m).empty());
+}
+
 vm_obj name_set_insert(vm_obj const & m, vm_obj const & k) {
     return to_obj(insert(to_name_set(m), to_name(k)));
 }
@@ -186,6 +194,7 @@ vm_obj name_set_fold(vm_obj const &, vm_obj const & m, vm_obj const & a, vm_obj
 void initialize_vm_rb_map() {
     DECLARE_VM_BUILTIN(name({"rb_map", "mk_core"}),        rb_map_mk_core);
     DECLARE_VM_BUILTIN(name({"rb_map", "size"}),           rb_map_size);
+    DECLARE_VM_BUILTIN(name({"rb_map", "empty"}),          rb_map_empty);
     DECLARE_VM_BUILTIN(name({"rb_map", "insert"}),         rb_map_insert);
     DECLARE_VM_BUILTIN(name({"rb_map", "erase"}),          rb_map_erase);
     DECLARE_VM_BUILTIN(name({"rb_map", "contains"}),       rb_map_contains);
@@ -196,6 +205,7 @@ void initialize_vm_rb_map() {
 
     DECLARE_VM_BUILTIN(name({"mk_name_set"}),              mk_name_set);
     DECLARE_VM_BUILTIN(name({"name_set", "size"}),         name_set_size);
+    DECLARE_VM_BUILTIN(name({"name_set", "empty"}),        name_set_empty);
     DECLARE_VM_BUILTIN(name({"name_set", "insert"}),       name_set_insert);
     DECLARE_VM_BUILTIN(name({"name_set", "erase"}),        name_set_erase);
     DECLARE_VM_BUILTIN(name({"name_set", "contains"}),     name_set_contains);