Made `not:' produce predicates tagged as negated -- and for these, an

empty directory is *not* dropped.  This finally makes the results more
intuitive, and can now also express queries like only directories,
without their content.  (See comments and new tests.)

svn: r17456

collects/meta/tree/plt-tree.ss

@@ -6,3 +6,16 @@
   (when absolute-installation?
     (error 'get-plt-tree "must be used from a relative installation"))
   (get-tree (build-path (find-collects-dir) 'up)))
+
+#| good for benchmarking changes
+(printf "getting tree\n")
+(define t (get-plt-tree))
+(printf "filtering\n")
+(time
+ (for ([i (in-range 1000)]) ; print-tree
+   (tree-filter
+    (not: (or: "**/.svn/" "**/compiled/"))
+    ;; (get-tree "/home/scheme/plt/collects/scribble/.svn")
+    t
+    )))
+|#

collects/meta/tree/tests.ss

@@ -3052,9 +3052,97 @@
      -/urls.ss
      -/xref.ss
      )
-   ;; (not: "*/*") is the same as (not: "*/"), because empty directories are
-   ;; dropped (!!)
+   ;; (not: "*/*") would be the same as (not: "*/") if empty directories were
+   ;; dropped -- but for negated predicates the default is to keep empty
+   ;; directories, so the result is the same as the above but also includes
+   ;; directories
    (->datums (e `(tree->path-list (tree-filter (not: "*/*") ,a-tree))))
