[racket-dev] [plt] Push #24868: master branch updated
This push resulted in the following failure (drdr will tell you the same thing in a few minutes probably).
raco setup: error: during making for stepper/private
raco setup: expand: unbound identifier in module
raco setup: in: stepper-syntax-property
raco setup: source:
raco setup: xml-box.rkt:20:11
On 06/20/2012 12:52 AM, clements at racket-lang.org wrote:
> clements has updated `master' from ac0bb2b98f to 63cc342cdb.
> http://git.racket-lang.org/plt/ac0bb2b98f..63cc342cdb
>
> =====[ 5 Commits ]======================================================
> Directory summary:
> 94.8% collects/stepper/private/
> 5.1% collects/
>
> ~~~~~~~~~~
>
> 615f687 John Clements <clements at racket-lang.org> 2012-04-12 17:42
> :
> | reformatting only
> :
> M collects/stepper/private/model.rkt | 105 ++++++++++++------------
> M collects/stepper/private/view-controller.rkt | 57 ++++++++-----
>
> ~~~~~~~~~~
>
> a11fd04 John Clements <clements at racket-lang.org> 2012-04-12 17:42
> :
> | working on adding stopping dialog
> :
> M collects/stepper/private/model.rkt | 9 +++--
> M collects/stepper/private/view-controller.rkt | 45 ++++++++++++++++++++++++-
>
> ~~~~~~~~~~
>
> 66321c8 John Clements <clements at racket-lang.org> 2012-06-19 13:11
> :
> | adding halt dialog for runaway process
> :
> M collects/stepper/private/model.rkt | 24 ++++++---
> M collects/stepper/private/shared.rkt | 15 ++++--
> M collects/stepper/private/view-controller.rkt | 66 ++++++++++++++++---------
>
> ~~~~~~~~~~
>
> c01e8c1 John Clements <clements at racket-lang.org> 2012-06-19 23:02
> :
> | refactored to reduce stepper dependencies
> :
> M collects/2htdp/universe.rkt | 2 +-
> M collects/deinprogramm/DMdA.rkt | 2 +-
> M collects/deinprogramm/deinprogramm-langs.rkt | 1 -
> M collects/deinprogramm/signature/signature.rkt | 2 +-
> M collects/gui-debugger/marks.rkt | 6 +-
> M collects/lang/htdp-langs.rkt | 2 -
> M collects/lang/prim.rkt | 2 +-
> M collects/lang/private/signature-syntax.rkt | 2 +-
> M collects/lang/private/teachhelp.rkt | 4 +-
> M collects/lang/private/teach.rkt | 2 +-
> M collects/lang/run-teaching-program.rkt | 2 +-
> M collects/lazy/lazy.rkt | 4 +-
> M collects/racket/private/promise.rkt | 2 +-
> M collects/stepper/private/annotate.rkt | 1 +
> M collects/stepper/private/lifting.rkt | 2 +-
> M collects/stepper/private/macro-unwind.rkt | 3 +-
> M collects/stepper/private/marks.rkt | 1 +
> M collects/stepper/private/model.rkt | 1 +
> M collects/stepper/private/mred-extensions.rkt | 10 +-
> M collects/stepper/private/reconstruct.rkt | 1 +
> M collects/stepper/private/shared.rkt | 92 +-----
> A collects/stepper/private/syntax-property.rkt
> D collects/stepper/private/testing-shared.rkt
> M collects/stepper/private/xml-snip-helpers.rkt | 309 +++++++++----------
> M collects/test-engine/racket-tests.rkt | 2 +-
> M collects/tests/stepper/shared-unit-tests.rkt | 3 +-
> M .../deinprogramm/define-record-procedures.rkt | 2 +-
> M .../deinprogramm/signature/signature-syntax.rkt | 2 +-
> M .../deinprogramm/signature/signature-unit.rkt | 2 +-
>
> ~~~~~~~~~~
>
> 63cc342 John Clements <clements at racket-lang.org> 2012-06-19 23:51
> :
> | fixes to dialog for too-many-step resolution
> :
> M collects/stepper/private/view-controller.rkt | 2 +-
>
> =====[ Overall Diff ]===================================================
>
> collects/2htdp/universe.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/2htdp/universe.rkt
> +++ NEW/collects/2htdp/universe.rkt
> @@ -17,7 +17,7 @@
> |#
>
> (require (for-syntax "private/clauses-spec-and-process.rkt"
> - stepper/private/shared)
> + stepper/private/syntax-property)
> "private/define-keywords.rkt"
> "private/clauses-spec-aux.rkt"
> ;; ---
>
> collects/deinprogramm/DMdA.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/deinprogramm/DMdA.rkt
> +++ NEW/collects/deinprogramm/DMdA.rkt
> @@ -12,7 +12,7 @@
> (except-in deinprogramm/signature/signature-syntax property))
>
> (require (for-syntax scheme/base)
> - (for-syntax stepper/private/shared))
> + (for-syntax stepper/private/syntax-property))
>
> (require deinprogramm/define-record-procedures)
>
>
> collects/deinprogramm/define-record-procedures.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/deinprogramm/define-record-procedures.rkt
> +++ NEW/collects/deinprogramm/define-record-procedures.rkt
> @@ -17,5 +17,5 @@
>
> (require (for-syntax scheme/base)
> (for-syntax deinprogramm/syntax-checkers)
> - (for-syntax stepper/private/shared))
> + (for-syntax stepper/private/syntax-property))
> (include "define-record-procedures.scm")
>
> collects/deinprogramm/deinprogramm-langs.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/deinprogramm/deinprogramm-langs.rkt
> +++ NEW/collects/deinprogramm/deinprogramm-langs.rkt
> @@ -25,7 +25,6 @@
> lang/debugger-language-interface
> lang/run-teaching-program
> lang/private/continuation-mark-key
> - stepper/private/shared
>
> (only-in test-engine/scheme-gui make-formatter)
> test-engine/scheme-tests
>
> collects/deinprogramm/signature/signature-syntax.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/deinprogramm/signature/signature-syntax.rkt
> +++ NEW/collects/deinprogramm/signature/signature-syntax.rkt
> @@ -11,7 +11,7 @@
> scheme/promise
> (for-syntax scheme/base)
> (for-syntax syntax/stx)
> - (for-syntax stepper/private/shared))
> + (for-syntax stepper/private/syntax-property))
>
> (define-for-syntax (phase-lift stx)
> (with-syntax ((?stx stx))
>
> collects/deinprogramm/signature/signature-unit.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/deinprogramm/signature/signature-unit.rkt
> +++ NEW/collects/deinprogramm/signature/signature-unit.rkt
> @@ -7,7 +7,7 @@
> mzlib/struct
> (only-in mzlib/list first rest)
> (for-syntax scheme/base)
> - (for-syntax stepper/private/shared))
> + (for-syntax stepper/private/syntax-property))
>
> (require deinprogramm/signature/signature)
>
>
> collects/deinprogramm/signature/signature.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/deinprogramm/signature/signature.rkt
> +++ NEW/collects/deinprogramm/signature/signature.rkt
> @@ -20,7 +20,7 @@
> (require scheme/promise
> mzlib/struct
> (for-syntax scheme/base)
> - (for-syntax stepper/private/shared))
> + (for-syntax stepper/private/syntax-property))
>
> (require deinprogramm/quickcheck/quickcheck)
>
>
> collects/gui-debugger/marks.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/gui-debugger/marks.rkt
> +++ NEW/collects/gui-debugger/marks.rkt
> @@ -2,9 +2,7 @@
>
> (require mzlib/list
> mzlib/contract
> - (prefix-in mz: mzscheme)
> - stepper/private/my-macros
> - stepper/private/shared)
> + (prefix-in mz: mzscheme))
>
> (define-struct full-mark-struct (module-name source label bindings values))
>
> @@ -57,7 +55,7 @@
> (define skipto-mark? skipto-mark-struct?)
> (define skipto-mark (make-skipto-mark-struct))
> (define (strip-skiptos mark-list)
> - (filter (lx (#%plain-app not (skipto-mark? _))) mark-list))
> + (filter (lambda (x) (#%plain-app not (skipto-mark? x))) mark-list))
>
>
> ; debug-key: this key will be used as a key for the continuation marks.
>
> collects/lang/htdp-langs.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/lang/htdp-langs.rkt
> +++ NEW/collects/lang/htdp-langs.rkt
> @@ -32,8 +32,6 @@
> "debugger-language-interface.rkt"
> "run-teaching-program.rkt"
> "htdp-langs-save-file-prefix.rkt"
> -
> - stepper/private/shared
>
> (only-in test-engine/scheme-gui make-formatter)
> (only-in test-engine/scheme-tests
>
> collects/lang/prim.rkt
> ~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/lang/prim.rkt
> +++ NEW/collects/lang/prim.rkt
> @@ -8,7 +8,7 @@
> (rename lang/htdp-beginner beginner-app #%app))
>
> (require-for-syntax (prefix fo: "private/firstorder.rkt")
> - stepper/private/shared)
> + stepper/private/syntax-property)
>
> (provide define-primitive
> define-higher-order-primitive
>
> collects/lang/private/signature-syntax.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/lang/private/signature-syntax.rkt
> +++ NEW/collects/lang/private/signature-syntax.rkt
> @@ -10,7 +10,7 @@
> scheme/promise
> (for-syntax scheme/base)
> (for-syntax syntax/stx)
> - (for-syntax stepper/private/shared)
> + (for-syntax stepper/private/syntax-property)
> (for-syntax "firstorder.rkt"))
>
> (define-for-syntax (phase-lift stx)
>
> collects/lang/private/teach.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/lang/private/teach.rkt
> +++ NEW/collects/lang/private/teach.rkt
> @@ -70,7 +70,7 @@
> (only racket/base syntax->datum datum->syntax)
> (rename racket/base kw-app #%app)
> racket/struct-info
> - stepper/private/shared
> + stepper/private/syntax-property
> test-engine/racket-tests)
>
> ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> collects/lang/private/teachhelp.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/lang/private/teachhelp.rkt
> +++ NEW/collects/lang/private/teachhelp.rkt
> @@ -1,11 +1,9 @@
> (module teachhelp mzscheme
> (require "firstorder.rkt"
> "rewrite-error-message.rkt"
> - stepper/private/shared
> + stepper/private/syntax-property
> (for-template (prefix r: racket/base)))
>
> - (require-for-syntax stepper/private/shared)
> -
> (provide make-undefined-check
> make-first-order-function)
>
>
> collects/lang/run-teaching-program.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/lang/run-teaching-program.rkt
> +++ NEW/collects/lang/run-teaching-program.rkt
> @@ -2,7 +2,7 @@
>
> (require "stepper-language-interface.rkt"
> "debugger-language-interface.rkt"
> - stepper/private/shared
> + stepper/private/syntax-property
> scheme/class
> scheme/contract
> test-engine/scheme-tests
>
> collects/lazy/lazy.rkt
> ~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/lazy/lazy.rkt
> +++ NEW/collects/lazy/lazy.rkt
> @@ -1,7 +1,7 @@
> #lang racket/base
>
> -(require (for-syntax racket/base))
> -(require (for-syntax stepper/private/shared))
> +(require (for-syntax racket/base)
> + (for-syntax stepper/private/syntax-property))
>
> ;; ~ = lazy (or delayed)
> ;; ! = strict (or forced)
>
> collects/racket/private/promise.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/racket/private/promise.rkt
> +++ NEW/collects/racket/private/promise.rkt
> @@ -174,7 +174,7 @@
> ;; stepper-syntax-property : like syntax property, but adds properties to an
> ;; association list associated with the syntax property 'stepper-properties
> ;; Had to re-define this because of circular dependencies
> - ;; (also defined in stepper/private/shared.rkt)
> + ;; (also defined in stepper/private/syntax-property.rkt)
> (define-for-syntax stepper-syntax-property
> (case-lambda
> [(stx tag)
>
> collects/stepper/private/annotate.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/stepper/private/annotate.rkt
> +++ NEW/collects/stepper/private/annotate.rkt
> @@ -4,6 +4,7 @@
> racket/contract
> "marks.rkt"
> "shared.rkt"
> + "syntax-property.rkt"
> "my-macros.rkt"
> #;"xml-box.rkt"
> (prefix-in beginner-defined: "beginner-defined.rkt")
>
> collects/stepper/private/lifting.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/stepper/private/lifting.rkt
> +++ NEW/collects/stepper/private/lifting.rkt
> @@ -1,8 +1,8 @@
> #lang racket
>
> (require (prefix-in kernel: syntax/kerncase)
> - "testing-shared.rkt"
> "shared.rkt"
> + "syntax-property.rkt"
> (for-syntax racket/base))
>
> (define-struct context-record (stx index kind))
>
> collects/stepper/private/macro-unwind.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/stepper/private/macro-unwind.rkt
> +++ NEW/collects/stepper/private/macro-unwind.rkt
> @@ -2,7 +2,8 @@
>
> (require (only-in syntax/kerncase kernel-syntax-case)
> "model-settings.rkt"
> - "shared.rkt")
> + "shared.rkt"
> + "syntax-property.rkt")
>
> (provide/contract [unwind (syntax? render-settings? . -> . syntax?)])
> ;
>
> collects/stepper/private/marks.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/stepper/private/marks.rkt
> +++ NEW/collects/stepper/private/marks.rkt
> @@ -4,6 +4,7 @@
> mzlib/contract
> "my-macros.rkt"
> "shared.rkt"
> + "syntax-property.rkt"
> #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss"))
>
> (define-struct full-mark-struct (source label bindings values))
>
> collects/stepper/private/model.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/stepper/private/model.rkt
> +++ NEW/collects/stepper/private/model.rkt
> @@ -1,4 +1,4 @@
> -#lang scheme/base
> +#lang racket/base
>
> ;step collector state machine (not yet implemented):
> ;
> @@ -38,13 +38,13 @@
> ; late-let(x) : ERROR
>
>
> -(require scheme/contract
> - scheme/match
> - scheme/class
> - scheme/list
> +(require racket/contract
> + racket/match
> + racket/list
> (prefix-in a: "annotate.rkt")
> (prefix-in r: "reconstruct.rkt")
> "shared.rkt"
> + "syntax-property.rkt"
> "marks.rkt"
> "model-settings.rkt"
> "macro-unwind.rkt"
> @@ -269,13 +269,20 @@
> ; - lhs = ellipses, rhs = last-rhs-exps
> ; when lhs = ellipses, and highlight-stack != null,
> ; pop step from stack and use lhs
> - (define (send-step lhs-exps lhs-finished-exps
> - rhs-exps rhs-finished-exps
> - step-kind lhs-posn-info rhs-posn-info)
> + (define/contract
> + (send-step lhs-exps lhs-finished-exps
> + rhs-exps rhs-finished-exps
> + step-kind lhs-posn-info rhs-posn-info)
> + (-> (listof syntax?)
> + (listof syntax?)
> + (listof syntax?)
> + (listof syntax?)
> + any/c any/c any/c
> + any)
>
> (define (send-it)
> (receive-result
> - (make-before-after-result
> + (before-after-result
> (append lhs-finished-exps lhs-exps)
> (append rhs-finished-exps rhs-exps)
> step-kind
> @@ -308,7 +315,8 @@
> [(step=? rhs-exps last-rhs-exps)
> (when DEBUG
> (printf "SKIPPING STEP (LHS = ellipses and RHS = last RHS)\n"))]
> - ; SKIPPING step, lhs = ellipses and highlight-stack = null and last-rhs = null
> + ; SKIPPING step, lhs = ellipses and highlight-stack = null and
> + ; last-rhs = null
> ; if last-rhs != null, send step (lhs = ...)
> [(null? highlight-stack)
> (if (not (null? last-rhs-exps))
> @@ -384,8 +392,11 @@
> (λ ()
> (when DEBUG
> (printf "\nforcing saved MARKLIST\n")
> - (for-each (λ (x) (printf "~a\n" (display-mark x))) mark-list)
> - (printf "saved RETURNED VALUE LIST: ~a\n" returned-value-list))
> + (for-each (λ (x)
> + (printf "~a\n" (display-mark x)))
> + mark-list)
> + (printf "saved RETURNED VALUE LIST: ~a\n"
> + returned-value-list))
> (map (λ (exp) (unwind exp render-settings))
> (maybe-lift
> (r:reconstruct-left-side
> @@ -396,29 +407,27 @@
>
> ; CASE: result-exp-break or result-value-break ----------------
> [(result-exp-break result-value-break)
> - (let ([reconstruct
> - (lambda ()
> - (let* ([rhs-reconstructed
> - (r:reconstruct-right-side
> - mark-list returned-value-list render-settings)]
> - [print-rhs-recon
> - (when DEBUG
> - (printf "RHS (pre-unwound):\n ~a\n"
> - (syntax->hilite-datum rhs-reconstructed)))]
> - [rhs-unwound
> - (map (λ (exp) (unwind exp render-settings))
> - (maybe-lift rhs-reconstructed #f))]
> - [print-rhs-unwound
> - (when DEBUG
> - (for-each
> - (λ (x) (printf "RHS (unwound): ~a\n"
> - (syntax->hilite-datum x)))
> - rhs-unwound))])
> - rhs-unwound))])
> + (define (reconstruct)
> + (define rhs-reconstructed
> + (r:reconstruct-right-side
> + mark-list returned-value-list render-settings))
> + (when DEBUG
> + (printf "RHS (pre-unwound):\n ~a\n"
> + (syntax->hilite-datum
> + rhs-reconstructed)))
> + (define rhs-unwound
> + (map (λ (exp) (unwind exp render-settings))
> + (maybe-lift rhs-reconstructed #f)))
> + (when DEBUG
> + (for-each
> + (λ (x) (printf "RHS (unwound): ~a\n"
> + (syntax->hilite-datum x)))
> + rhs-unwound))
> + rhs-unwound)
> (match held-exp-list
> [(struct skipped-step ())
> (when DEBUG (printf "LHS = skipped, so skipping RHS\n"))
> - ;; don't render if before step was a skipped-step
> + ;; don't render if before step was a skipped-step
> (reset-held-exp-list)]
> [(struct no-sexp ())
> (when DEBUG (printf "LHS = none\n"))
> @@ -437,7 +446,7 @@
> (reconstruct) (reconstruct-all-completed)
> (compute-step-kind held-step-was-app?)
> held-posn-info (compute-posn-info))
> - (reset-held-exp-list)]))]
> + (reset-held-exp-list)])]
>
> ; CASE: double-break ------------------------------------------
> [(double-break)
> @@ -447,31 +456,31 @@
> (error
> 'break-reconstruction
> "held-exp-list not empty when a double-break occurred"))
> - (let* ([new-finished-list (reconstruct-all-completed)]
> - [reconstruct-result
> - (r:reconstruct-double-break mark-list render-settings)]
> - [print-recon
> - (when DEBUG
> - (printf "LHS (pre-unwound):\n ~a\n"
> - (syntax->hilite-datum (car reconstruct-result)))
> - (printf "RHS (pre-unwound):\n ~a\n"
> - (syntax->hilite-datum (cadr reconstruct-result))))]
> - [lhs-unwound (map (lambda (exp) (unwind exp render-settings))
> - (maybe-lift (car reconstruct-result) #f))]
> - [rhs-unwound (map (lambda (exp) (unwind exp render-settings))
> - (maybe-lift (cadr reconstruct-result) #t))]
> - [print-unwound
> - (when DEBUG
> - (for-each (λ (x) (printf "LHS (unwound):\n ~a\n"
> - (syntax->hilite-datum x)))
> - lhs-unwound)
> - (for-each (λ (x) (printf "right side (unwound):\n ~a\n"
> - (syntax->hilite-datum x)))
> - rhs-unwound))])
> - (send-step lhs-unwound new-finished-list
> - rhs-unwound new-finished-list
> - 'normal
> - (compute-posn-info) (compute-posn-info)))]
> + (define new-finished-list (reconstruct-all-completed))
> + (define reconstruct-result
> + (r:reconstruct-double-break mark-list render-settings))
> + (when DEBUG
> + (printf "LHS (pre-unwound):\n ~a\n"
> + (syntax->hilite-datum (car reconstruct-result)))
> + (printf "RHS (pre-unwound):\n ~a\n"
> + (syntax->hilite-datum (cadr reconstruct-result))))
> + (define lhs-unwound
> + (map (lambda (exp) (unwind exp render-settings))
> + (maybe-lift (car reconstruct-result) #f)))
> + (define rhs-unwound
> + (map (lambda (exp) (unwind exp render-settings))
> + (maybe-lift (cadr reconstruct-result) #t)))
> + (when DEBUG
> + (for-each (λ (x) (printf "LHS (unwound):\n ~a\n"
> + (syntax->hilite-datum x)))
> + lhs-unwound)
> + (for-each (λ (x) (printf "right side (unwound):\n ~a\n"
> + (syntax->hilite-datum x)))
> + rhs-unwound))
> + (send-step lhs-unwound new-finished-list
> + rhs-unwound new-finished-list
> + 'normal
> + (compute-posn-info) (compute-posn-info))]
>
> ; CASE: expr-finished-break -----------------------------------
> [(expr-finished-break)
> @@ -489,7 +498,8 @@
> (printf " source: ~a\n" (syntax->hilite-datum ((car x))))
> (printf " index: ~a\n" (second x))
> (printf " getter: ")
> - (if (stepper-syntax-property ((car x)) 'stepper-black-box-expr)
> + (if (stepper-syntax-property ((car x))
> + 'stepper-black-box-expr)
> (printf "no getter for term with stepper-black-box-expr property\n")
> (printf "~a\n" ((third x)))))
> returned-value-list))
> @@ -502,7 +512,8 @@
> (define maybe-lift
> (if (render-settings-lifting? render-settings)
> lift
> - ;; ... oh dear; model.rkt should disable the double-break & late-let break when lifting is off.
> + ;; ... oh dear; model.rkt should disable the double-break & late-let
> + ;; break when lifting is off.
> (lambda (stx dont-care) (list stx))))
>
> (define (step-through-expression expanded expand-next-expression)
> @@ -517,11 +528,11 @@
> (define (err-display-handler message exn)
> (match held-exp-list
> [(struct no-sexp ())
> - (receive-result (make-error-result message))]
> + (receive-result (error-result message))]
> [(struct held (exps dc posn-info))
> (begin
> (receive-result
> - (make-before-error-result (append held-finished-list exps)
> + (before-error-result (append held-finished-list exps)
> message
> posn-info))
> (set! held-exp-list the-no-sexp))]))
> @@ -534,7 +545,7 @@
> (r:reset-special-values)
> (if (eof-object? expanded)
> (begin
> - (receive-result (make-finished-stepping)))
> + (receive-result (finished-stepping)))
> (step-through-expression expanded continue-thunk)))))
>
>
>
> collects/stepper/private/mred-extensions.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/stepper/private/mred-extensions.rkt
> +++ NEW/collects/stepper/private/mred-extensions.rkt
> @@ -1,11 +1,9 @@
> -#lang scheme
> +#lang racket
>
> -(require mzlib/class
> - mred
> +(require mred
> (prefix-in f: framework)
> - mzlib/pretty
> - #;"testing-shared.rkt"
> - "shared.rkt"
> + racket/pretty
> + "syntax-property.rkt"
> images/compile-time
> (for-syntax images/icons/control images/icons/style))
>
>
> collects/stepper/private/reconstruct.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/stepper/private/reconstruct.rkt
> +++ NEW/collects/stepper/private/reconstruct.rkt
> @@ -13,6 +13,7 @@
> "marks.rkt"
> "model-settings.rkt"
> "shared.rkt"
> + "syntax-property.rkt"
> "my-macros.rkt"
> (for-syntax scheme/base)
> racket/private/promise)
>
> collects/stepper/private/shared.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/stepper/private/shared.rkt
> +++ NEW/collects/stepper/private/shared.rkt
> @@ -1,6 +1,6 @@
> #lang racket
>
> -(require rackunit)
> +(require "syntax-property.rkt")
>
> ; CONTRACTS
>
> @@ -45,10 +45,12 @@
> varref-set-remove-bindings
> binding-set-varref-set-intersect
> step-result?
> + step-maybe-result?
> (struct-out before-after-result)
> (struct-out before-error-result)
> (struct-out error-result)
> (struct-out finished-stepping)
> + (struct-out runaway-process)
> list-take
> list-partition
> (struct-out closure-record)
> @@ -83,16 +85,7 @@
> finished-xml-box-table
> language-level->name
> saved-code-inspector
> - stepper-syntax-property
> - with-stepper-syntax-properties
>
> - skipto/cdr
> - skipto/cddr
> - skipto/first
> - skipto/second
> - skipto/third
> - skipto/fourth
> - skipto/firstarg
>
> (struct-out annotated-proc)
>
> @@ -100,67 +93,6 @@
> stepper-frame^
> )
>
> -;; stepper-syntax-property : like syntax property, but adds properties to an association
> -;; list associated with the syntax property 'stepper-properties
> -
> -(define stepper-syntax-property
> - (case-lambda
> - [(stx tag)
> - (unless (member tag known-stepper-syntax-property-names)
> - (raise-type-error 'stepper-syntax-property "known stepper property symbol" 1 stx tag))
> - (let ([stepper-props (syntax-property stx 'stepper-properties)])
> - (if stepper-props
> - (let ([table-lookup (assq tag stepper-props)])
> - (if table-lookup
> - (cadr table-lookup)
> - #f))
> - #f))]
> - [(stx tag new-val)
> - (unless (member tag known-stepper-syntax-property-names)
> - (raise-type-error 'stepper-syntax-property "known stepper property symbol" 1
> - stx tag new-val))
> - (syntax-property stx 'stepper-properties
> - (cons (list tag new-val)
> - (or (syntax-property stx 'stepper-properties)
> - null)))]))
> -
> -;; if the given property name isn't in this list, signal an error...
> -(define known-stepper-syntax-property-names
> - '(stepper-skip-completely
> - stepper-hint
> - stepper-define-type
> - stepper-xml-hint
> - stepper-xml-value-hint
> - stepper-proc-define-name
> - stepper-orig-name
> - stepper-prim-name
> - stepper-binding-type
> - stepper-no-lifting-info
> - stepper-and/or-clauses-consumed
> - stepper-skipto
> - stepper-skipto/discard
> - stepper-replace
> - stepper-else
> - stepper-black-box-expr
> - stepper-test-suite-hint
> - stepper-highlight
> - stepper-fake-exp
> - stepper-args-of-call
> - stepper-hide-completed
> - stepper-hide-reduction
> - stepper-use-val-as-final
> - stepper-lifted-name
> - lazy-op
> - ))
> -
> - ;; with-stepper-syntax-properties : like stepper-syntax-property, but in a "let"-like form
> - (define-syntax (with-stepper-syntax-properties stx)
> - (syntax-case stx ()
> - [(_ ([property val] ...) body)
> - (foldl (lambda (property val b) #`(stepper-syntax-property #,b #,property #,val))
> - #'body
> - (syntax->list #`(property ...))
> - (syntax->list #`(val ...)))]))
>
> ; A step-result is either:
> ; (make-before-after-result finished-exps exp redex reduct)
> @@ -168,12 +100,15 @@
> ; or (make-error-result finished-exps err-msg)
> ; or (make-finished-result finished-exps)
>
> - (define-struct before-after-result (pre-exps post-exps kind pre-src post-src) #:transparent)
> - (define-struct before-error-result (pre-exps err-msg pre-src) #:transparent)
> - (define-struct error-result (err-msg) #:transparent)
> - (define-struct finished-stepping () #:transparent)
> + (struct before-after-result (pre-exps post-exps kind pre-src post-src) #:prefab)
> + (struct before-error-result (pre-exps err-msg pre-src) #:prefab)
> + (struct error-result (err-msg) #:prefab)
> + (struct finished-stepping () #:prefab)
> + (struct runaway-process (sema) #:prefab)
>
> - (define step-result? (or/c before-after-result? before-error-result? error-result? finished-stepping?))
> + (define step-result? (or/c before-after-result? before-error-result?
> + error-result? finished-stepping?))
> + (define step-maybe-result? (or/c step-result? runaway-process?))
>
> ; the closure record is placed in the closure table
>
> @@ -490,14 +425,6 @@
> 'rebuild)
> `(a . (b ((2) c . 3) d))))
>
> - ;; commonly used values for stepper-syntax-property:
> - (define skipto/cdr `(syntax-e cdr))
> - (define skipto/cddr `(syntax-e cdr cdr))
> - (define skipto/first `(syntax-e car))
> - (define skipto/second `(syntax-e cdr car))
> - (define skipto/third `(syntax-e cdr cdr car))
> - (define skipto/fourth `(syntax-e cdr cdr cdr car))
> - (define skipto/firstarg (append skipto/cdr skipto/second))
>
> ;; skipto/auto : syntax?
> ;; (symbols 'rebuild 'discard)
> @@ -512,7 +439,10 @@
> (cond [(or (stepper-syntax-property stx 'stepper-skipto)
> (stepper-syntax-property stx 'stepper-skipto/discard))
> =>
> - (lambda (x) (update x stx (lambda (y) (skipto/auto y traversal transformer)) traversal))]
> + (lambda (x) (update x stx
> + (lambda (y)
> + (skipto/auto y traversal transformer))
> + traversal))]
> [else (transformer stx)]))
>
> ; small test case:
> @@ -767,10 +697,3 @@
>
> (define-signature view-controller^ (go))
> (define-signature stepper-frame^ (stepper-frame%))
> -
> -
> -
> -
> -
> -
> -
>
> collects/stepper/private/syntax-property.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/stepper/private/syntax-property.rkt
> @@ -0,0 +1,96 @@
> +#lang racket/base
> +
> +(require (for-syntax racket/base))
> +
> +(provide stepper-syntax-property
> + with-stepper-syntax-properties
> +
> + skipto/cdr
> + skipto/cddr
> + skipto/first
> + skipto/second
> + skipto/third
> + skipto/fourth
> + skipto/firstarg)
> +
> +
> +;; stepper-syntax-property : like syntax property, but adds properties to an association
> +;; list associated with the syntax property 'stepper-properties
> +
> +(define stepper-syntax-property
> + (case-lambda
> + [(stx tag)
> + (unless (member tag known-stepper-syntax-property-names)
> + (raise-type-error 'stepper-syntax-property
> + "known stepper property symbol" 1 stx tag))
> + (let ([stepper-props (syntax-property stx 'stepper-properties)])
> + (if stepper-props
> + (let ([table-lookup (assq tag stepper-props)])
> + (if table-lookup
> + (cadr table-lookup)
> + #f))
> + #f))]
> + [(stx tag new-val)
> + (unless (member tag known-stepper-syntax-property-names)
> + (raise-type-error 'stepper-syntax-property
> + "known stepper property symbol" 1
> + stx tag new-val))
> + (syntax-property stx 'stepper-properties
> + (cons (list tag new-val)
> + (or (syntax-property stx 'stepper-properties)
> + null)))]))
> +
> +
> +
> +;; if the given property name isn't in this list, signal an error...
> +(define known-stepper-syntax-property-names
> + '(stepper-skip-completely
> + stepper-hint
> + stepper-define-type
> + stepper-xml-hint
> + stepper-xml-value-hint
> + stepper-proc-define-name
> + stepper-orig-name
> + stepper-prim-name
> + stepper-binding-type
> + stepper-no-lifting-info
> + stepper-and/or-clauses-consumed
> + stepper-skipto
> + stepper-skipto/discard
> + stepper-replace
> + stepper-else
> + stepper-black-box-expr
> + stepper-test-suite-hint
> + stepper-highlight
> + stepper-fake-exp
> + stepper-args-of-call
> + stepper-hide-completed
> + stepper-hide-reduction
> + stepper-use-val-as-final
> + stepper-lifted-name
> + lazy-op
> + ))
> +
> +
> +
> + ;; with-stepper-syntax-properties : like stepper-syntax-property,
> + ;; but in a "let"-like form
> + (define-syntax (with-stepper-syntax-properties stx)
> + (syntax-case stx ()
> + [(_ ([property val] ...) body)
> + (foldl (lambda (property val b)
> + #`(stepper-syntax-property #,b #,property #,val))
> + #'body
> + (syntax->list #`(property ...))
> + (syntax->list #`(val ...)))]))
> +
> +
> +
> + ;; commonly used values for stepper-syntax-property:
> + (define skipto/cdr `(syntax-e cdr))
> + (define skipto/cddr `(syntax-e cdr cdr))
> + (define skipto/first `(syntax-e car))
> + (define skipto/second `(syntax-e cdr car))
> + (define skipto/third `(syntax-e cdr cdr car))
> + (define skipto/fourth `(syntax-e cdr cdr cdr car))
> + (define skipto/firstarg (append skipto/cdr skipto/second))
> \ No newline at end of file
>
> collects/stepper/private/testing-shared.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/stepper/private/testing-shared.rkt
> +++ /dev/null
> @@ -1,62 +0,0 @@
> -(module testing-shared mzscheme
> - (require mzlib/contract
> - "shared.rkt"
> - syntax/kerncase
> - mzlib/file)
> -
> - (provide/contract [build-stx-with-highlight ((or/c (listof any/c) string?) ; input with one or more '(hilite ...) tags
> - . -> .
> - (listof syntax?))]) ; result
> -
> - (define (build-stx-with-highlight input)
> - (let ([temp-file (make-temporary-file)])
> - (call-with-output-file temp-file
> - (lambda (port)
> - (if (string? input)
> - (display input port)
> - (map (lambda (sexp) (write sexp port) (display #\space port)) input)))
> - 'truncate)
> - (begin0
> - (let ([file-port (open-input-file temp-file)])
> - (let read-loop ([stx (read-syntax temp-file file-port)])
> - (if (eof-object? stx)
> - null
> - (cons
> - (let stx-loop ([stx stx])
> - (syntax-case stx (hilite)
> - [(hilite x)
> - (stepper-syntax-property (stx-loop #`x) 'stepper-highlight #t)]
> - [(a . rest) (datum->syntax-object stx (cons (stx-loop #`a) (stx-loop #`rest)) stx stx)]
> - [else stx]))
> - (read-loop (read-syntax temp-file file-port))))))
> - (delete-file temp-file))))
> -
> -; (require tests/utils/mz-testing
> -; tests/utils/sexp-diff)
> -; (test `((define a 13) 14 15 #f 1)
> -; map
> -; syntax-object->datum
> -; (build-stx-with-highlight `((define a 13) 14 15 #f 1)))
> -
> -; (let ([test-run (build-stx-with-highlight `((+ (hilite x) (hilite (+ (hilite 13) (a b))))))])
> -; (test #t (lambda () (and (pair? test-run) (null? (cdr test-run)))))
> -; (let ([test-stx (car test-run)])
> -; (test `(+ x (+ 13 (a b)))
> -; syntax-object->datum test-stx)
> -; (test #f stepper-syntax-property test-stx 'stepper-highlight)
> -; (test #t stepper-syntax-property (car (syntax-e (cdr (syntax-e test-stx)))) 'stepper-highlight)
> -; (test #t stepper-syntax-property (syntax-case test-stx ()
> -; [(+ x target)
> -; #`target])
> -; 'stepper-highlight)
> -; (test #t stepper-syntax-property (syntax-case test-stx (#%app)
> -; [(+ x (a target d))
> -; #`target])
> -; 'stepper-highlight)))
> -;
> -;
> -;
> -; (let ([test-sexp `(+ (hilite x) (hilite (+ (hilite 13) (a b))))])
> -; (test #t equal? test-sexp (syntax-object->hilite-datum (car (build-stx-with-highlight (list test-sexp))))))
> -
> - )
>
> collects/stepper/private/view-controller.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/stepper/private/view-controller.rkt
> +++ NEW/collects/stepper/private/view-controller.rkt
> @@ -47,21 +47,31 @@
> (define (go drracket-tab program-expander selection-start selection-end)
>
> ;; get the language-level:
> - (define language-settings (definitions-text->settings (send drracket-tab get-defs)))
> - (define language-level (drracket:language-configuration:language-settings-language language-settings))
> - (define simple-settings (drracket:language-configuration:language-settings-settings language-settings))
> + (define language-settings
> + (definitions-text->settings
> + (send drracket-tab get-defs)))
> +
> + (define language-level
> + (drracket:language-configuration:language-settings-language
> + language-settings))
> +
> + (define simple-settings
> + (drracket:language-configuration:language-settings-settings
> + language-settings))
>
> ;; VALUE CONVERSION CODE:
>
> ;; render-to-string : TST -> string
> (define (render-to-string val)
> (let ([string-port (open-output-string)])
> - (send language-level render-value val simple-settings string-port)
> + (send language-level render-value
> + val simple-settings string-port)
> (get-output-string string-port)))
>
> ;; render-to-sexp : TST -> sexp
> (define (render-to-sexp val)
> - (send language-level stepper:render-to-sexp val simple-settings language-level))
> + (send language-level stepper:render-to-sexp
> + val simple-settings language-level))
>
> ;; channel for incoming views
> (define view-channel (make-async-channel))
> @@ -78,36 +88,51 @@
> ;; the view in the stepper window
> (define view #f)
>
> - ;; wait for steps to show up on the channel. When they do, add them to the list.
> + ;; wait for steps to show up on the channel.
> + ;; When they do, add them to the list.
> (define (start-listener-thread stepper-frame-eventspace)
> (thread
> (lambda ()
> (let loop ()
> (define new-result (async-channel-get view-channel))
> - (define new-step (format-result new-result))
> - (parameterize ([current-eventspace stepper-frame-eventspace])
> - (queue-callback
> - (lambda ()
> - (set! view-history (append view-history (list new-step)))
> - (set! num-steps-available (length view-history))
> - ;; this is only necessary the first time, but it's cheap:
> - (semaphore-post first-step-sema)
> - (update-status-bar))))
> + (receive-result-from-target new-result)
> (loop)))))
> +
> + ;; handles an incoming result. Either adds it to the list of
> + ;; steps, or prompts user to see whether to continue running.
> + (define (receive-result-from-target result)
> + (cond [(runaway-process? result)
> + (parameterize ([current-eventspace stepper-frame-eventspace])
> + (queue-callback
> + (lambda ()
> + (when (confirm-running)
> + (semaphore-post (runaway-process-sema result)))
> + (void))))]
> + [else
> + (define new-step (format-result result))
> + (parameterize ([current-eventspace stepper-frame-eventspace])
> + (queue-callback
> + (lambda ()
> + (set! view-history (append view-history (list new-step)))
> + (set! num-steps-available (length view-history))
> + ;; this is only necessary the first time, but it's cheap:
> + (semaphore-post first-step-sema)
> + (update-status-bar))))]))
>
>
> ;; find-later-step : given a predicate on history-entries, search through
> ;; the history for the first step that satisfies the predicate and whose
> ;; number is greater than n (or -1 if n is #f), return # of step on success,
> - ;; on failure return (list 'nomatch last-step) or (list 'nomatch/seen-final last-step)
> - ;; if we went past the final step
> + ;; on failure return (list 'nomatch last-step) or (list 'nomatch/seen-final
> + ;; last-step) if we went past the final step
> (define (find-later-step p n)
> (let* ([n-as-num (or n -1)])
> (let loop ([step 0]
> [remaining view-history]
> [seen-final? #f])
> - (cond [(null? remaining) (cond [seen-final? (list `nomatch/seen-final (- step 1))]
> - [else (list `nomatch (- step 1))])]
> + (cond [(null? remaining)
> + (cond [seen-final? (list `nomatch/seen-final (- step 1))]
> + [else (list `nomatch (- step 1))])]
> [(and (> step n-as-num) (p (car remaining))) step]
> [else (loop (+ step 1)
> (cdr remaining)
> @@ -117,7 +142,8 @@
> ;; the given step.
> (define (find-earlier-step p n)
> (unless (number? n)
> - (error 'find-earlier-step "can't find earlier step when no step is displayed."))
> + (error 'find-earlier-step
> + "can't find earlier step when no step is displayed."))
> (let* ([to-search (reverse (take view-history n))])
> (let loop ([step (- n 1)]
> [remaining to-search])
> @@ -152,12 +178,13 @@
> (define (next-of-specified-kind right-kind? msg)
> (next-of-specified-kind/helper right-kind? view msg))
>
> - ;; first-of-specified-kind : similar to next-of-specified-kind, but always start at zero
> + ;; first-of-specified-kind : similar to next-of-specified-kind, but
> + ;; always start at zero
> (define (first-of-specified-kind right-kind? msg)
> (next-of-specified-kind/helper right-kind? #f msg))
>
> - ;; next-of-specified-kind/helper : if the desired step is already in the list, display
> - ;; it; otherwise, give up.
> + ;; next-of-specified-kind/helper : if the desired step
> + ;; is already in the list, display it; otherwise, give up.
> (define (next-of-specified-kind/helper right-kind? starting-step msg)
> (match (find-later-step right-kind? starting-step)
> [(? number? n)
> @@ -225,7 +252,8 @@
> ;; choice box option
> (define (jump-to-prior-application)
> (prior-of-specified-kind application-step?
> - (string-constant stepper-no-earlier-application-step)))
> + (string-constant
> + stepper-no-earlier-application-step)))
>
>
> ;; GUI ELEMENTS:
> @@ -315,7 +343,8 @@
> (send status-text lock #f)
> (send status-text delete 0 (send status-text last-position))
> ;; updated to yield 1-based step numbering rather than 0-based numbering.
> - (send status-text insert (format "~a/~a" (if view (+ 1 view) "none") (length view-history)))
> + (send status-text insert
> + (format "~a/~a" (if view (+ 1 view) "none") (length view-history)))
> (send status-text lock #t)
> (send status-text end-edit-sequence))
>
> @@ -329,30 +358,85 @@
>
> (define (print-current-view item evt)
> (send (send canvas get-editor) print))
> +
> + ;; code for dealing with runaway processes:
> +
> + (define runaway-counter-limit 500)
> + (define disable-runaway-counter #f)
> + (define runaway-counter 0)
> +
> + ;; runs on the stepped-process side.
> + ;; checks to see if the process has taken too
> + ;; many steps. If so, send a message and block
> + ;; for a response, then send the result. Otherwise,
> + ;; just send the result.
> + (define (deliver-result-to-gui result)
> + (when (not disable-runaway-counter)
> + (set! runaway-counter (+ runaway-counter 1)))
> + (when (= runaway-counter runaway-counter-limit)
> + (define runaway-semaphore (make-semaphore 0))
> + (async-channel-put view-channel
> + (runaway-process runaway-semaphore))
> + ;; wait for a signal to continue running:
> + (semaphore-wait runaway-semaphore))
> + (async-channel-put view-channel result))
> +
> + (define keep-running-message
> + (string-append
> + "The program running in the stepper has taken a whole bunch of steps. "
> + "Do you want to continue running it for now, halt, or let it run "
> + "without asking again?"))
> +
> + (define (confirm-running)
> + (define message-box-result
> + (message-box/custom
> + "Keep Running Program?"
> + keep-running-message
> + "Continue for now"
> + "Halt"
> + "Continue uninterrupted"
> + #f ;; use the stepper window instead?
> + '(stop disallow-close default=1)
> + ))
> + (match message-box-result
> + ;; continue-for-now:
> + [1 (set! runaway-counter 0)
> + #t]
> + ;; halt:
> + [2 #f]
> + ;; continue-forever:
> + [3 (set! runaway-counter 0)
> + (set! disable-runaway-counter #t)
> + #t]))
> +
> +
>
> ;; translates a result into a step
> - ;; format-result : result -> step?
> + ;; format-result : step-result -> step?
> (define (format-result result)
> (match result
> [(struct before-after-result (pre-exps post-exps kind pre-src post-src))
> (make-step (new x:stepper-text%
> [left-side pre-exps]
> [right-side post-exps]
> - [show-inexactness? (send language-level stepper:show-inexactness?)])
> + [show-inexactness?
> + (send language-level stepper:show-inexactness?)])
> kind
> (list pre-src post-src))]
> [(struct before-error-result (pre-exps err-msg pre-src))
> (make-step (new x:stepper-text%
> [left-side pre-exps]
> [right-side err-msg]
> - [show-inexactness? (send language-level stepper:show-inexactness?)])
> + [show-inexactness?
> + (send language-level stepper:show-inexactness?)])
> 'finished-or-error
> (list pre-src))]
> [(struct error-result (err-msg))
> (make-step (new x:stepper-text%
> [left-side null]
> [right-side err-msg]
> - [show-inexactness? (send language-level stepper:show-inexactness?)])
> + [show-inexactness?
> + (send language-level stepper:show-inexactness?)])
> 'finished-or-error
> (list))]
> [(struct finished-stepping ())
> @@ -381,7 +465,7 @@
> (model:go
> program-expander-prime
> ;; what do do with the results:
> - (lambda (result) (async-channel-put view-channel result))
> + deliver-result-to-gui
> (get-render-settings render-to-string
> render-to-sexp
> (send language-level stepper:enable-let-lifting?)
>
> collects/stepper/private/xml-snip-helpers.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/stepper/private/xml-snip-helpers.rkt
> +++ NEW/collects/stepper/private/xml-snip-helpers.rkt
> @@ -1,157 +1,156 @@
> -(module xml-snip-helpers mzscheme
> - (require xml/xml
> - syntax/readerr
> - mred
> - mzlib/class
> - mzlib/list
> - "shared.rkt")
> -
> - (provide xml-read-special
> - xml-snip<%>
> - scheme-read-special
> - scheme-snip<%>)
> -
> - (define (scheme-read-special snip source line col pos)
> - (let ([text (send snip get-editor)]
> - [splice? (send snip get-splice?)])
> - (when (= 0 (send text last-position))
> - (raise-read-error
> - (if splice?
> - "read: bad syntax: empty scheme splice box"
> - "read: bad syntax: empty scheme box")
> - source line col pos 1))
> - (let* ([source-name (get-source-name text)]
> - [stx (read-syntax source-name
> - (open-input-text-editor text 0 'end values source-name))])
> - (when (eof-object? stx)
> - (raise-read-error
> - (if splice?
> - "read: bad syntax: empty scheme splice box"
> - "read: bad syntax: empty scheme box")
> - source-name 1 1 1 (send text last-position)))
> - stx)))
> -
> - (define (get-source-name text)
> +#lang racket
> +
> +(require xml/xml
> + syntax/readerr
> + mred
> + "syntax-property.rkt")
> +
> +(provide xml-read-special
> + xml-snip<%>
> + scheme-read-special
> + scheme-snip<%>)
> +
> +(define (scheme-read-special snip source line col pos)
> + (let ([text (send snip get-editor)]
> + [splice? (send snip get-splice?)])
> + (when (= 0 (send text last-position))
> + (raise-read-error
> + (if splice?
> + "read: bad syntax: empty scheme splice box"
> + "read: bad syntax: empty scheme box")
> + source line col pos 1))
> + (let* ([source-name (get-source-name text)]
> + [stx (read-syntax source-name
> + (open-input-text-editor text 0 'end values source-name))])
> + (when (eof-object? stx)
> + (raise-read-error
> + (if splice?
> + "read: bad syntax: empty scheme splice box"
> + "read: bad syntax: empty scheme box")
> + source-name 1 1 1 (send text last-position)))
> + stx)))
> +
> +(define (get-source-name text)
> + (cond
> + [(method-in-interface? 'get-port-name (object-interface text))
> + (send text get-port-name)]
> + [else
> + (send text get-filename)]))
> +
> +(define (xml-read-special eliminate-whitespace-in-empty-tags? snip source line col pos)
> + (let ([editor (send snip get-editor)]
> + [old-locked #f])
> + (when (= 0 (send editor last-position))
> + (raise-read-error "read: bad syntax: empty xml box"
> + source line col pos 1))
> + (dynamic-wind
> + (lambda ()
> + (set! old-locked (send editor is-locked?))
> + (send editor lock #t))
> + (lambda ()
> + (let* ([source-name (get-source-name editor)]
> + [port (open-input-text-editor editor 0 'end (xml-snip-filter editor) source-name)]
> + [xml (parameterize ([permissive-xexprs #t]) (read-xml port))]
> + [xexpr (parameterize ([permissive-xexprs #t]) (xml->xexpr (document-element xml)))]
> + [clean-xexpr (if eliminate-whitespace-in-empty-tags?
> + (eliminate-whitespace-in-empty-tags xexpr)
> + xexpr)]
> + [expd-xexpr (expand-embedded clean-xexpr)]
> + [qq-body (datum->syntax #'here expd-xexpr (list editor #f #f #f #f))])
> + (with-syntax ([qq-body qq-body])
> + (stepper-syntax-property (syntax (quasiquote qq-body))
> + 'stepper-xml-hint
> + 'from-xml-box))))
> + (lambda () (send editor lock old-locked)))))
> +
> +(define ((xml-snip-filter text) s)
> + (cond
> + [(is-a? s scheme-snip<%>)
> + (let* ([position (send text get-snip-position s)]
> + [line (send text position-paragraph position)]
> + [col (- position (send text paragraph-start-position line))])
> + (make-wrapped s text line col position))]
> + [else s]))
> +
> +(define scheme-snip<%>
> + (interface ()
> + get-splice?))
> +
> +(define xml-snip<%>
> + (interface ()))
> +
> +;; eliminate-whitespace-in-empty-tags : xexpr -> xexpr
> +(define (eliminate-whitespace-in-empty-tags xexpr)
> + (cond
> + [(and (pair? xexpr)
> + (symbol? (car xexpr)))
> + (list* (car xexpr)
> + (cadr xexpr)
> + (map eliminate-whitespace-in-empty-tags
> + (eliminate-whitespace-in-list (cddr xexpr))))]
> + [else xexpr]))
> +
> +;; wrapped = (make-wraped sexp text number number number)
> +(define-struct wrapped (snip text line col pos))
> +
> +;; expand-embedded : xexpr -> xexpr
> +;; constructs a new xexpr that has the embedded snips expanded
> +;; and wrapped with unquotes
> +;; CRUCIAL INVARIANT: an expression must not receive both 'from-xml-box and 'from-scheme/splice-box tags.
> +(define (expand-embedded _xexpr)
> + (let loop ([xexpr _xexpr])
> (cond
> - [(method-in-interface? 'get-port-name (object-interface text))
> - (send text get-port-name)]
> - [else
> - (send text get-filename)]))
> -
> - (define (xml-read-special eliminate-whitespace-in-empty-tags? snip source line col pos)
> - (let ([editor (send snip get-editor)]
> - [old-locked #f])
> - (when (= 0 (send editor last-position))
> - (raise-read-error "read: bad syntax: empty xml box"
> - source line col pos 1))
> - (dynamic-wind
> - (lambda ()
> - (set! old-locked (send editor is-locked?))
> - (send editor lock #t))
> - (lambda ()
> - (let* ([source-name (get-source-name editor)]
> - [port (open-input-text-editor editor 0 'end (xml-snip-filter editor) source-name)]
> - [xml (parameterize ([permissive-xexprs #t]) (read-xml port))]
> - [xexpr (parameterize ([permissive-xexprs #t]) (xml->xexpr (document-element xml)))]
> - [clean-xexpr (if eliminate-whitespace-in-empty-tags?
> - (eliminate-whitespace-in-empty-tags xexpr)
> - xexpr)]
> - [expd-xexpr (expand-embedded clean-xexpr)]
> - [qq-body (datum->syntax-object #'here expd-xexpr (list editor #f #f #f #f))])
> - (with-syntax ([qq-body qq-body])
> - (stepper-syntax-property (syntax (quasiquote qq-body))
> - 'stepper-xml-hint
> - 'from-xml-box))))
> - (lambda () (send editor lock old-locked)))))
> -
> - (define ((xml-snip-filter text) s)
> + [(pair? xexpr)
> + (cons (loop (car xexpr))
> + (loop (cdr xexpr)))]
> + [(wrapped? xexpr)
> + (let* ([snip (wrapped-snip xexpr)]
> + [text (wrapped-text xexpr)]
> + [pos (wrapped-pos xexpr)]
> + [line (wrapped-line xexpr)]
> + [col (wrapped-col xexpr)]
> + [raw-stxs (list (send snip read-special text line col pos))])
> + (with-syntax ([(stxs ...) raw-stxs])
> + (if (and (is-a? snip scheme-snip<%>)
> + (send snip get-splice?))
> + (with-syntax ([err (syntax/loc
> + (car (last-pair raw-stxs))
> + (error 'scheme-splice-box "expected a list, found: ~e" lst))])
> + #`,@#,(stepper-syntax-property #`(let ([lst (begin stxs ...)])
> + (if (list? lst)
> + lst
> + err))
> + 'stepper-xml-hint
> + 'from-splice-box))
> + #`,#,(stepper-syntax-property #`(begin stxs ...)
> + 'stepper-xml-hint
> + 'from-scheme-box))))]
> + [else xexpr])))
> +
> +;; eliminate-whitespace-in-list (listof xexpr) -> (listof xexpr)
> +;; if each string in xexprs is a whitespace string, remove all strings
> +;; otherwise, return input.
> +(define (eliminate-whitespace-in-list xexprs)
> + (cond
> + [(andmap (lambda (x) (or (not (string? x))
> + (string-whitespace? x)))
> + xexprs)
> + (filter (lambda (x) (not (string? x))) xexprs)]
> + [else xexprs]))
> +
> +;; string-whitespace? : string -> boolean
> +;; return #t if the input string consists entirely of whitespace
> +(define (string-whitespace? str)
> + (let loop ([i (string-length str)])
> (cond
> - [(is-a? s scheme-snip<%>)
> - (let* ([position (send text get-snip-position s)]
> - [line (send text position-paragraph position)]
> - [col (- position (send text paragraph-start-position line))])
> - (make-wrapped s text line col position))]
> - [else s]))
> -
> - (define scheme-snip<%>
> - (interface ()
> - get-splice?))
> -
> - (define xml-snip<%>
> - (interface ()))
> -
> - ;; eliminate-whitespace-in-empty-tags : xexpr -> xexpr
> - (define (eliminate-whitespace-in-empty-tags xexpr)
> - (cond
> - [(and (pair? xexpr)
> - (symbol? (car xexpr)))
> - (list* (car xexpr)
> - (cadr xexpr)
> - (map eliminate-whitespace-in-empty-tags
> - (eliminate-whitespace-in-list (cddr xexpr))))]
> - [else xexpr]))
> -
> - ;; wrapped = (make-wraped sexp text number number number)
> - (define-struct wrapped (snip text line col pos))
> -
> - ;; expand-embedded : xexpr -> xexpr
> - ;; constructs a new xexpr that has the embedded snips expanded
> - ;; and wrapped with unquotes
> - ;; CRUCIAL INVARIANT: an expression must not receive both 'from-xml-box and 'from-scheme/splice-box tags.
> - (define (expand-embedded _xexpr)
> - (let loop ([xexpr _xexpr])
> - (cond
> - [(pair? xexpr)
> - (cons (loop (car xexpr))
> - (loop (cdr xexpr)))]
> - [(wrapped? xexpr)
> - (let* ([snip (wrapped-snip xexpr)]
> - [text (wrapped-text xexpr)]
> - [pos (wrapped-pos xexpr)]
> - [line (wrapped-line xexpr)]
> - [col (wrapped-col xexpr)]
> - [raw-stxs (list (send snip read-special text line col pos))])
> - (with-syntax ([(stxs ...) raw-stxs])
> - (if (and (is-a? snip scheme-snip<%>)
> - (send snip get-splice?))
> - (with-syntax ([err (syntax/loc
> - (car (last-pair raw-stxs))
> - (error 'scheme-splice-box "expected a list, found: ~e" lst))])
> - #`,@#,(stepper-syntax-property #`(let ([lst (begin stxs ...)])
> - (if (list? lst)
> - lst
> - err))
> - 'stepper-xml-hint
> - 'from-splice-box))
> - #`,#,(stepper-syntax-property #`(begin stxs ...)
> - 'stepper-xml-hint
> - 'from-scheme-box))))]
> - [else xexpr])))
> -
> - ;; eliminate-whitespace-in-list (listof xexpr) -> (listof xexpr)
> - ;; if each string in xexprs is a whitespace string, remove all strings
> - ;; otherwise, return input.
> - (define (eliminate-whitespace-in-list xexprs)
> - (cond
> - [(andmap (lambda (x) (or (not (string? x))
> - (string-whitespace? x)))
> - xexprs)
> - (filter (lambda (x) (not (string? x))) xexprs)]
> - [else xexprs]))
> -
> - ;; string-whitespace? : string -> boolean
> - ;; return #t if the input string consists entirely of whitespace
> - (define (string-whitespace? str)
> - (let loop ([i (string-length str)])
> - (cond
> - [(zero? i) #t]
> - [(char-whitespace? (string-ref str (- i 1)))
> - (loop (- i 1))]
> - [else #f])))
> -
> -
> - ;; transformable? : snip -> boolean
> - ;; deteremines if a snip can be expanded here
> - (define (transformable? snip)
> - (or (is-a? snip xml-snip<%>)
> - (is-a? snip scheme-snip<%>))))
> + [(zero? i) #t]
> + [(char-whitespace? (string-ref str (- i 1)))
> + (loop (- i 1))]
> + [else #f])))
> +
> +
> +;; transformable? : snip -> boolean
> +;; deteremines if a snip can be expanded here
> +(define (transformable? snip)
> + (or (is-a? snip xml-snip<%>)
> + (is-a? snip scheme-snip<%>)))
>
> collects/test-engine/racket-tests.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/test-engine/racket-tests.rkt
> +++ NEW/collects/test-engine/racket-tests.rkt
> @@ -10,7 +10,7 @@
> "test-info.scm"
> )
>
> -(require (for-syntax stepper/private/shared))
> +(require (for-syntax stepper/private/syntax-property))
>
> (provide
> check-expect ;; syntax : (check-expect <expression> <expression>)
>
> collects/tests/stepper/shared-unit-tests.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/tests/stepper/shared-unit-tests.rkt
> +++ NEW/collects/tests/stepper/shared-unit-tests.rkt
> @@ -1,7 +1,8 @@
> #lang racket
>
> (require rackunit
> - stepper/private/shared)
> + stepper/private/shared
> + stepper/private/syntax-property)
>
> ; test cases taken from shared.rkt
> ;
![[logo]](/logo.png){kind=logo}