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

unstable/syntax: changed format-id to autoconvert identifiers

Browse Source 
unstable/struct: changed struct->list, more options
added unstable/find

svn: r16774
This commit is contained in:
Ryan Culpepper 2009-11-15 07:00:44 +00:00
parent d66d5f7759
commit 4517f37942
7 changed files with 238 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
collects/unstable/find.ss Normal file
View File

@ -0,0 +1,69 @@
#lang scheme/base
(require scheme/contract
unstable/struct)
(provide/contract
[find
(->* ((-> any/c any/c)
any/c)
(#:stop-on-found? any/c
#:stop (or/c #f (-> any/c any/c))
#:get-children (or/c #f (-> any/c (or/c #f list?))))
list?)]
[find-first
(->* ((-> any/c any/c)
any/c)
(#:stop (or/c #f (-> any/c any/c))
#:get-children (or/c #f (-> any/c (or/c #f list?)))
#:default any/c)
any/c)])
(define (find pred x
#:stop-on-found? [stop-on-found? #f]
#:stop [stop #f]
#:get-children [get-children #f])
(define (loop x acc)
(cond [(pred x)
(let ([acc (cons x acc)])
(if stop-on-found?
acc
(loop/nf x acc)))]
[else
(loop/nf x acc)]))
;; loop/nt: x is "not found"; look in its children
(define (loop/nf x acc)
(cond [(and stop (stop x))
acc]
[(and get-children (get-children x))
=> (lambda (children) (loop* children acc))]
[(pair? x)
(let ([acc (loop (car x) acc)])
(loop (cdr x) acc))]
[(vector? x)
(for/fold ([acc acc]) ([elem (in-vector x)])
(loop elem acc))]
[(box? x)
(loop (unbox x) acc)]
[(struct->list x #:on-opaque 'skip)
=> (lambda (elems)
(loop* elems acc))]
;; unreachable, since
;; (struct->list X #:on-opaque 'skip) always returns a list
[else acc]))
(define (loop* xs acc)
(for/fold ([acc acc]) ([elem (in-list xs)])
(loop elem acc)))
(reverse (loop x null)))
(define (find-first pred x
#:stop [stop #f]
#:get-children [get-children #f]
#:default [default #f])
(let/ec return
(define (pred* x)
(and (pred x) (return x)))
(find pred* x #:stop stop #:get-children get-children)
(if (procedure? default)
(default)
default)))

74
collects/unstable/scribblings/find.scrbl Normal file
View File

@ -0,0 +1,74 @@
#lang scribble/manual
@(require scribble/eval
(for-label unstable/find
scheme/contract
scheme/shared
scheme/base))
@title[#:tag "find"]{Find}
@(define the-eval (make-base-eval))
@(the-eval '(require unstable/find))
@(the-eval '(require scheme/shared))
@defmodule[unstable/find]
@defproc[(find [pred (-> any/c any/c)]
[x any/c]
[#:stop-on-found? stop-on-found? any/c #f]
[#:stop stop (or/c #f (-> any/c any/c)) #f]
[#:get-children get-children (or/c #f (-> any/c (or/c #f list?))) #f])
list?]{
Returns a list of all values satisfying @scheme[pred] contained in
@scheme[x] (possibly including @scheme[x] itself).
If @scheme[stop-on-found?] is true, the children of values satisfying
@scheme[pred] are not examined. If @scheme[stop] is a procedure, then
the children of values for which @scheme[stop] returns true are not
examined (but the values themselves are; @scheme[stop] is applied
after @scheme[pred]). Only the current branch of the search is
stopped, not the whole search.
The search recurs through pairs, vectors, boxes, and the accessible
fields of structures. If @scheme[get-children] is a procedure, it can
override the default notion of a value's children by returning a list
(if it returns false, the default notion of children is used).
No cycle detection is done, so @scheme[find] on a cyclic graph may
diverge. To do cycle checking yourself, use @scheme[stop] and a
mutable table.
@examples[#:eval the-eval
(find symbol? '((all work) and (no play)))
(find list? '#((all work) and (no play)) #:stop-on-found? #t)
(find negative? 100
#:stop-on-found? #t
#:get-children (lambda (n) (list (- n 12))))
(find symbol? (shared ([x (cons 'a x)]) x)
#:stop (let ([table (make-hasheq)])
(lambda (x)
(begin0 (hash-ref table x #f)
(hash-set! table x #t)))))
]
}
@defproc[(find-first [pred (-> any/c any/c)]
[x any/c]
[#:stop stop (or/c #f (-> any/c any/c)) #f]
[#:get-children get-children (or/c #f (-> any/c (or/c #f list?))) #f]
[#:default default any/c (lambda () (error ....))])
any/c]{
Like @scheme[find-first], but only returns the first match. If no
matches are found, @scheme[default] is applied as a thunk if it is a
procedure or returned otherwise.
@examples[#:eval the-eval
(find-first symbol? '((all work) and (no play)))
(find-first list? '#((all work) and (no play)))
(find-first negative? 100
#:get-children (lambda (n) (list (- n 12))))
(find-first symbol? (shared ([x (cons 'a x)]) x))
]
}

22
collects/unstable/scribblings/struct.scrbl
View File

@ -27,25 +27,29 @@ is raised at compile time.
}
@defproc[(struct->list [v any/c]
[#:false-on-opaque? false-on-opaque? boolean? #f])
[#:on-opaque on-opaque (or/c 'error 'return-false 'skip) 'error])
(or/c list? #f)]{
Returns a list containing the struct instance @scheme[v]'s
fields. Unlike @scheme[struct->vector], the struct name itself is not
included.
The struct instance @scheme[v] must be fully accessible using the
current inspector. If any fields are inaccessible, either an error is
raised or @scheme[#f] is returned, depending on the value of
@scheme[false-on-opaque?]. The default is to raise an error.
If any fields of @scheme[v] are inaccessible via the current inspector
the behavior of @scheme[struct->list] is determined by
@scheme[on-opaque]. If @scheme[on-opaque] is @scheme['error] (the
default), an error is raised. If it is @scheme['return-false],
@scheme[struct->list] returns @scheme[#f]. If it is @scheme['skip],
the inaccessible fields are omitted from the list.
@examples[#:eval the-eval
(define-struct open (u v) #:transparent)
(struct->list (make-open 'a 'b))
(struct->list #s(pre 1 2 3))
(define-struct secret (x y))
(struct->list (make-secret 17 22))
(struct->list (make-secret 17 22) #:false-on-opaque? #t)
(struct->list 'not-a-struct #:false-on-opaque? #t)
(define-struct (secret open) (x y))
(struct->list (make-secret 0 1 17 22))
(struct->list (make-secret 0 1 17 22) #:on-opaque 'return-false)
(struct->list (make-secret 0 1 17 22) #:on-opaque 'skip)
(struct->list 'not-a-struct #:on-opaque 'return-false)
(struct->list 'not-a-struct #:on-opaque 'skip)
]
}

15
collects/unstable/scribblings/syntax.scrbl
View File

@ -182,13 +182,16 @@ or similar, has no effect.
@;{----}
@defproc[(format-symbol [fmt string?] [v any/c] ...)
@defproc[(format-symbol [fmt string?]
[v (or/c string? symbol? identifier? keyword? number?)] ...)
symbol?]{
Like @scheme[format], but produces a symbol.
Like @scheme[format], but produces a symbol. The format string must
use only @litchar{~a} placeholders. Identifiers in the argument list
are automatically converted to symbols.
@examples[#:eval the-eval
(format-symbol "make-~s" 'triple)
(format-symbol "make-~a" 'triple)
]
}
@ -196,7 +199,8 @@ Like @scheme[format], but produces a symbol.
[#:source src (or/c syntax? #f) #f]
[#:props props (or/c syntax? #f) #f]
[#:cert cert (or/c syntax? #f) #f]
[fmt string?] [v any/c] ...)
[fmt string?]
[v (or/c string? symbol? identifier? keyword? number?)] ...)
identifier?]{
Like @scheme[format-symbol], but converts the symbol into an
@ -205,6 +209,9 @@ for the source location, @scheme[props] for the properties, and
@scheme[cert] for the inactive certificates. (See
@scheme[datum->syntax].)
The format string must use only @litchar{~a} placeholders. Identifiers
in the argument list are automatically converted to symbols.
@examples[#:eval the-eval
(define-syntax (make-pred stx)
(syntax-case stx ()

1
collects/unstable/scribblings/unstable.scrbl
View File

@ -82,6 +82,7 @@ Keep documentation and tests up to date.
@include-section["syntax.scrbl"]
@include-section["poly-c.scrbl"]
@include-section["mutated-vars.scrbl"]
@include-section["find.scrbl"]
@;{--------}

36
collects/unstable/struct.ss
View File

@ -48,18 +48,36 @@
(define dummy-value (box 'dummy))
;; struct->list : struct? #:false-on-opaque? bool -> (listof any/c)
(define (struct->list s #:false-on-opaque? [false-on-opaque? #f])
;; struct->list : struct?
;; #:on-opaque? (or/c 'error 'return-false 'skip)
;; -> (listof any/c)
(define (struct->list s
#:on-opaque [on-opaque 'error])
(define error-on-opaque? (eq? on-opaque 'error))
(let ([vec (struct->vector s dummy-value)])
(and (for/and ([elem (in-vector vec)])
(cond [(eq? elem dummy-value)
(unless false-on-opaque?
(raise-type-error 'struct->list "non-opaque struct" s))
#f]
[else #t]))
(cdr (vector->list vec)))))
;; go through vector backwards, don't traverse 0 (struct name)
(let loop ([index (sub1 (vector-length vec))]
[elems null]
[any-opaque? #f])
(cond [(positive? index)
(let ([elem (vector-ref vec index)])
(cond [(eq? elem dummy-value)
(when error-on-opaque?
(raise-type-error 'struct->list "non-opaque struct" s))
(loop (sub1 index) elems #t)]
[else (loop (sub1 index) (cons elem elems) any-opaque?)]))]
[else
(cond [(and any-opaque? (eq? on-opaque 'return-false))
#f]
[else elems])]))))
;; Eli: Why is there that `false-on-opaque?' business instead of having
;; an interface similar to `struct->vector'? I'd prefer an optional
;; on-opaque value, and have it throw an error if it's opaque and no
;; value is given. Also, `gensym' seems much better to me than a box
;; for a unique value.
;; ryanc: I've never seen any code that wanted the on-opaque filler
;; value except printers, whereas lots of code assumes the struct is
;; fully transparent and wants all of the fields. #:false-on-opaque?
;; also lets this act as a predicate-plus (like member, assoc, etc)
;; for fully-transparent structs.

47
collects/unstable/syntax.ss
View File

@ -100,27 +100,66 @@
;; Symbol Formatting
(define (format-symbol fmt . args)
(string->symbol (apply format fmt args)))
(define (convert x) (->atom x 'format-symbol))
(check-restricted-format-string 'format-symbol fmt)
(let ([args (map convert args)])
(string->symbol (apply format fmt args))))
(define (format-id lctx
#:source [src #f]
#:props [props #f]
#:cert [cert #f]
fmt . args)
(let* ([str (apply format fmt args)]
(define (convert x) (->atom x 'format-id))
(check-restricted-format-string 'format-id fmt)
(let* ([args (map convert args)]
[str (apply format fmt args)]
[sym (string->symbol str)])
(datum->syntax lctx sym src props cert)))
;; Eli: This looks very *useful*, but I'd like to see it more convenient to
;; "preserve everything". Maybe add a keyword argument that when #t makes
;; all the others use values lctx, and when syntax makes the others use that
;; syntax? Also, I'd prefer it if each of these keywords would also accept a
;; syntax instead of a value, to copy the value from.
;; syntax?
;; Finally, if you get to add this, then another useful utility in the same
;; spirit is one that concatenates symbols and/or strings and/or identifiers
;; into a new identifier. I considered something like that, which expects a
;; single syntax among its inputs, and will use it for the context etc, or
;; throw an error if there's more or less than 1.
#|
(define (id-append #:source [src #f]
#:props [props #f]
#:cert [cert #f]
. args)
(define stxs (filter syntax? args))
(define lctx
(cond [(and (pair? stxs) (null? (cdr stxs)))
(car stxs)]
[(error 'id-append "expected exactly one identifier in arguments: ~e" args)]))
(define (convert x) (->atom x 'id-append))
(define sym (string->symbol (apply string-append (map convert args))))
(datum->syntax lctx sym src props cert))
|#
(define (restricted-format-string? fmt)
(regexp-match? #rx"^(?:[^~]|~[aAn~%])*$" fmt))
(define (check-restricted-format-string who fmt)
(unless (restricted-format-string? fmt)
(raise-type-error who
"format string using only ~a placeholders"
fmt)))
(define (->atom x err)
(cond [(string? x) x]
[(symbol? x) x]
[(identifier? x) (syntax-e x)]
[(keyword? x) (keyword->string x)]
[(number? x) x]
[else (raise-type-error err
"string, symbol, identifier, keyword, or number"
x)]))
;; Error reporting
(define current-syntax-context (make-parameter #f))