stepper refactoring and cleanup

2010-12-08 15:14:10 -08:00 · 2010-12-08 15:14:10 -08:00 · ff973b628b
commit ff973b628b
parent 463ab0d309
8 changed files with 120 additions and 107 deletions
--- a/collects/stepper/private/annotate.rkt
+++ b/collects/stepper/private/annotate.rkt
@ -1,16 +1,13 @@
-#lang racket/base
+#lang racket

 (require (prefix-in kernel: syntax/kerncase)
-         mzlib/contract
-         mzlib/list
-         mzlib/etc
-         scheme/match
+         racket/contract
         "marks.ss"
         "shared.ss"
         "my-macros.ss"
         #;"xml-box.ss"
         (prefix-in beginner-defined: "beginner-defined.ss")
-         (for-syntax scheme/base))
+         (for-syntax racket/base))

 (define-syntax (where stx)
  (syntax-case stx ()
@ -28,10 +25,9 @@
   (((or/c continuation-mark-set? false/c) 
     break-kind?)
    (list?)
-    . opt->* .
-    (any/c))                       ; procedure for runtime break
-   boolean?                        ; show-lambdas-as-lambdas?
-   (union any/c (symbols 'testing)); language-level
+    . ->* .
+    any/c)                       ; procedure for runtime break
+   boolean?   ; show-lambdas-as-lambdas?
   . -> .
   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)))
  
