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

Improve some code, add a "verify" verb to verify paths in props info.

Browse Source
This commit is contained in:
Eli Barzilay 2012-06-14 22:10:40 -04:00
parent fac76a56f8
commit 7d40901381
1 changed files with 83 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

150
collects/meta/props
View File

@ -96,12 +96,12 @@ 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.
(define-struct tree (name [subs #:mutable] [props #:mutable])) (struct Tree (name [subs #:mutable] [props #:mutable]))
;; Descriptors for known properties ;; Descriptors for known properties
(define-struct prop (name description parse unparse)) (struct Prop (name description parse unparse))
(define props-tree (make-tree #f '() '())) (define props-tree (Tree #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
@ -121,10 +121,10 @@ path/s is either such a string or a list of them.
(fprintf (current-error-port) "warning: ~a\n" (apply format fmt args))) (fprintf (current-error-port) "warning: ~a\n" (apply format fmt args)))
(define (find-prop who pname [error-message "unknown property: ~.s"]) (define (find-prop who pname [error-message "unknown property: ~.s"])
(if (prop? pname) (if (Prop? pname)
pname ; might happen when `set-prop!' calls `get-prop' pname ; might happen when `set-prop!' calls `get-prop'
(or (for/or ([p (in-list known-props)]) (or (for/or ([p (in-list known-props)])
(and (eq? pname (prop-name p)) p)) (and (eq? pname (Prop-name p)) p))
(error* who error-message pname)))) (error* who error-message pname))))
(define (path->symbols path-string) (define (path->symbols path-string)
@ -161,35 +161,33 @@ path/s is either such a string or a list of them.
(define (parse-prop-string prop str who) (define (parse-prop-string prop str who)
(with-handlers ([exn? (lambda (e) (with-handlers ([exn? (lambda (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]
#:strict? [strict? #f] #:as-string? [as-string? #f]) #:strict? [strict? #f] #:as-string? [as-string? #f])
(validate-path-string path-string 'get-prop #t) ; no errors (validate-path-string path-string 'get-prop #t) ; no errors
(let ([upchain (define upchain
;; take the chain going up from the most specific node, so that ;; take the chain going up from the most specific node, so that properties
;; properties of a directory apply to subpaths ;; of a directory apply to subpaths
(let loop ([path (path->symbols path-string)] (let loop ([path (path->symbols path-string)]
[upchain (list props-tree)]) [upchain (list props-tree)])
(let ([sub (and (pair? path) (define sub
(let ([fst (car path)]) (and (pair? path)
(ormap (lambda (sub) (let ([fst (car path)])
(and (eq? (tree-name sub) fst) sub)) (ormap (lambda (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))])))
[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 (lambda (tree) (assq prop-name (Tree-props tree))) upchain)
=> (lambda (x) => (lambda (x) ((if as-string? (Prop-unparse prop) values) (cdr 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\"" [(procedure? default) (default)]
prop-name path-string)] [else default]))
[(procedure? default) (default)]
[else default])))
(define (single->list x) (if (list? x) x (list x))) (define (single->list x) (if (list? x) x (list x)))
@ -205,17 +203,17 @@ path/s is either such a string or a list of them.
"a value it already has (possibly via a containing directory)") "a value it already has (possibly via a containing directory)")
;; otherwise set it blindly (will be normalized away when written) ;; otherwise set it blindly (will be normalized away when written)
(let ([tree (tree-find path #t)]) (let ([tree (tree-find path #t)])
(set-tree-props! tree (cons (cons prop-name val) (set-Tree-props! tree (cons (cons prop-name val)
(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 'set-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 (lambda (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)]))))
@ -225,11 +223,11 @@ 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)) [sub (or (ormap (lambda (sub) (and (eq? (Tree-name sub) fst) sub))
(tree-subs tree)) (Tree-subs tree))
(and create? (and create?
(let ([new (make-tree fst '() '())]) (let ([new (Tree fst '() '())])
(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))))))
@ -267,7 +265,7 @@ path/s is either such a string or a list of them.
(malformed "unexpected text found at the end of the file"))] (malformed "unexpected text found at the end of the file"))]
[prop-name [prop-name
;; register a given property value ;; register a given property value
(set-tree-props! tree (cons (cons prop-name x) (tree-props tree))) (set-Tree-props! tree (cons (cons prop-name x) (Tree-props tree)))
(loop tree #f)] (loop tree #f)]
[(string? x) [(string? x)
;; new path, find the node or create if none ;; new path, find the node or create if none
@ -286,38 +284,38 @@ path/s is either such a string or a list of them.
"beginning markup not found while writing new file")) "beginning markup not found while writing new file"))
(write-bytes (car m) new) (write-bytes (car m) new)
(let loop ([tree props-tree] [path ""]) (let loop ([tree props-tree] [path ""])
(when (pair? (tree-props tree)) (when (pair? (Tree-props tree))
(fprintf new "~s" path) (fprintf new "~s" path)
(for ([p (in-list (tree-props tree))]) (for ([p (in-list (Tree-props tree))])
(fprintf new " ~s ~s" (car p) (cdr p))) (fprintf new " ~s ~s" (car p) (cdr p)))
(newline new)) (newline new))
(for ([sub (in-list (tree-subs tree))]) (for ([sub (in-list (Tree-subs tree))])
(loop sub (let ([s (symbol->string (tree-name sub))]) (loop sub (let ([s (symbol->string (Tree-name sub))])
(if (equal? "" path) s (string-append path "/" s)))))) (if (equal? "" path) s (string-append path "/" s))))))
(fprintf new "\n~s |#\n" props-end-token))) (fprintf new "\n~s |#\n" props-end-token)))
(define (write-props) (define (write-props)
(define known-prop-names (map prop-name known-props)) (define known-prop-names (map Prop-name known-props))
;; normalize the tree, to minimize changes to the file and remove redundant ;; normalize the tree, to minimize changes to the file and remove redundant
;; entries that could be added manually ;; entries that could be added manually
(let loop ([tree props-tree] [up-props '()]) (let loop ([tree props-tree] [up-props '()])
(define normalized-props (define normalized-props
(for*/list ([p (in-list known-prop-names)] (for*/list ([p (in-list known-prop-names)]
[p (in-value (let ([cur (assq p (tree-props tree))]) [p (in-value (let ([cur (assq p (Tree-props tree))])
(and cur (not (member cur up-props)) cur)))] (and cur (not (member cur up-props)) cur)))]
#:when p) #:when p)
p)) p))
(set-tree-props! tree normalized-props) (set-Tree-props! tree normalized-props)
(when (pair? (tree-subs tree)) (when (pair? (Tree-subs tree))
(let ([up-props (append normalized-props up-props)] (let ([up-props (append normalized-props up-props)]
[subs (sort (tree-subs tree) string<? [subs (sort (Tree-subs tree) string<?
#:key (lambda (t) (symbol->string (tree-name t))) #:key (lambda (t) (symbol->string (Tree-name t)))
#:cache-keys? #t)]) #:cache-keys? #t)])
(set-tree-subs! tree (for*/list ([sub (in-list subs)] (set-Tree-subs! tree (for*/list ([sub (in-list subs)]
[sub (in-value (loop sub up-props))] [sub (in-value (loop sub up-props))]
#:when sub) #:when sub)
sub)))) sub))))
(and (or (pair? (tree-subs tree)) (pair? (tree-props tree))) tree)) (and (or (pair? (Tree-subs tree)) (pair? (Tree-props tree))) tree))
(let (;; temp file in the same directory => fail early if cannot write to it (let (;; temp file in the same directory => fail early if cannot write to it
;; and make a rename possible; copy from this file to preserve being ;; and make a rename possible; copy from this file to preserve being
;; executable ;; executable
@ -371,14 +369,15 @@ path/s is either such a string or a list of them.
(for ([v (in-list (verbs))]) (printf " ~a\n" (cadr v))) (for ([v (in-list (verbs))]) (printf " ~a\n" (cadr v)))
(printf "\nKnown properties:\n") (printf "\nKnown properties:\n")
(for ([p (in-list known-props)]) (for ([p (in-list known-props)])
(printf " ~s: ~a\n" (prop-name p) (prop-description p))) (printf " ~s: ~a\n" (Prop-name p) (Prop-description p)))
(para "See in-script comments for a racket interface")) (para "See in-script comments for a racket interface"))
(define (verbs) (define (verbs)
`([("help" "h" "-h" "--help") "help: show this help" ,help] `([("help" "h" "-h" "--help") "help: show this help" ,help]
[("get") "get <prop> <path/s>" ,get] [("get") "get <prop> <path/s>" ,get]
[("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]))
(define (find-root) (define (find-root)
(let loop ([p this-file] [n 3]) ; look only a few level up (let loop ([p this-file] [n 3]) ; look only a few level up
(let-values ([(base _1 _2) (split-path p)]) (let-values ([(base _1 _2) (split-path p)])
@ -434,22 +433,39 @@ path/s is either such a string or a list of them.
(let ([nonesuch (gensym 'none)] (let ([nonesuch (gensym 'none)]
[from (paths->list from null)] [from (paths->list from null)]
[to (paths->list to null)]) [to (paths->list to null)])
(for ([p (in-list (map prop-name known-props))]) (for ([p (in-list (map Prop-name known-props))])
(let ([v (get-prop from p nonesuch #:strict? #t)]) (let ([v (get-prop from p nonesuch #:strict? #t)])
(unless (eq? v nonesuch) (unless (eq? v nonesuch)
(set-prop! to p v) (set-prop! to p v)
(del-prop! from p))))) (del-prop! from p)))))
(write-props)) (write-props))
(define (verify)
(define root (find-root))
(printf "Root: ~a\n" root)
(parameterize ([current-directory root])
(let loop ([tree props-tree] [path '(" ")])
(for ([sub (in-list (Tree-subs tree))])
(define name (symbol->string (Tree-name sub)))
(define (print-path more)
(for ([x (in-list (reverse path))]) (printf "~a/" x))
(printf "~a: ~a\n" name more))
(cond [(equal? "" name)
(print-path "empty name")]
[(directory-exists? name)
(parameterize ([current-directory name])
(loop sub (cons name path)))]
[(not (file-exists? name))
(print-path "Missing file/directory")])))))
(set! running-as-script? #t) (set! running-as-script? #t)
;; (perhaps add some `--force' flag to (set! check-existing-paths? #f)) ;; (perhaps add some `--force' flag to (set! check-existing-paths? #f))
(let* ([verb (if (pair? args) (car args) (usage "missing subcommand"))] (define verb (if (pair? args) (car args) (usage "missing subcommand")))
[args (cdr args)] (define verb-args (cdr args))
[proc (or (for/or ([v (in-list (verbs))] #:when (member verb (car v))) (define proc
(caddr v)) (or (for/or ([v (in-list (verbs))] #:when (member verb (car v))) (caddr v))
(usage (format "unknown subcommand ~s" verb)))]) (usage (format "unknown subcommand ~s" verb))))
(if (procedure-arity-includes? proc (length args)) (if (procedure-arity-includes? proc (length verb-args))
(apply proc args) (apply proc verb-args)
(usage (format "bad number of arguments for ~s" verb))))) (usage (format "bad number of arguments for ~s" verb))))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
@ -457,7 +473,7 @@ path/s is either such a string or a list of them.
known-props known-props
(list (list
;; -------------------- ;; --------------------
(make-prop (Prop
'responsible 'responsible
"responsible person/people (comma separated names)" "responsible person/people (comma separated names)"
(lambda (str) (lambda (str)
@ -472,10 +488,10 @@ path/s is either such a string or a list of them.
(lambda (syms) (lambda (syms)
(apply string-append (add-between (map symbol->string syms) ",")))) (apply string-append (add-between (map symbol->string syms) ","))))
;; -------------------- ;; --------------------
(make-prop (Prop
'drdr:command-line 'drdr:command-line
(string-append (string-append
"command-line string (space-separated, missing => default execution," "command-line string (space-separated,\n missing => default execution,"
" empty => no execution, \"~s\" => the file)") " empty => no execution, \"~s\" => the file)")
(lambda (str) (lambda (str)
(define (bad) (error "expecting an empty string, or one with `~s'")) (define (bad) (error "expecting an empty string, or one with `~s'"))
@ -513,7 +529,7 @@ path/s is either such a string or a list of them.
[else (bad)])) [else (bad)]))
cmd))]))) cmd))])))
;; -------------------- ;; --------------------
(make-prop (Prop
'drdr:timeout 'drdr:timeout
"timeout in seconds" "timeout in seconds"
(lambda (str) (lambda (str)
@ -522,7 +538,7 @@ path/s is either such a string or a list of them.
(error "expecting an integer"))) (error "expecting an integer")))
number->string) number->string)
;; -------------------- ;; --------------------
(make-prop (Prop
'drdr:random 'drdr:random
"is file output random?" "is file output random?"
(lambda (str) (lambda (str)