diff --git a/collects/unstable/find.ss b/collects/unstable/find.ss new file mode 100644 index 0000000000..51d0a93f70 --- /dev/null +++ b/collects/unstable/find.ss @@ -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))) diff --git a/collects/unstable/scribblings/find.scrbl b/collects/unstable/scribblings/find.scrbl new file mode 100644 index 0000000000..b82de303c1 --- /dev/null +++ b/collects/unstable/scribblings/find.scrbl @@ -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)) +] +} diff --git a/collects/unstable/scribblings/struct.scrbl b/collects/unstable/scribblings/struct.scrbl index 0e33658ca0..31e5bd8fde 100644 --- a/collects/unstable/scribblings/struct.scrbl +++ b/collects/unstable/scribblings/struct.scrbl @@ -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) ] } diff --git a/collects/unstable/scribblings/syntax.scrbl b/collects/unstable/scribblings/syntax.scrbl index 150a9f3564..226f74f756 100644 --- a/collects/unstable/scribblings/syntax.scrbl +++ b/collects/unstable/scribblings/syntax.scrbl @@ -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 () diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 0213da2679..13e2d892b0 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -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"] @;{--------} diff --git a/collects/unstable/struct.ss b/collects/unstable/struct.ss index 9d07b3f551..2ebce5989c 100644 --- a/collects/unstable/struct.ss +++ b/collects/unstable/struct.ss @@ -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. diff --git a/collects/unstable/syntax.ss b/collects/unstable/syntax.ss index b46794d3b3..f0ff099b23 100644 --- a/collects/unstable/syntax.ss +++ b/collects/unstable/syntax.ss @@ -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))