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

Added generator support for named ellipses.

Browse Source 
svn: r11126
This commit is contained in:
Casey Klein 2008-08-07 12:53:59 +00:00
parent 6cfb96abaa
commit 108cf06b46
2 changed files with 47 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/redex/private/rg-test.ss
View File

@ -458,6 +458,16 @@
(e (hide-hole (in-hole ((hide-hole hole) hole) 1)))) (e (hide-hole (in-hole ((hide-hole hole) hole) 1))))
(test (generate lang e 5 0) (term (hole 1)))) (test (generate lang e 5 0) (term (hole 1))))
;; named ellipses
(let ()
(define-language empty)
(test
(generate empty (number ..._1 variable ..._2 number ..._1) 5 0
(decisions #:seq (list (λ () 2) (λ () 3))
#:var (list (λ _ 'x) (λ _ 'y) (λ _ 'z))
#:num (build-list 4 (λ (x) (λ (_) x)))))
'(0 1 x y z 2 3)))
(define (output-error-port thunk) (define (output-error-port thunk)
(let ([port (open-output-string)]) (let ([port (open-output-string)])
(parameterize ([current-error-port port]) (parameterize ([current-error-port port])

54
collects/redex/private/rg.ss
View File

@ -156,12 +156,12 @@ To do a better job of not generating programs with free variables,
(define (generate-pat pat bound-vars var-info size in-hole) (define (generate-pat pat bound-vars var-info size in-hole)
(let* ([found-vars-table (map (λ (binds) (make-found-vars (binds-binds binds) (binds-source binds) '() #f)) (let* ([found-vars-table (map (λ (binds) (make-found-vars (binds-binds binds) (binds-source binds) '() #f))
var-info)] var-info)]
[bindings (make-immutable-hasheq null)] [matches (make-immutable-hasheq null)]
[mismatches (make-immutable-hasheq null)]) [mismatches (make-immutable-hasheq null)])
(let loop ([pat pat] [in-hole in-hole]) (let loop ([pat pat] [in-hole in-hole])
(define (generate/retry #:gen [gen (λ (p) (loop p in-hole))] success? . subpatterns) (define (generate/retry #:gen [gen (λ (p) (loop p in-hole))] success? . subpatterns)
(let ([old-fvt found-vars-table] (let ([old-fvt found-vars-table]
[old-bindings bindings] [old-matches matches]
[old-mismatches mismatches]) [old-mismatches mismatches])
(let retry ([remaining generation-retries]) (let retry ([remaining generation-retries])
(if (zero? remaining) (if (zero? remaining)
@ -173,7 +173,7 @@ To do a better job of not generating programs with free variables,
generated) generated)
(begin (begin
(set! found-vars-table old-fvt) (set! found-vars-table old-fvt)
(set! bindings old-bindings) (set! matches old-matches)
(set! mismatches old-mismatches) (set! mismatches old-mismatches)
(retry (sub1 remaining))))))))) (retry (sub1 remaining)))))))))
(match pat (match pat
@ -190,13 +190,13 @@ To do a better job of not generating programs with free variables,
[`(side-condition ,pattern ,(? procedure? condition)) [`(side-condition ,pattern ,(? procedure? condition))
(define (condition-bindings bindings) (define (condition-bindings bindings)
(make-bindings (hash-map bindings (λ (name exp) (make-bind name exp))))) (make-bindings (hash-map bindings (λ (name exp) (make-bind name exp)))))
(generate/retry (λ _ (condition (condition-bindings bindings))) pattern)] (generate/retry (λ _ (condition (condition-bindings matches))) pattern)]
[`(name ,(? symbol? id) ,p) [`(name ,(? symbol? id) ,p)
(define (generate/record) (define (generate/record)
(let ([term (loop p in-hole)]) (let ([term (loop p in-hole)])
(set! bindings (hash-set bindings id term)) (set! matches (hash-set matches id term))
term)) term))
(hash-ref bindings id generate/record)] (hash-ref matches id generate/record)]
[`hole (if in-hole (in-hole) the-hole)] [`hole (if in-hole (in-hole) the-hole)]
[`(in-hole ,context ,contractum) [`(in-hole ,context ,contractum)
(loop context (λ () (loop contractum in-hole)))] (loop context (λ () (loop contractum in-hole)))]
@ -216,10 +216,10 @@ To do a better job of not generating programs with free variables,
(match (symbol->string pat) (match (symbol->string pat)
[(regexp #rx"^([^_]*)_[^_]*$" (list _ undecorated)) [(regexp #rx"^([^_]*)_[^_]*$" (list _ undecorated))
(hash-ref (hash-ref
bindings pat matches pat
(λ () (λ ()
(let ([term ((generate-nt/underscored pat) (string->symbol undecorated))]) (let ([term ((generate-nt/underscored pat) (string->symbol undecorated))])
(set! bindings (hash-set bindings pat term)) (set! matches (hash-set matches pat term))
term)))] term)))]
[(regexp #rx"([^_]*)_!_[^_]*$" (list _ undecorated)) [(regexp #rx"([^_]*)_!_[^_]*$" (list _ undecorated))
(let* ([prior (hash-ref mismatches pat null)] (let* ([prior (hash-ref mismatches pat null)]
@ -232,13 +232,20 @@ To do a better job of not generating programs with free variables,
[else ((generate-nt/underscored pat) pat)])] [else ((generate-nt/underscored pat) pat)])]
[(or (? symbol?) (? number?) (? string?) (? boolean?)) pat] [(or (? symbol?) (? number?) (? string?) (? boolean?)) pat]
[(? null? pat) '()] [(? null? pat) '()]
[(? pair? pat) [(list-rest seq '... rest)
(if (or (null? (cdr pat)) (loop (expand-sequence seq ((next-sequence-decision)) rest) in-hole)]
(not (eq? '... (cadr pat)))) [(list-rest seq (? named-ellipsis? name) rest)
(cons (loop (car pat) in-hole) (let* ([match-len (hash-ref matches name #f)]
(loop (cdr pat) in-hole)) [seq-len
(append (build-list ((next-sequence-decision)) (λ (i) (loop (car pat) in-hole))) (if match-len
(loop (cddr pat) in-hole)))] match-len
(let ([len ((next-sequence-decision))])
(begin
(set! matches (hash-set matches name len))
len)))])
(loop (expand-sequence seq seq-len rest) in-hole))]
[(list-rest pat rest)
(cons (loop pat in-hole) (loop rest in-hole))]
[else [else
(error 'generate "unknown pattern ~s\n" pat)])))) (error 'generate "unknown pattern ~s\n" pat)]))))
@ -274,6 +281,12 @@ To do a better job of not generating programs with free variables,
[else found-vars])) [else found-vars]))
found-vars-table)) found-vars-table))
(define (expand-sequence seq-pat seq-len rest-pat)
(let loop ([remaining seq-len] [acc-pat rest-pat])
(if (zero? remaining)
acc-pat
(loop (sub1 remaining) (cons seq-pat acc-pat)))))
(generate-pat nt '() '() size #f)) (generate-pat nt '() '() size #f))
;; find-base-cases : compiled-language -> hash-table ;; find-base-cases : compiled-language -> hash-table
@ -354,8 +367,15 @@ To do a better job of not generating programs with free variables,
;; underscored-built-in? : symbol -> boolean ;; underscored-built-in? : symbol -> boolean
(define (underscored-built-in? sym) (define (underscored-built-in? sym)
(not (false? (and (memq #\_ (string->list (symbol->string sym))) (and (memq #\_ (string->list (symbol->string sym)))
(memq (symbol->nt sym) underscore-allowed))))) (memq (symbol->nt sym) underscore-allowed)
#t))
;; named-ellipsis? : any -> boolean
(define (named-ellipsis? x)
(and (symbol? x)
(memq #\_ (string->list (symbol->string x)))
(eq? (symbol->nt x) '...)))
(define-syntax check (define-syntax check
(syntax-rules () (syntax-rules ()