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

stepper refactoring and cleanup

Browse Source
This commit is contained in:
John Clements 2010-12-08 15:14:10 -08:00
parent 463ab0d309
commit ff973b628b
8 changed files with 120 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/stepper/private/annotate.rkt
View File

@ -1,16 +1,13 @@
#lang racket/base #lang racket
(require (prefix-in kernel: syntax/kerncase) (require (prefix-in kernel: syntax/kerncase)
mzlib/contract racket/contract
mzlib/list
mzlib/etc
scheme/match
"marks.ss" "marks.ss"
"shared.ss" "shared.ss"
"my-macros.ss" "my-macros.ss"
#;"xml-box.ss" #;"xml-box.ss"
(prefix-in beginner-defined: "beginner-defined.ss") (prefix-in beginner-defined: "beginner-defined.ss")
(for-syntax scheme/base)) (for-syntax racket/base))
(define-syntax (where stx) (define-syntax (where stx)
(syntax-case stx () (syntax-case stx ()
@ -28,10 +25,9 @@
(((or/c continuation-mark-set? false/c) (((or/c continuation-mark-set? false/c)
break-kind?) break-kind?)
(list?) (list?)
. opt->* . . ->* .
(any/c)) ; procedure for runtime break any/c) ; procedure for runtime break
boolean? ; show-lambdas-as-lambdas? boolean? ; show-lambdas-as-lambdas?
(union any/c (symbols 'testing)); language-level
. -> . . -> .
syntax?)] ; results syntax?)] ; results
@ -278,7 +274,7 @@
(define (annotate main-exp break show-lambdas-as-lambdas? language-level) (define (annotate main-exp break show-lambdas-as-lambdas?)
#;(define _ (>>> main-exp #;(syntax->datum main-exp))) #;(define _ (>>> main-exp #;(syntax->datum main-exp)))

104
collects/stepper/private/display-break-stuff.rkt
View File

@ -1,32 +1,32 @@
(module display-break-stuff mzscheme #lang racket
(require mred mzlib/class "marks.ss") (require mred mzlib/class "marks.ss")
(provide display-break-stuff) (provide display-break-stuff)
(define f (define f
(new frame% (new frame%
[label (format "Breakpoints Inspector")] [label (format "Breakpoints Inspector")]
[width 400] [height 500])) [width 400] [height 500]))
(define sel (new choice% [label "Breakpoint#"] [choices '()] [parent f] (define sel (new choice% [label "Breakpoint#"] [choices '()] [parent f]
[callback (lambda (c e) (show-sel))] [stretchable-width #t])) [callback (lambda (c e) (show-sel))] [stretchable-width #t]))
(define ec (new editor-canvas% [parent f])) (define ec (new editor-canvas% [parent f]))
(define t (new text%)) (define t (new text%))
(send ec set-editor t) (send ec set-editor t)
(define selections '()) (define selections '())
(define (add-sel num mset bkind retvals) (define (add-sel num mset bkind retvals)
(set! selections (cons (list num mset bkind retvals) selections)) (set! selections (cons (list num mset bkind retvals) selections))
(let ([num (number->string num)]) (let ([num (number->string num)])
(send sel append num) (send sel append num)
(send sel set-string-selection num) (send sel set-string-selection num)
(show-sel))) (show-sel)))
(define (show-sel) (define (show-sel)
(let* ([num (string->number (send sel get-string-selection))] (let* ([num (string->number (send sel get-string-selection))]
[bpt (assq num selections)]) [bpt (assq num selections)])
(send* t (lock #f) (erase)) (send* t (lock #f) (erase))
(if (not bpt) (if (not bpt)
(send* t (insert (format "Breakpoint #~a not found!\n" num))) (send* t (insert (format "Breakpoint #~a not found!\n" num)))
(let-values ([(mset bkind retvals) (apply values (cdr bpt))]) (let-values ([(mset bkind retvals) (apply values (cdr bpt))])
(send* t (send* t
@ -34,34 +34,34 @@
(insert (format " break-kind: ~v\n" bkind)) (insert (format " break-kind: ~v\n" bkind))
(insert "marks:\n")) (insert "marks:\n"))
(if mset (if mset
(for-each (for-each
(lambda (mark) (lambda (mark)
(let* ([em (expose-mark mark)] (let* ([em (expose-mark mark)]
[source (car em)] [source (car em)]
[label (cadr em)] [label (cadr em)]
[binding-set (caddr em)]) [binding-set (caddr em)])
(send* t (send* t
(insert (format " label: ~v\n" label)) (insert (format " label: ~v\n" label))
;; we really want one of those nice collapsible ;; we really want one of those nice collapsible
;; syntax-viewer thingies here: ;; syntax-viewer thingies here:
(insert (format " source : ~v\n" (insert (format " source : ~v\n"
(syntax-object->datum source))) (syntax->datum source)))
;; here too, though this isn't a syntax object. ;; here too, though this isn't a syntax object.
(insert (format " bindings: ~v\n" binding-set))))) (insert (format " bindings: ~v\n" binding-set)))))
(extract-mark-list mset)) (extract-mark-list mset))
(send t insert " nothing!\n")) (send t insert " nothing!\n"))
(send t insert "returned-value-list:\n") (send t insert "returned-value-list:\n")
(if retvals (if retvals
(for-each (lambda (v) (send t insert (format " ~v\n" v))) (for-each (lambda (v) (send t insert (format " ~v\n" v)))
retvals) retvals)
(send t insert " nothing!\n")))) (send t insert " nothing!\n"))))
(send* t (lock #t)))) (send* t (lock #t))))
;; display-break-stuff : show the information associated with a breakpoint. ;; display-break-stuff : show the information associated with a breakpoint.
;; Useful for people building steppers for new languages ;; Useful for people building steppers for new languages
(define (display-break-stuff break-number mark-set break-kind (define (display-break-stuff break-number mark-set break-kind
returned-value-list) returned-value-list)
(add-sel break-number mark-set break-kind returned-value-list) (add-sel break-number mark-set break-kind returned-value-list)
(send f show #t)) (send f show #t))
)

38
collects/stepper/private/model-settings.rkt
View File

@ -23,7 +23,8 @@
render-to-sexp render-to-sexp
lifting? lifting?
show-and/or-clauses-consumed? show-and/or-clauses-consumed?
all-bindings-mutable?)) all-bindings-mutable?
show-lambdas-as-lambdas?))
(provide/contract [check-global-defined (-> symbol? boolean?)] (provide/contract [check-global-defined (-> symbol? boolean?)]
[global-lookup (-> any/c any)] [global-lookup (-> any/c any)]
@ -35,7 +36,8 @@
[render-to-sexp (any/c . -> . any)] [render-to-sexp (any/c . -> . any)]
[lifting? boolean?] [lifting? boolean?]
[show-and/or-clauses-consumed? boolean?] [show-and/or-clauses-consumed? boolean?]
[all-bindings-mutable? boolean?])] [all-bindings-mutable? boolean?]
[show-lambdas-as-lambdas? boolean?])]
@ -43,6 +45,7 @@
(any/c . -> . any) ; render-to-sexp (any/c . -> . any) ; render-to-sexp
boolean? ; lifting? boolean? ; lifting?
boolean? ; show-and/or-clauses-consumed? boolean? ; show-and/or-clauses-consumed?
boolean? ; show-lambdas-as-lambdas?
. -> . . -> .
render-settings?)] render-settings?)]
@ -53,7 +56,8 @@
[fake-intermediate-render-settings render-settings?] [fake-intermediate-render-settings render-settings?]
[fake-intermediate/lambda-render-settings render-settings?] [fake-intermediate/lambda-render-settings render-settings?]
[fake-advanced-render-settings render-settings?] [fake-advanced-render-settings render-settings?]
[fake-mz-render-settings render-settings?]) [fake-mz-render-settings render-settings?]
[fake-lazy-render-settings render-settings?])
(define (make-fake-render-to-sexp true/false constructor-style abbreviate) (define (make-fake-render-to-sexp true/false constructor-style abbreviate)
(lambda (val) (lambda (val)
@ -67,20 +71,20 @@
; FIXME : #f totally unacceptable as 'render-to-string' ; FIXME : #f totally unacceptable as 'render-to-string'
(define fake-beginner-render-settings (define fake-beginner-render-settings
(make-render-settings #t #t #f (make-fake-render-to-sexp #t #t #f) #t #t #f)) (make-render-settings #t #t #f (make-fake-render-to-sexp #t #t #f) #t #t #f #f))
(define fake-beginner-wla-render-settings (define fake-beginner-wla-render-settings
(make-render-settings #t #t #t (make-fake-render-to-sexp #t #t #t) #t #t #f)) (make-render-settings #t #t #t (make-fake-render-to-sexp #t #t #t) #t #t #f #f))
(define fake-intermediate-render-settings (define fake-intermediate-render-settings
fake-beginner-wla-render-settings) fake-beginner-wla-render-settings)
(define fake-intermediate/lambda-render-settings (define fake-intermediate/lambda-render-settings
fake-beginner-wla-render-settings) (make-render-settings #t #t #t (make-fake-render-to-sexp #t #t #t) #t #t #f #t))
;; this is a guess: ;; this is a guess:
(define fake-advanced-render-settings (define fake-advanced-render-settings
fake-beginner-wla-render-settings) (make-render-settings #t #t #t (make-fake-render-to-sexp #t #t #t) #t #t #f #t))
(define fake-mz-render-settings (define fake-mz-render-settings
(make-render-settings (booleans-as-true/false) (make-render-settings (booleans-as-true/false)
@ -89,13 +93,26 @@
print-convert print-convert
#f #f
#t #t
#f)) #f
#t))
(define fake-lazy-render-settings
(make-render-settings (booleans-as-true/false)
(constructor-style-printing)
(abbreviate-cons-as-list)
print-convert
#f
#t
#f
#f))
(define-struct test-struct () (make-inspector)) (define-struct test-struct () (make-inspector))
;; get-render-settings : infer aspects of the current language's print conversion by explicitly testing ;; get-render-settings : infer aspects of the current language's print conversion by explicitly testing
;; assorted test expressions ;; assorted test expressions
(define (get-render-settings render-to-string render-to-sexp lifting? show-and/or-clauses-consumed?) (define (get-render-settings render-to-string render-to-sexp lifting?
show-and/or-clauses-consumed?
show-lambdas-as-lambdas?)
(let* ([true-false-printed? (string=? (render-to-string #t) "true")] (let* ([true-false-printed? (string=? (render-to-string #t) "true")]
[constructor-style-printing? (string=? (render-to-string (make-test-struct)) "(make-test-struct)")] [constructor-style-printing? (string=? (render-to-string (make-test-struct)) "(make-test-struct)")]
[rendered-list (render-to-string '(3))] [rendered-list (render-to-string '(3))]
@ -111,7 +128,8 @@
render-to-sexp render-to-sexp
lifting? lifting?
show-and/or-clauses-consumed? show-and/or-clauses-consumed?
#f))) #f
show-lambdas-as-lambdas?)))
(define (check-global-defined identifier) (define (check-global-defined identifier)
(with-handlers (with-handlers

23
collects/stepper/private/model.rkt
View File

@ -63,13 +63,13 @@
void?)) void?))
(provide/contract (provide/contract
[go (program-expander-contract ; program-expander [go (->*
(program-expander-contract ; program-expander
(step-result? . -> . void?) ; receive-result (step-result? . -> . void?) ; receive-result
(or/c render-settings? false/c) ; render-settings (or/c render-settings? false/c)) ; render-settings
boolean? ; track-inferred-names? (#:raw-step-receiver
(or/c object? (symbols 'testing)) ;; FIXME: can do better: subclass of language% ; the language level (-> continuation-mark-set? symbol? void?)
boolean? ; disable-error-handling (to allow debugging) #:disable-error-handling? boolean?)
. -> .
void?)]) void?)])
@ -81,7 +81,8 @@
; go starts a stepper instance ; go starts a stepper instance
; see provide stmt for contract ; see provide stmt for contract
(define (go program-expander receive-result render-settings (define (go program-expander receive-result render-settings
show-lambdas-as-lambdas? language-level disable-error-handling) #:disable-error-handling? [disable-error-handling? #f]
#:raw-step-receiver [raw-step-receiver #f])
;; finished-exps: ;; finished-exps:
;; (listof (list/c syntax-object? (or/c number? false?)( -> any))) ;; (listof (list/c syntax-object? (or/c number? false?)( -> any)))
@ -320,8 +321,10 @@
(lambda (stx dont-care) (list stx)))) (lambda (stx dont-care) (list stx))))
(define (step-through-expression expanded expand-next-expression) (define (step-through-expression expanded expand-next-expression)
(let* ([annotated (a:annotate expanded break show-lambdas-as-lambdas? (define show-lambdas-as-lambdas?
language-level)]) (render-settings-show-lambdas-as-lambdas? render-settings))
(let* ([annotated (a:annotate expanded break
show-lambdas-as-lambdas?)])
(parameterize ([test-engine:test-silence #t]) (parameterize ([test-engine:test-silence #t])
(eval-syntax annotated)) (eval-syntax annotated))
(expand-next-expression))) (expand-next-expression)))
@ -340,7 +343,7 @@
(program-expander (program-expander
(lambda () (lambda ()
(unless disable-error-handling (unless disable-error-handling?
(error-display-handler err-display-handler))) (error-display-handler err-display-handler)))
(lambda (expanded continue-thunk) ; iter (lambda (expanded continue-thunk) ; iter
(r:reset-special-values) (r:reset-special-values)

2
collects/stepper/stepper-tool.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/unit #lang racket/unit
(require scheme/class (require scheme/class
drscheme/tool drscheme/tool

9
collects/stepper/view-controller.rkt
View File

@ -322,12 +322,11 @@
program-expander-prime program-expander-prime
;; what do do with the results: ;; what do do with the results:
(lambda (result) (async-channel-put view-channel result)) (lambda (result) (async-channel-put view-channel result))
(get-render-settings render-to-string render-to-sexp (get-render-settings render-to-string
render-to-sexp
(send language-level stepper:enable-let-lifting?) (send language-level stepper:enable-let-lifting?)
(send language-level stepper:show-consumed-and/or-clauses?)) (send language-level stepper:show-consumed-and/or-clauses?)
(send language-level stepper:show-lambdas-as-lambdas?) (send language-level stepper:show-lambdas-as-lambdas?)))
language-level
#f)
(send s-frame show #t) (send s-frame show #t)

20
collects/tests/stepper/language-level-model.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require stepper/private/model-settings) (require stepper/private/model-settings)
@ -7,34 +7,34 @@
;; DEFINING A LANGUAGE FOR THE PURPOSES OF TESTING ;; DEFINING A LANGUAGE FOR THE PURPOSES OF TESTING
;; ll-model : a representation of the behavior of a language level w.r.t. the stepper ;; ll-model : a representation of the behavior of a language level w.r.t. the stepper
(define-struct ll-model (namespace-spec teachpack-specs render-settings show-lambdas-as-lambdas? enable-testing?)) (define-struct ll-model (namespace-spec render-settings enable-testing?))
;; the built-in ll-models: ;; the built-in ll-models:
(define mz (define mz
(make-ll-model 'mzscheme `() fake-mz-render-settings #t #f)) (make-ll-model 'mzscheme fake-mz-render-settings #f))
(define beginner (define beginner
(make-ll-model `(lib "htdp-beginner.ss" "lang") `() fake-beginner-render-settings #f #t)) (make-ll-model `(lib "htdp-beginner.ss" "lang") fake-beginner-render-settings #t))
(define beginner-wla (define beginner-wla
(make-ll-model `(lib "htdp-beginner-abbr.ss" "lang") `() fake-beginner-wla-render-settings #f #t)) (make-ll-model `(lib "htdp-beginner-abbr.ss" "lang") fake-beginner-wla-render-settings #t))
(define intermediate (define intermediate
(make-ll-model `(lib "htdp-intermediate.ss" "lang") `() fake-intermediate-render-settings #f #t)) (make-ll-model `(lib "htdp-intermediate.ss" "lang") fake-intermediate-render-settings #t))
(define intermediate-lambda (define intermediate-lambda
(make-ll-model `(lib "htdp-intermediate-lambda.ss" "lang") `() fake-intermediate/lambda-render-settings #t #t)) (make-ll-model `(lib "htdp-intermediate-lambda.ss" "lang") fake-intermediate/lambda-render-settings #t))
(define advanced (define advanced
(make-ll-model `(lib "htdp-advanced.ss" "lang") `() fake-advanced-render-settings #t #t)) (make-ll-model `(lib "htdp-advanced.ss" "lang") fake-advanced-render-settings #t))
(define lazy (define lazy
(make-ll-model `(lib "lazy.ss" "lazy") `() fake-mz-render-settings #f #f)) (make-ll-model `(lib "lazy.ss" "lazy") fake-lazy-render-settings #f))
;; unsure about the render-settings, here: ;; unsure about the render-settings, here:
(define dmda-a (define dmda-a
(make-ll-model `(lib "DMdA-beginner.ss" "deinprogramm") '() fake-beginner-render-settings #f #t)) (make-ll-model `(lib "DMdA-beginner.ss" "deinprogramm") fake-beginner-render-settings #t))
;; SUPPORT FOR TESTING A BUNCH OF LANGUAGES AT ONCE: ;; SUPPORT FOR TESTING A BUNCH OF LANGUAGES AT ONCE:

13
collects/tests/stepper/test-engine.rkt
View File

@ -119,7 +119,7 @@
;; check to see whether the stepper produces the desired steps ;; check to see whether the stepper produces the desired steps
(define (test-sequence the-ll-model exp-str expected-steps error-box) (define (test-sequence the-ll-model exp-str expected-steps error-box)
(match the-ll-model (match the-ll-model
[(struct ll-model (namespace-spec teachpack-specs render-settings show-lambdas-as-lambdas? enable-testing?)) [(struct ll-model (namespace-spec render-settings enable-testing?))
(let ([filename (build-path test-directory "stepper-test")]) (let ([filename (build-path test-directory "stepper-test")])
(call-with-output-file filename (call-with-output-file filename
(lambda (port) (fprintf port "~a" exp-str)) (lambda (port) (fprintf port "~a" exp-str))
@ -131,14 +131,14 @@
[module-id (gensym "stepper-module-name-")] [module-id (gensym "stepper-module-name-")]
;; thunk this so that syntax errors happen within the error handlers: ;; thunk this so that syntax errors happen within the error handlers:
[expanded-thunk [expanded-thunk
(lambda () (expand-teaching-program port read-syntax namespace-spec teachpack-specs #f module-id enable-testing?))]) (lambda () (expand-teaching-program port read-syntax namespace-spec '() #f module-id enable-testing?))])
(test-sequence/core render-settings show-lambdas-as-lambdas? expanded-thunk expected-steps error-box)))])) (test-sequence/core render-settings expanded-thunk expected-steps error-box)))]))
;; test-sequence/core : render-settings? boolean? syntax? steps? ;; test-sequence/core : render-settings? boolean? syntax? steps?
;; this is a front end for calling the stepper's "go"; the main ;; this is a front end for calling the stepper's "go"; the main
;; responsibility here is to fake the behavior of DrRacket and collect the ;; responsibility here is to fake the behavior of DrRacket and collect the
;; resulting steps. ;; resulting steps.
(define (test-sequence/core render-settings show-lambdas-as-lambdas? expanded-thunk expected-steps error-box) (define (test-sequence/core render-settings expanded-thunk expected-steps error-box)
(let* ([current-error-display-handler (error-display-handler)] (let* ([current-error-display-handler (error-display-handler)]
[all-steps [all-steps
(append expected-steps '((finished-stepping)))] (append expected-steps '((finished-stepping)))]
@ -170,10 +170,7 @@
(let/ec escape (let/ec escape
(parameterize ([error-escape-handler (lambda () (escape (void)))]) (parameterize ([error-escape-handler (lambda () (escape (void)))])
(go iter-caller receive-result render-settings (go iter-caller receive-result render-settings
show-lambdas-as-lambdas? #:disable-error-handling? (disable-stepper-error-handling))))
;; language level:
'testing
(disable-stepper-error-handling))))
(error-display-handler current-error-display-handler))) (error-display-handler current-error-display-handler)))
(define-namespace-anchor n-anchor) (define-namespace-anchor n-anchor)