suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

More props code improvements.

Browse Source 
Simplified code, and additional testing for redundant properties, and
for properties that can be collapsed into a parent directory (this might
be dropped or used only for notification on differences, see
commentage).

Also, make drdr test itself reflectively.
This commit is contained in:
Eli Barzilay 2012-06-19 06:29:30 -04:00
parent 555aa0d8b6
commit b43affa171
1 changed files with 131 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

230
collects/meta/props
View File

@ -96,16 +96,15 @@ path/s is either such a string or a list of them.
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; This could use `meta/tree/tree' in the future, it's pretty similar. ;; This could use `meta/tree/tree' in the future, it's pretty similar.
(struct Tree (name [subs #:mutable] [props #:mutable])) (struct Tree (name [subs #:mutable] [props #:mutable] in-db?))
(define (Tree-subs/sorted tree) (define (Tree-subs/sorted tree)
(sort (Tree-subs tree) string<? (sort (Tree-subs tree) string<?
#:key (lambda (t) (symbol->string (Tree-name t))) #:key (λ (t) (symbol->string (Tree-name t))) #:cache-keys? #t))
#:cache-keys? #t))
;; Descriptors for known properties ;; Descriptors for known properties
(struct Prop (name description parse unparse)) (struct Prop (name description parse unparse))
(define props-tree (Tree #f '() '())) (define props-tree (Tree #f '() '() #f))
(define known-props #f) (define known-props #f)
;; used to throw an error message that fits uses as a program and when running ;; used to throw an error message that fits uses as a program and when running
@ -163,9 +162,8 @@ path/s is either such a string or a list of them.
" script needs to be exteded to allow them)")))) " script needs to be exteded to allow them)"))))
(define (parse-prop-string prop str who) (define (parse-prop-string prop str who)
(with-handlers ([exn? (lambda (e) (with-handlers ([exn? (λ (e) (error* who "bad value for `~a', ~a: ~s"
(error* who "bad value for `~a', ~a: ~s" (Prop-name prop) (exn-message e) str))])
(Prop-name prop) (exn-message e) str))])
((Prop-parse prop) str))) ((Prop-parse prop) str)))
(define (get-prop path-string prop-name [default get-prop] (define (get-prop path-string prop-name [default get-prop]
@ -179,15 +177,15 @@ path/s is either such a string or a list of them.
(define sub (define sub
(and (pair? path) (and (pair? path)
(let ([fst (car path)]) (let ([fst (car path)])
(ormap (lambda (sub) (and (eq? (Tree-name sub) fst) sub)) (ormap (λ (sub) (and (eq? (Tree-name sub) fst) sub))
(Tree-subs (car upchain)))))) (Tree-subs (car upchain))))))
(cond [sub (loop (cdr path) (cons sub upchain))] (cond [sub (loop (cdr path) (cons sub upchain))]
[(not strict?) upchain] [(not strict?) upchain]
[(pair? path) '()] [(pair? path) '()]
[else (list (car upchain))]))) [else (list (car upchain))])))
(define prop (find-prop 'get-prop prop-name)) (define prop (find-prop 'get-prop prop-name))
(cond [(ormap (lambda (tree) (assq prop-name (Tree-props tree))) upchain) (cond [(ormap (λ (tree) (assq prop-name (Tree-props tree))) upchain)
=> (lambda (x) ((if as-string? (Prop-unparse prop) values) (cdr x)))] => (λ (x) ((if as-string? (Prop-unparse prop) values) (cdr x)))]
[(eq? get-prop default) [(eq? get-prop default)
(error* 'get-prop "no `~s' property for \"~a\"" prop-name path-string)] (error* 'get-prop "no `~s' property for \"~a\"" prop-name path-string)]
[(procedure? default) (default)] [(procedure? default) (default)]
@ -211,14 +209,13 @@ path/s is either such a string or a list of them.
(Tree-props tree))))))) (Tree-props tree)))))))
(define (del-prop! path-string/s prop-name #:warn? [warn? #t]) (define (del-prop! path-string/s prop-name #:warn? [warn? #t])
(define prop (find-prop 'set-prop! prop-name)) (define prop (find-prop 'del-prop! prop-name))
(for ([path (in-list (single->list path-string/s))]) (for ([path (in-list (single->list path-string/s))])
(validate-path-string path 'del-prop!) (validate-path-string path 'del-prop!)
(let* ([tree (tree-find path #f)] (let* ([tree (tree-find path #f)]
[props (if tree (Tree-props tree) '())]) [props (if tree (Tree-props tree) '())])
(cond [(assq prop-name props) (cond [(assq prop-name props)
(set-Tree-props! tree (filter (lambda (p) (set-Tree-props! tree (filter (λ (p) (not (eq? prop-name (car p))))
(not (eq? prop-name (car p))))
props))] props))]
[warn? (warn "no `~s' property on ~s" prop-name path)])))) [warn? (warn "no `~s' property on ~s" prop-name path)]))))
@ -227,14 +224,30 @@ path/s is either such a string or a list of them.
(if (null? path) (if (null? path)
tree tree
(let* ([fst (car path)] (let* ([fst (car path)]
[sub (or (ormap (lambda (sub) (and (eq? (Tree-name sub) fst) sub)) [rst (cdr path)]
[sub (or (ormap (λ (sub) (and (eq? (Tree-name sub) fst) sub))
(Tree-subs tree)) (Tree-subs tree))
(and create? (and create?
(let ([new (Tree fst '() '())]) ;; keep track of properties that are actually in the
;; db, for verification
(let ([new (Tree fst '() '()
(and (null? rst) create?))])
(set-Tree-subs! tree (cons new (Tree-subs tree))) (set-Tree-subs! tree (cons new (Tree-subs tree)))
new)))]) new)))])
(and sub (loop (cdr path) sub)))))) (and sub (loop (cdr path) sub))))))
(define (find-root)
(let loop ([p this-file] [n 3]) ; look only a few level up
(let-values ([(base _1 _2) (split-path p)])
(and base
(or (and (andmap (λ (d) (directory-exists? (build-path p d)))
'("collects" "doc" "man" "src"))
p)
(if (> n 0)
(loop base (sub1 n))
(error* #f "could not find the racket root from ~a"
(path-only this-file))))))))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; Reading and writing ;; Reading and writing
@ -324,69 +337,101 @@ path/s is either such a string or a list of them.
[temp (make-temporary-file (format "~a~~a" this-file) this-file)]) [temp (make-temporary-file (format "~a~~a" this-file) this-file)])
(dynamic-wind (dynamic-wind
void void
(lambda () (λ () (call-with-output-file* temp #:exists 'truncate
(call-with-output-file* temp #:exists 'truncate (λ (new) (call-with-input-file* this-file
(lambda (new) (λ (old) (*write-props old new)))))
(call-with-input-file* this-file (delete-file this-file)
(lambda (old) (*write-props old new))))) (rename-file-or-directory temp this-file))
(delete-file this-file) (λ () (when (file-exists? temp) (delete-file temp))))))
(rename-file-or-directory temp this-file))
(lambda () (when (file-exists? temp) (delete-file temp))))))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; Verify props ;; Verify this database
(define no-responsible-needed (define no-props-needed
'(#rx"/compiled$" '(#rx"/compiled$"
#rx"/[.]gitignore$" #rx"(?:^|/)[.]git"
#rx"^(?:README|bin|lib|include|[.]mailmap)$"
#rx"^collects/info-domain$" #rx"^collects/info-domain$"
#rx"^doc/[^/]*$")) #rx"^doc/[^/]*$"))
(define ((verify find-root)) (define (verify)
(define errors 0) (define errors 0)
(define (path-error path err) (define (path-error path fmt . more)
(when (= 0 errors) (newline) (flush-output)) (when (= 0 errors) (newline) (flush-output))
(set! errors (add1 errors)) (set! errors (add1 errors))
(eprintf " ~a: ~a\n" path err)) (eprintf " ~a: ~a\n" (or path "<ROOT>") (apply format fmt more)))
(define (verify-responsibles tree path) (define (uncovered-subs path/ subs)
(define alist (map (lambda (t) (cons (Tree-name t) (Tree-props t))) (for*/list ([fn (in-list (directory-list (if (equal? path/ "") "." path/)))]
(Tree-subs tree))) [str (in-value (path-element->string fn))]
(for* ([f (directory-list path)] #:unless (memq (string->symbol str) subs)
[s (in-value (path-element->string f))] [subp (in-value (string-append path/ str))]
[p (in-value (string-append path "/" s))] #:unless (for/or ([rx (in-list no-props-needed)])
;; check dirs too, since we might not get into them if (regexp-match? rx subp)))
;; there are no entries for them subp))
;; #:when (file-exists? p) (define prop-names (map Prop-name known-props))
[s (in-value (string->symbol s))]) (define (merge-props propss path/ others)
(unless (or (for/or ([sub (in-list (Tree-subs tree))]) ;; Used to detect collapsible properties, might be disabled, or
(and (eq? s (Tree-name sub)) ;; maybe just output them to stderr if that leads to an email only
(or (assq 'responsible (Tree-props sub)) ;; when there are changes.
;; if it has subs, then we'll get there eventually (filter
(pair? (Tree-subs sub))))) values
(for/or ([rx (in-list no-responsible-needed)]) (for/list ([pname (in-list prop-names)])
(regexp-match? rx p))) (define values
(path-error p "no responsible")))) (for*/list ([props (in-list propss)]
(define (loop tree path responsible) [a (in-value (assq pname props))]
#:when a)
(cdr a)))
(cond [(null? values) #f]
[(memq (void) values) (cons pname (void))]
[else
(define value (car values))
(define rest (cdr values))
(define same? (andmap (λ (v) (equal? value v)) rest))
(when (and same? (pair? rest) (null? others))
(path-error (string-append path/ "...")
"all ~s sub-properties are ~s" pname value)
;; Printing the others is usually too verbose.
;; (define rx (regexp (string-append "^" (regexp-quote path/))))
;; (define os (map (λ (o) (regexp-replace rx o "")) others))
;; (define os*
;; (if (> (length os) 20) (append (take os 20) '("...")) os))
;; (eprintf " others: ~a\n" (string-join os* ", "))
)
(cons pname (if same? (car values) (void)))]))))
(define (loop tree base-path base-props)
(define name (Tree-name tree))
(define path (and name (string-append base-path (symbol->string name))))
(define props (Tree-props tree))
(define all-props (append props base-props))
(define subs (Tree-subs tree))
(when (eq? '|| name) (path-error base-path "empty name (trailing slash?)"))
(unless (equal? (reverse (Tree-subs tree)) (Tree-subs/sorted tree)) (unless (equal? (reverse (Tree-subs tree)) (Tree-subs/sorted tree))
(path-error path "unsorted sub-paths")) (path-error path "unsorted sub-paths"))
(for ([sub (in-list (Tree-subs tree))]) (when (and (Tree-in-db? tree) (null? props))
(define name (symbol->string (Tree-name sub))) (path-error path "no properties"))
(define path* (string-append path name)) (for ([p (in-list props)] #:when (member p base-props))
(define responsible* (or responsible (path-error path "redundant property: ~s := ~s" (car p) (cdr p)))
(assq 'responsible (Tree-props sub)))) (define path/ ; #f for a file, "" for the root
(cond [(equal? "" name) (cond [(not path) ""]
(path-error path* "empty name")] [(directory-exists? path) (string-append path "/")]
[(directory-exists? path*) [(file-exists? path) #f]
(unless responsible* (verify-responsibles sub path*)) [else (path-error path "Missing file/directory")]))
(loop sub (string-append path* "/") responsible*)] (define others (if path/ (uncovered-subs path/ (map Tree-name subs)) '()))
[(not (file-exists? path*)) (unless (assq 'responsible all-props)
(path-error path* "Missing file/directory")]))) (define (bad p) (path-error p "no responsible"))
(if path/ (for-each bad others) (bad path)))
(if path/
(let* ([rs (for/list ([sub (in-list subs)]) (loop sub path/ all-props))]
[others (append others (map (λ (x) (string-append path/ x))
(append-map car rs)))])
(cons others (merge-props (cons props (map cdr rs)) path/ others)))
(cons others props)))
(define root (find-root)) (define root (find-root))
(printf "Root: ~a..." root) (printf "Root: ~a..." root)
(flush-output) (flush-output)
(parameterize ([current-directory root]) (loop props-tree "" #f)) (parameterize ([current-directory root]) (loop props-tree #f '()))
(if (errors . > . 0) (if (errors . > . 0)
(error* 'verify "~s path errors" errors) (error* #f "~s path errors" errors)
(printf " no errors.\n"))) (printf " no errors.\n")))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
@ -435,18 +480,7 @@ path/s is either such a string or a list of them.
[("set") "set <prop> <val> <path/s>" ,set] [("set") "set <prop> <val> <path/s>" ,set]
[("del") "del <prop> <path/s>" ,del] [("del") "del <prop> <path/s>" ,del]
[("mv") "mv <path> <path>" ,mv] [("mv") "mv <path> <path>" ,mv]
[("verify") "verify: check that paths exist" ,(verify find-root)])) [("verify") "verify: check that paths exist" ,verify]))
(define (find-root)
(let loop ([p this-file] [n 3]) ; look only a few level up
(let-values ([(base _1 _2) (split-path p)])
(and base
(or (and (andmap (lambda (d) (directory-exists? (build-path p d)))
'("collects" "doc" "man" "src"))
p)
(if (> n 0)
(loop base (sub1 n))
(error* #f "could not find the racket root from ~a"
(path-only this-file))))))))
(define check-existing-paths? #t) (define check-existing-paths? #t)
(define (paths->list path paths) (define (paths->list path paths)
(if (and (equal? "-" path) (null? paths)) (if (and (equal? "-" path) (null? paths))
@ -517,17 +551,15 @@ path/s is either such a string or a list of them.
(Prop (Prop
'responsible 'responsible
"responsible person/people (comma separated names)" "responsible person/people (comma separated names)"
(lambda (str) (λ (str)
(let* ([strs (remove* '("") (regexp-split #rx" *, *" str))] (let* ([strs (remove* '("") (regexp-split #rx" *, *" str))]
[syms (map string->symbol strs)]) [syms (map string->symbol strs)])
(cond [(ormap (lambda (s) (and (not (regexp-match? #rx"^[a-z]+" s)) s)) (cond [(ormap (λ (s) (and (not (regexp-match? #rx"^[a-z]+" s)) s)) strs)
strs) => (λ (s) (error (format "~s is an invalid name" s)))]
=> (lambda (s) (error (format "~s is an invalid name" s)))]
[(not (= (length syms) (length (remove-duplicates syms eq?)))) [(not (= (length syms) (length (remove-duplicates syms eq?))))
(error "repeated names")] (error "repeated names")]
[else syms]))) [else syms])))
(lambda (syms) (λ (syms) (string-join (map symbol->string syms) ",")))
(apply string-append (add-between (map symbol->string syms) ","))))
;; -------------------- ;; --------------------
(Prop (Prop
'drdr:command-line 'drdr:command-line
@ -537,7 +569,7 @@ path/s is either such a string or a list of them.
"missing => use the default (\"racket ~s\" for *.rkt etc," "missing => use the default (\"racket ~s\" for *.rkt etc,"
"\"racket -f ~s\" for *.rktl)") "\"racket -f ~s\" for *.rktl)")
"\n ") "\n ")
(lambda (str) (λ (str)
(define (bad) (error "expecting an empty string, or one with `~s'")) (define (bad) (error "expecting an empty string, or one with `~s'"))
(if (equal? str "") (if (equal? str "")
#f #f
@ -548,8 +580,7 @@ path/s is either such a string or a list of them.
#f #f
(let* ([xs (regexp-split #rx" " str)] (let* ([xs (regexp-split #rx" " str)]
[xs (cons (string->symbol (car xs)) [xs (cons (string->symbol (car xs))
(map (lambda (x) (if (equal? x "~s") '* x)) (map (λ (x) (if (equal? x "~s") '* x)) (cdr xs)))]
(cdr xs)))]
[*-tail (memq '* xs)] [*-tail (memq '* xs)]
[commands '(racket gracket gracket-text raco mzc)]) [commands '(racket gracket gracket-text raco mzc)])
(unless (memq (car xs) commands) (unless (memq (car xs) commands)
@ -561,39 +592,39 @@ path/s is either such a string or a list of them.
(when (memq '* (cdr *-tail)) (when (memq '* (cdr *-tail))
(error "can't use more than a single `~s'")) (error "can't use more than a single `~s'"))
xs))))) xs)))))
(lambda (cmd) (λ (cmd)
(define (bad) (define (bad)
(error 'drdr:command-line "bad command-line value: ~.s" cmd)) (error 'drdr:command-line "bad command-line value: ~.s" cmd))
(cond [(not cmd) ""] (cond [(not cmd) ""]
[(not (list? cmd)) (bad)] [(not (list? cmd)) (bad)]
[else (string-join (map (lambda (x) [else (string-join (for/list ([x (in-list cmd)])
(cond [(eq? x '*) "~s"] (cond [(eq? x '*) "~s"]
[(symbol? x) (symbol->string x)] [(symbol? x) (symbol->string x)]
[(string? x) x] [(string? x) x]
[else (bad)])) [else (bad)])))])))
cmd))])))
;; -------------------- ;; --------------------
(Prop (Prop
'drdr:timeout 'drdr:timeout
"timeout in seconds" "timeout in seconds"
(lambda (str) (λ (str) (if (regexp-match? #rx"^ *[0-9]+ *$" str)
(if (regexp-match? #rx"^ *[0-9]+ *$" str) (string->number str)
(string->number str) (error "expecting an integer")))
(error "expecting an integer")))
number->string) number->string)
;; -------------------- ;; --------------------
(Prop (Prop
'drdr:random 'drdr:random
"is file output random?" "is file output random?"
(lambda (str) (λ (str) (cond [(equal? str "yes") #t]
(cond [(equal? str "yes") #t] [(equal? str "no") #f]
[(equal? str "no") #f] [else (error "expecting \"yes\" or \"no\"")]))
[else (error "expecting \"yes\" or \"no\"")])) (λ (b) (if b "yes" "no")))))
(lambda (b) (if b "yes" "no")))))
;; read the arguments here, so just requiring this file verifies the data ;; read the arguments here, so just requiring this file verifies the data
(read-props) (read-props)
;; if we're running directly, do a verification
(module+ main (verify))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
#| #:begin-props #| #:begin-props
@ -785,6 +816,7 @@ path/s is either such a string or a list of them.
"collects/meta/drdr" responsible (jay) drdr:command-line #f "collects/meta/drdr" responsible (jay) drdr:command-line #f
"collects/meta/drdr2" responsible (jay) drdr:command-line #f "collects/meta/drdr2" responsible (jay) drdr:command-line #f
"collects/meta/images/mkheart.rkt" drdr:command-line #f "collects/meta/images/mkheart.rkt" drdr:command-line #f
"collects/meta/props" drdr:command-line (racket *) responsible (eli jay)
"collects/meta/web" drdr:command-line #f "collects/meta/web" drdr:command-line #f
"collects/mred" responsible (mflatt) "collects/mred" responsible (mflatt)
"collects/mred/edit-main.rkt" drdr:command-line (mzc *) "collects/mred/edit-main.rkt" drdr:command-line (mzc *)