--- a/collects/stepper/private/display-break-stuff.rkt
+++ b/collects/stepper/private/display-break-stuff.rkt
@ -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
-    (new frame%
-      [label (format "Breakpoints Inspector")]
-      [width 400] [height 500]))
-  (define sel (new choice% [label "Breakpoint#"] [choices '()] [parent f]
-                   [callback (lambda (c e) (show-sel))] [stretchable-width #t]))
-  (define ec  (new editor-canvas% [parent f]))
-  (define t   (new text%))
-  (send ec set-editor t)
+(define f
+  (new frame%
+       [label (format "Breakpoints Inspector")]
+       [width 400] [height 500]))
+(define sel (new choice% [label "Breakpoint#"] [choices '()] [parent f]
+                 [callback (lambda (c e) (show-sel))] [stretchable-width #t]))
+(define ec  (new editor-canvas% [parent f]))
+(define t   (new text%))
+(send ec set-editor t)

-  (define selections '())
-  (define (add-sel num mset bkind retvals)
-    (set! selections (cons (list num mset bkind retvals) selections))
-    (let ([num (number->string num)])
-      (send sel append num)
-      (send sel set-string-selection num)
-      (show-sel)))
+(define selections '())
+(define (add-sel num mset bkind retvals)
+  (set! selections (cons (list num mset bkind retvals) selections))
+  (let ([num (number->string num)])
+    (send sel append num)
+    (send sel set-string-selection num)
+    (show-sel)))

-  (define (show-sel)
-    (let* ([num (string->number (send sel get-string-selection))]
-           [bpt (assq num selections)])
-      (send* t (lock #f) (erase))
-      (if (not bpt)
+(define (show-sel)
+  (let* ([num (string->number (send sel get-string-selection))]
+         [bpt (assq num selections)])
+    (send* t (lock #f) (erase))
+    (if (not bpt)
        (send* t (insert (format "Breakpoint #~a not found!\n" num)))
        (let-values ([(mset bkind retvals) (apply values (cdr bpt))])
          (send* t
@ -34,34 +34,34 @@
            (insert (format "  break-kind: ~v\n" bkind))
            (insert "marks:\n"))
          (if mset
-            (for-each
-             (lambda (mark)
-               (let* ([em (expose-mark mark)]
-                      [source (car em)]
-                      [label (cadr em)]
-                      [binding-set (caddr em)])
-                 (send* t
-                   (insert (format "  label: ~v\n" label))
-                   ;; we really want one of those nice collapsible
-                   ;; syntax-viewer thingies here:
-                   (insert (format "  source : ~v\n"
-                                   (syntax-object->datum source)))
-                   ;; here too, though this isn't a syntax object.
-                   (insert (format "  bindings: ~v\n" binding-set)))))
-             (extract-mark-list mset))
-            (send t insert "  nothing!\n"))
+              (for-each
+               (lambda (mark)
+                 (let* ([em (expose-mark mark)]
+                        [source (car em)]
+                        [label (cadr em)]
+                        [binding-set (caddr em)])
+                   (send* t
+                     (insert (format "  label: ~v\n" label))
+                     ;; we really want one of those nice collapsible
+                     ;; syntax-viewer thingies here:
+                     (insert (format "  source : ~v\n"
+                                     (syntax->datum source)))
+                     ;; here too, though this isn't a syntax object.
+                     (insert (format "  bindings: ~v\n" binding-set)))))
+               (extract-mark-list mset))
+              (send t insert "  nothing!\n"))
          (send t insert "returned-value-list:\n")
          (if retvals
-            (for-each (lambda (v) (send t insert (format "  ~v\n" v)))
-                      retvals)
-            (send t insert "  nothing!\n"))))
-      (send* t (lock #t))))
+              (for-each (lambda (v) (send t insert (format "  ~v\n" v)))
+                        retvals)
+              (send t insert "  nothing!\n"))))
+    (send* t (lock #t))))
+
+;; display-break-stuff : show the information associated with a breakpoint.
+;; Useful for people building steppers for new languages
+(define (display-break-stuff break-number mark-set break-kind
+                             returned-value-list)
+  (add-sel break-number mark-set break-kind returned-value-list)
+  (send f show #t))
  
-  ;; display-break-stuff : show the information associated with a breakpoint.
-  ;; Useful for people building steppers for new languages
-  (define (display-break-stuff break-number mark-set break-kind
-                               returned-value-list)
-    (add-sel break-number mark-set break-kind returned-value-list)
-    (send f show #t))
  
-  )
--- a/collects/stepper/private/model-settings.rkt
+++ b/collects/stepper/private/model-settings.rkt
@ -23,7 +23,8 @@
     render-to-sexp
     lifting?
     show-and/or-clauses-consumed?
-     all-bindings-mutable?))
+     all-bindings-mutable?
+     show-lambdas-as-lambdas?))
  
  (provide/contract [check-global-defined (-> symbol? boolean?)]
                    [global-lookup (-> any/c any)]
@ -35,7 +36,8 @@
                             [render-to-sexp (any/c . -> . any)]
                             [lifting? 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
                                          boolean? ; lifting?
 					  boolean? ; show-and/or-clauses-consumed?
+                                          boolean? ; show-lambdas-as-lambdas?
                                          . -> .
                                          render-settings?)]
                    
@ -53,7 +56,8 @@
                    [fake-intermediate-render-settings render-settings?]
                    [fake-intermediate/lambda-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)
    (lambda (val)
@ -67,20 +71,20 @@
  
    ; FIXME : #f totally unacceptable as 'render-to-string'
  (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
-    (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
    fake-beginner-wla-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:
  (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
    (make-render-settings (booleans-as-true/false) 
@ -89,13 +93,26 @@
                          print-convert
                          #f
                          #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))
  
  ;; get-render-settings : infer aspects of the current language's print conversion by explicitly testing 
  ;;  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")]
           [constructor-style-printing? (string=? (render-to-string (make-test-struct)) "(make-test-struct)")]
           [rendered-list (render-to-string '(3))]
@ -111,7 +128,8 @@
       render-to-sexp
       lifting?
       show-and/or-clauses-consumed?
-       #f)))
+       #f
+       show-lambdas-as-lambdas?)))
  
  (define (check-global-defined identifier)
    (with-handlers
--- a/collects/stepper/private/model.rkt
+++ b/collects/stepper/private/model.rkt
@ -63,13 +63,13 @@
   void?))

 (provide/contract
- [go (program-expander-contract       ; program-expander
+ [go (->*
+      (program-expander-contract       ; program-expander
      (step-result? . -> . void?)     ; receive-result
-      (or/c render-settings? false/c) ; render-settings
-      boolean?                        ; track-inferred-names?
-      (or/c object? (symbols 'testing))   ;; FIXME: can do better: subclass of language%       ; the language level
-      boolean?                        ; disable-error-handling (to allow debugging)
-      . -> .
+      (or/c render-settings? false/c)) ; render-settings
+      (#:raw-step-receiver 
+       (-> continuation-mark-set? symbol? void?)
+       #:disable-error-handling? boolean?)
      void?)])

   
@ -81,7 +81,8 @@
 ; go starts a stepper instance
 ; see provide stmt for contract
 (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:
  ;;   (listof (list/c syntax-object? (or/c number? false?)( -> any)))
@ -320,8 +321,10 @@
        (lambda (stx dont-care) (list stx))))
  
  (define (step-through-expression expanded expand-next-expression)
-    (let* ([annotated (a:annotate expanded break show-lambdas-as-lambdas?
-                                  language-level)])
+    (define show-lambdas-as-lambdas?
+      (render-settings-show-lambdas-as-lambdas? render-settings))
+    (let* ([annotated (a:annotate expanded break 
+                                  show-lambdas-as-lambdas?)])
      (parameterize ([test-engine:test-silence #t])
        (eval-syntax annotated))
      (expand-next-expression)))
@ -340,7 +343,7 @@
  
  (program-expander
   (lambda ()
-     (unless disable-error-handling
+     (unless disable-error-handling?
       (error-display-handler err-display-handler)))
   (lambda (expanded continue-thunk) ; iter
     (r:reset-special-values)
--- a/collects/stepper/stepper-tool.rkt
+++ b/collects/stepper/stepper-tool.rkt
@ -1,4 +1,4 @@
-#lang scheme/unit
+#lang racket/unit

 (require scheme/class
         drscheme/tool
--- a/collects/stepper/view-controller.rkt
+++ b/collects/stepper/view-controller.rkt
@ -322,12 +322,11 @@
   program-expander-prime 
   ;; what do do with the results:
   (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:show-consumed-and/or-clauses?))
-   (send language-level stepper:show-lambdas-as-lambdas?)
-   language-level
-   #f)
+			(send language-level stepper:show-consumed-and/or-clauses?)
+                        (send language-level stepper:show-lambdas-as-lambdas?)))
  
  (send s-frame show #t)
  
--- a/collects/tests/stepper/language-level-model.rkt
+++ b/collects/tests/stepper/language-level-model.rkt
@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base

 (require stepper/private/model-settings)

@ -7,34 +7,34 @@
 ;; DEFINING A LANGUAGE FOR THE PURPOSES OF TESTING

 ;; 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:
 (define mz
-  (make-ll-model 'mzscheme `() fake-mz-render-settings #t #f))
+  (make-ll-model 'mzscheme fake-mz-render-settings #f))

 (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
-  (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
-  (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
-  (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
-  (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
-  (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: 
 (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:
--- a/collects/tests/stepper/test-engine.rkt
+++ b/collects/tests/stepper/test-engine.rkt
@ -119,7 +119,7 @@
 ;; check to see whether the stepper produces the desired steps
 (define (test-sequence the-ll-model exp-str expected-steps error-box)
  (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")])
       (call-with-output-file filename
         (lambda (port) (fprintf port "~a" exp-str))
@ -131,14 +131,14 @@
              [module-id (gensym "stepper-module-name-")]
              ;; thunk this so that syntax errors happen within the error handlers:
              [expanded-thunk 
-               (lambda () (expand-teaching-program port read-syntax namespace-spec teachpack-specs #f module-id enable-testing?))])
-         (test-sequence/core render-settings show-lambdas-as-lambdas? expanded-thunk expected-steps error-box)))]))
+               (lambda () (expand-teaching-program port read-syntax namespace-spec '() #f module-id enable-testing?))])
+         (test-sequence/core render-settings expanded-thunk expected-steps error-box)))]))

 ;; test-sequence/core : render-settings? boolean? syntax? steps?
 ;; 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
 ;; 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)]
         [all-steps
          (append expected-steps '((finished-stepping)))]
@ -170,10 +170,7 @@
    (let/ec escape
      (parameterize ([error-escape-handler (lambda () (escape (void)))])
        (go iter-caller receive-result render-settings
-            show-lambdas-as-lambdas?
-            ;; language level:
-            'testing
-            (disable-stepper-error-handling))))
+            #:disable-error-handling? (disable-stepper-error-handling))))
    (error-display-handler current-error-display-handler)))

 (define-namespace-anchor n-anchor)