+   =>
+   '(
+     -/
+     -/.svn/
+     -/base/
+     -/base-render.ss
+     -/base.ss
+     -/basic.ss
+     -/bnf.ss
+     -/comment-reader.ss
+     -/compiled/
+     -/config.ss
+     -/core.ss
+     -/decode-struct.ss
+     -/decode.ss
+     -/doc/
+     -/doc.txt
+     -/doclang.ss
+     -/eval.ss
+     -/extract.ss
+     -/html-properties.ss
+     -/html-render.ss
+     -/info.ss
+     -/latex-properties.ss
+     -/latex-render.ss
+     -/lp/
+     -/lp-include.ss
+     -/lp.ss
+     -/manual/
+     -/manual-prefix.tex
+     -/manual-struct.ss
+     -/manual-style.tex
+     -/manual.ss
+     -/pdf-render.ss
+     -/private/
+     -/provide-doc-transform.ss
+     -/reader.ss
+     -/render-struct.ss
+     -/run.ss
+     -/scheme.css
+     -/scheme.ss
+     -/scheme.tex
+     -/scribble-common.js
+     -/scribble-prefix.html
+     -/scribble-prefix.tex
+     -/scribble-style.css
+     -/scribble-style.tex
+     -/scribble.css
+     -/scribble.tex
+     -/search.ss
+     -/sigplan/
+     -/sigplan.ss
+     -/srcdoc.ss
+     -/struct.ss
+     -/text/
+     -/text-render.ss
+     -/text.ss
+     -/tools/
+     -/urls.ss
+     -/xref.ss
+     )
+   ;; (not: (not: pred)) returns `pred'
+   (->datums (e `(tree->path-list (tree-filter (not: (not: (not: "*/*")))
+                                               ,a-tree))))
+   => same-as-last-datums
+   ;; the special treatment of negated predicates makes it possible to select
+   ;; only toplevel directories too
+   (->datums (e `(tree->path-list (tree-filter (and: "*/" (not: "*/*"))
+                                               ,a-tree))))
+   =>
+   '(
+     -/
+     -/.svn/
+     -/base/
+     -/compiled/
+     -/doc/
+     -/lp/
+     -/manual/
+     -/private/
+     -/sigplan/
+     -/text/
+     -/tools/
+     )
+   ;; demorgan works with this negation
+   (->datums (e `(tree->path-list (tree-filter (not: (or: (not: "*/") "*/*"))
+                                               ,a-tree))))
    => same-as-last-datums
    ;; only compiled directories
    (->datums (e `(tree->path-list (tree-filter "**/compiled/" ,a-tree))))
@@ -3241,6 +3329,43 @@
      -/tools/private/compiled/mk-drs-bitmaps_ss.dep
      -/tools/private/compiled/mk-drs-bitmaps_ss.zo
      )
+   ;; only compiled directories but not their content
+   (->datums (e `(tree->path-list (tree-filter (and: "**/compiled/"
+                                                     (not: "**/compiled/*"))
+                                               ,a-tree))))
+   =>
+   '(-/
+     -/base/
+     -/base/compiled/
+     -/base/lang/
+     -/base/lang/compiled/
+     -/compiled/
+     -/doc/
+     -/doc/compiled/
+     -/doc/lang/
+     -/doc/lang/compiled/
+     -/lp/
+     -/lp/lang/
+     -/lp/lang/compiled/
+     -/manual/
+     -/manual/compiled/
+     -/manual/lang/
+     -/manual/lang/compiled/
+     -/private/
+     -/private/compiled/
+     -/sigplan/
+     -/sigplan/compiled/
+     -/sigplan/lang/
+     -/sigplan/lang/compiled/
+     -/text/
+     -/text/compiled/
+     -/text/lang/
+     -/text/lang/compiled/
+     -/tools/
+     -/tools/compiled/
+     -/tools/private/
+     -/tools/private/compiled/
+     )
    ;; only .dep files in compiled directories
    (->datums (e `(tree->path-list (tree-filter "**/compiled/*.dep" ,a-tree))))
    =>

collects/meta/tree/tree.ss

@@ -56,7 +56,7 @@
 
 ;; ----------------------------------------------------------------------------
 
-;; a tree-filtering predicate is a function that receives a tree, and returns
+;; A tree-filtering predicate is a function that receives a tree, and returns
 ;; either #t/#f to include or exclude it, or it can return a function to be
 ;; applied on the sub-trees of a directory.  This setup makes it possible to
 ;; minimize the filtering work that is needed (compared to the old code that
@@ -162,7 +162,7 @@
         [(procedure? pred/glob) pred/glob]
         [else (error 'pred/glob->pred "bad predicate or glob: ~e" pred/glob)]))
 
-;; combine tree-filter predicates efficiently: stop when the result is #f or #t
+;; Combine tree-filter predicates efficiently: stop when the result is #f or #t
 ;; for `and:' or `or:' resp., drop predicates that returned #t or #f for them.
 (define-syntax-rule (define-combiner name: raw-name: pos neg)
   (begin
@@ -188,12 +188,24 @@
       (apply raw-name: (map pred/glob->pred preds/globs)))))
 (define-combiner and: raw-and: #t #f)
 (define-combiner or:  raw-or:  #f #t)
+
+;; Negating predicates is a little tricky, for example (not: "*/*") would
+;; filter out everything in all subdirectories, and since empty directories are
+;; usually dropped by `tree-filter', this means that the directories will be
+;; dropped too, leaving only immediate files.  The way to make this behave more
+;; intuitively is to mark negated predicates, and when filtering with a negated
+;; predicate the default is to keep empty directories rather than drop them.
+;; (As an aside, this can also be used to make (not: (not: f)) return `f'.)
+(define-struct negated (pred orig) #:property prop:procedure 0)
 (define (raw-not: p)
-  (lambda (tree)
-    (let ([r (p tree)])
-      (cond [(eq? #t r) #f]
-            [(eq? #f r) #t]
-            [else (raw-not: r)]))))
+  (if (negated? p)
+    (negated-orig p)
+    (make-negated (lambda (tree)
+                    (let ([r (p tree)])
+                      (cond [(eq? #t r) #f]
+                            [(eq? #f r) #t]
+                            [else (raw-not: r)])))
+                  p)))
 (define (not: pred/glob)
   (raw-not: (pred/glob->pred pred/glob)))
 
@@ -207,8 +219,13 @@
                                      (unless (eq? r sub) (set! same? #f))
                                      r))
                                  subs)])
-      (and (pair? new-subs) ; drop empty directories
-           (if same? dir (make-dir (tree-name dir) new-subs)))))
+      ;; (when (null? new-subs)
+      ;;   (printf "dropping result after pred: ~s\n" (object-name pred)))
+      ;; (and (pair? new-subs) ; drop empty directories
+      ;;      (if same? dir (make-dir (tree-name dir) new-subs)))
+      (cond [(and (null? new-subs) (not (negated? pred))) #f]
+            [same? dir]
+            [else (make-dir (tree-name dir) new-subs)])))
   (define (loop tree pred)
     (let ([r (pred tree)])
       (cond [(eq? #t r) tree]