refactored to reduce stepper dependencies
This commit is contained in:
John Clements
parent
66321c8f84
commit
c01e8c1564
|
|
@ -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"
|
||||
;; ---
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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?)])
|
||||
;
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -44,6 +44,7 @@
|
|||
(prefix-in a: "annotate.rkt")
|
||||
(prefix-in r: "reconstruct.rkt")
|
||||
"shared.rkt"
|
||||
"syntax-property.rkt"
|
||||
"marks.rkt"
|
||||
"model-settings.rkt"
|
||||
"macro-unwind.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))
|
||||
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
"marks.rkt"
|
||||
"model-settings.rkt"
|
||||
"shared.rkt"
|
||||
"syntax-property.rkt"
|
||||
"my-macros.rkt"
|
||||
(for-syntax scheme/base)
|
||||
racket/private/promise)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket
|
||||
|
||||
(require rackunit)
|
||||
(require "syntax-property.rkt")
|
||||
|
||||
; CONTRACTS
|
||||
|
||||
|
|
@ -85,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)
|
||||
|
||||
|
|
@ -102,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)
|
||||
|
|
@ -495,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)
|
||||
|
|
@ -517,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:
|
||||
|
|
@ -772,10 +697,3 @@
|
|||
|
||||
(define-signature view-controller^ (go))
|
||||
(define-signature stepper-frame^ (stepper-frame%))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
96
collects/stepper/private/syntax-property.rkt
Normal file
96
collects/stepper/private/syntax-property.rkt
Normal file
|
|
@ -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))
|
||||
|
|
@ -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))))))
|
||||
|
||||
)
|
||||
|
|
@ -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<%>)))
|
||||
|
|
|
|||
|
|
@ -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>)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
#lang racket
|
||||
|
||||
(require rackunit
|
||||
stepper/private/shared)
|
||||
stepper/private/shared
|
||||
stepper/private/syntax-property)
|
||||
|
||||
; test cases taken from shared.rkt
|
||||
;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user