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