1#lang racket/base 2 3;; `omitted-paths' returns a list of omitted file and subdirectory names for a 4;; given directory, or 'all if the directory is completely omitted. Considers 5;; the local info.rkt as well as info.rkt in parent directories all the way to a 6;; collection root. (Could be a bit easier using `find-relevant-directories', 7;; but it needs to be available for raco setup, before the "info-domain" caches 8;; are created.) 9 10(provide omitted-paths) 11 12(require racket/path racket/list racket/promise "../dirs.rkt" "lib-roots.rkt") 13 14;; An entry for each collections root that holds a hash table. The hash table 15;; maps a reversed list of subpath elements to the exploded omitted-paths 16;; specified by the info files accumulated at that subpath for that subpath -- 17;; filtered to only relevant ones. Some entries are added automatically: 18;; "compiled", directories that begin with a ".", and "doc" unless it's in the 19;; main collection tree (it is not used there for documentation, and there is 20;; at least one place where it contains code: scribble/doc). 21(define roots 22 (delay 23 (map (lambda (p) 24 (list (explode-path (simplify-path (car p))) 25 (make-hash) 26 ;; don't omit "doc" in the main tree 27 (not (equal? (find-collects-dir) (car p))))) 28 library-roots))) 29 30;; if `x' has `y' as a prefix, return the tail, 31;; eg (relative-from '(1 2 3 4) '(1 2)) => '(3 4) 32(define (relative-from x y) 33 (cond [(null? y) x] 34 [(null? x) #f] 35 [(equal? (car x) (car y)) (relative-from (cdr x) (cdr y))] 36 [else #f])) 37 38(define-syntax-rule (with-memo t x expr) 39 (hash-ref! t x (lambda () expr))) 40 41(define ((implicit-omit? omit-doc?) path) 42 (let ([str (path-element->string path)]) 43 (or (member str '("compiled" "CVS")) 44 (and omit-doc? (equal? "doc" str)) 45 (regexp-match? #rx"^[.]" str)))) 46 47;; accumulated omissions is a list of 48;; exploded paths plus a list of (cons prefix-path regexp) 49(struct omits (exploded-paths prefix+rxs)) 50 51;; returns 'all or an `omits` 52(define (compute-omitted dir accumulated implicit-omit? get-info/full) 53 (define info (or (get-info/full dir) (lambda _ '()))) 54 (define explicit 55 (let ([omit (info 'compile-omit-paths (lambda () '()))]) 56 (if (eq? 'all omit) 57 'all 58 (map (lambda (e) (if (regexp? e) 59 e 60 (explode-path (simplify-path e #f)))) 61 ;; for backward compatibility 62 (append omit (info 'compile-omit-files (lambda () '()))))))) 63 (cond 64 [(or (eq? 'all explicit) (memq 'same explicit)) 'all] 65 [(findf (lambda (e) 66 (and (not (regexp? e)) 67 (or (null? e) (not (path? (car e))) (absolute-path? (car e))))) 68 explicit) 69 => (lambda (bad) 70 (error 'compile-omit-paths 71 "bad entry value in info file: ~e" (apply build-path bad)))] 72 [else 73 (define explicit-paths (filter pair? explicit)) 74 (define rxes (filter regexp? explicit)) 75 (omits 76 (append explicit-paths 77 (map list (filter (lambda (p) 78 (or (implicit-omit? p) 79 (for/or ([rx (in-list rxes)]) 80 (regexp-match? rx p)) 81 (for/or ([prefix+rx (in-list (omits-prefix+rxs accumulated))]) 82 (regexp-match? (cdr prefix+rx) 83 (build-path (car prefix+rx) p))))) 84 (directory-list dir))) 85 (omits-exploded-paths accumulated)) 86 (append (map (lambda (rx) (cons 'same rx)) rxes) 87 (omits-prefix+rxs accumulated)))])) 88 89(define (accumulate-omitted get-info/full rsubs root t omit-doc?) 90 (define dir (apply build-path root)) 91 (define implicit? (implicit-omit? omit-doc?)) 92 (let loop ([rsubs rsubs]) 93 (if (null? rsubs) 94 (compute-omitted dir (omits '() '()) implicit? get-info/full) 95 (with-memo t rsubs 96 (let ([acc (loop (cdr rsubs))] 97 [rsub (car rsubs)]) 98 (cond 99 [(or (eq? 'all acc) 100 ;; if the nest subdirectory is omitted, it's 'all from 101 ;; the perspective of the subdirectory or any even more 102 ;; nested directory: 103 (member (list rsub) (omits-exploded-paths acc))) 104 'all] 105 [else 106 ;; keep paths from enclosing directory that apply to 107 ;; nested directory, and strip off the nested directory element 108 (define acc-exploded-paths (for/list ([up (omits-exploded-paths acc)] 109 #:when (equal? (car up) (car rsubs))) 110 ;; must have non-null cdr: see `member' check 111 (cdr up))) 112 ;; extend prefix of each prefix+rx accumulated from the 113 ;; enclosing directory 114 (define acc-prefix+rxes (map (lambda (prefix+rx) 115 (define prefix (car prefix+rx)) 116 (cons (if (eq? prefix 'same) 117 rsub 118 (build-path prefix rsub)) 119 (cdr prefix+rx))) 120 (omits-prefix+rxs acc))) 121 (compute-omitted (apply build-path dir (reverse rsubs)) 122 (omits acc-exploded-paths acc-prefix+rxes) 123 implicit? 124 get-info/full)])))))) 125 126(define (omitted-paths* dir get-info/full root-dir) 127 (unless (and (path-string? dir) (complete-path? dir) (directory-exists? dir)) 128 (raise-type-error 'omitted-paths 129 "complete path to an existing directory" dir)) 130 (let* ([dir* (explode-path (simple-form-path dir))] 131 [r (ormap (lambda (root+table) 132 (let ([r (relative-from dir* (car root+table))]) 133 (and r (cons (reverse r) root+table)))) 134 (if root-dir 135 (list (list (explode-path (simple-form-path root-dir)) 136 (make-hash) 137 #t)) 138 (force roots)))] 139 [r (and r (apply accumulate-omitted get-info/full r))]) 140 (unless r 141 (error 'omitted-paths 142 "given directory path is not in any collection root: ~e" dir)) 143 (if (eq? 'all r) 144 r 145 ;; get paths for the immediate directory only; that is, drop 146 ;; any exploded path that has more than one element: 147 (filter-map (lambda (x) (and (null? (cdr x)) (car x))) 148 (omits-exploded-paths r))))) 149 150(define omitted-paths-memo (make-hash)) 151 152(define (omitted-paths dir get-info/full [root-dir #f]) 153 (with-memo omitted-paths-memo dir (omitted-paths* dir get-info/full root-dir))) 154