165 lines
6.5 KiB
Scheme
165 lines
6.5 KiB
Scheme
(module syncheck-debug mzscheme
|
|
(require (lib "pretty.ss")
|
|
(lib "list.ss")
|
|
(lib "class.ss")
|
|
(lib "mred.ss" "mred"))
|
|
|
|
(provide debug-origin) ;; : syntax [syntax] -> void
|
|
;; creates a frame for examining the
|
|
;; origin and source fields of an expanded sexp
|
|
;; also the 'bound-in-source syntax property
|
|
|
|
(define debug-origin
|
|
(case-lambda
|
|
[(original-object) (debug-origin original-object (expand original-object))]
|
|
[(original-object expanded-object)
|
|
(define-values (expanded-datum stx-ht) (syntax-object->datum/ht expanded-object))
|
|
|
|
(define output-text (make-object text%))
|
|
(define output-port (make-text-port output-text))
|
|
(define info-text (make-object text%))
|
|
(define info-port (make-text-port info-text))
|
|
|
|
;; assume that there aren't any eq? sub structures, only eq? flat stuff (symbols, etc)
|
|
;; this is guaranteed by syntax-object->datum/ht
|
|
(define range-start-ht (make-hash-table))
|
|
(define range-ht (make-hash-table))
|
|
(define original-output-port (current-output-port))
|
|
(define (range-pretty-print-pre-hook x v)
|
|
(hash-table-put! range-start-ht x (send output-text last-position)))
|
|
(define (range-pretty-print-post-hook x v)
|
|
(hash-table-put! range-ht x
|
|
(cons
|
|
(cons
|
|
(hash-table-get range-start-ht x)
|
|
(send output-text last-position))
|
|
(hash-table-get range-ht x (λ () null)))))
|
|
|
|
(define (make-modern text)
|
|
(send text change-style
|
|
(make-object style-delta% 'change-family 'modern)
|
|
0
|
|
(send text last-position)))
|
|
|
|
(define dummy
|
|
(begin (pretty-print (syntax-object->datum original-object) output-port)
|
|
(newline output-port)
|
|
(parameterize ([current-output-port output-port]
|
|
[pretty-print-pre-print-hook range-pretty-print-pre-hook]
|
|
[pretty-print-post-print-hook range-pretty-print-post-hook]
|
|
[pretty-print-columns 30])
|
|
(pretty-print expanded-datum))
|
|
(make-modern output-text)))
|
|
|
|
(define ranges
|
|
(sort
|
|
(apply append (hash-table-map range-ht (λ (k vs) (map (λ (v) (cons k v)) vs))))
|
|
(λ (x y)
|
|
(<= (- (car (cdr x)) (cdr (cdr x)))
|
|
(- (car (cdr y)) (cdr (cdr y)))))))
|
|
|
|
(define (show-info stx)
|
|
(fprintf info-port "datum: ~s\nsource: ~a\nposition: ~s\noffset: ~s\noriginal: ~s\nbound-in-source: ~s\n\n"
|
|
(syntax-object->datum stx)
|
|
(syntax-source stx)
|
|
(syntax-position stx)
|
|
(syntax-span stx)
|
|
(syntax-original? stx)
|
|
(syntax-property stx 'bound-in-source))
|
|
(let loop ([origin (syntax-property stx 'origin)])
|
|
(cond
|
|
[(pair? origin)
|
|
(loop (car origin))
|
|
(loop (cdr origin))]
|
|
[(syntax? origin)
|
|
(display " " info-port)
|
|
(display origin info-port)
|
|
(newline info-port)
|
|
(fprintf info-port
|
|
" original? ~a\n datum:\n ~a\n\n"
|
|
(and (syntax? origin) (syntax-original? origin))
|
|
(and (syntax? origin) (syntax-object->datum origin)))]
|
|
[else (void)])))
|
|
|
|
(for-each
|
|
(λ (range)
|
|
(let* ([obj (car range)]
|
|
[stx (hash-table-get stx-ht obj)]
|
|
[start (cadr range)]
|
|
[end (cddr range)])
|
|
(when (syntax? stx)
|
|
(send output-text set-clickback start end
|
|
(λ _
|
|
(send info-text begin-edit-sequence)
|
|
(send info-text erase)
|
|
(show-info stx)
|
|
(make-modern info-text)
|
|
(send info-text end-edit-sequence))))))
|
|
ranges)
|
|
|
|
(newline output-port)
|
|
(newline output-port)
|
|
(let ([before (send output-text last-position)])
|
|
(display "all" output-port)
|
|
(send output-text set-clickback
|
|
before
|
|
(send output-text last-position)
|
|
(λ _
|
|
(send info-text begin-edit-sequence)
|
|
(send info-text erase)
|
|
(for-each (λ (rng)
|
|
(let ([stx (hash-table-get stx-ht (car rng))])
|
|
(when (syntax? stx)
|
|
(show-info stx))))
|
|
ranges)
|
|
(make-modern info-text)
|
|
(send info-text end-edit-sequence))))
|
|
|
|
(let ()
|
|
(define f (make-object frame% "Syntax 'origin Browser" #f 600 300))
|
|
(define p (make-object horizontal-panel% f))
|
|
(make-object editor-canvas% p output-text)
|
|
(make-object editor-canvas% p info-text)
|
|
(send f show #t))]))
|
|
|
|
;; build-ht : stx -> hash-table
|
|
;; the resulting hash-table maps from the each sub-object's to it's syntax.
|
|
(define (syntax-object->datum/ht stx)
|
|
(let ([ht (make-hash-table)])
|
|
(values (let loop ([stx stx])
|
|
(let ([obj (syntax-e stx)])
|
|
(cond
|
|
[(list? obj)
|
|
(let ([res (map loop obj)])
|
|
(hash-table-put! ht res stx)
|
|
res)]
|
|
[(pair? obj)
|
|
(let ([res (cons (loop (car obj))
|
|
(loop (cdr obj)))])
|
|
(hash-table-put! ht res stx)
|
|
res)]
|
|
[(vector? obj)
|
|
(let ([res (list->vector (map loop (vector->list obj)))])
|
|
(hash-table-put! ht res stx)
|
|
res)]
|
|
[else
|
|
(let ([res (syntax-object->datum stx)])
|
|
(hash-table-put! ht res stx)
|
|
res)])))
|
|
ht)))
|
|
|
|
;; make-text-port : text -> port
|
|
;; builds a port from a text object.
|
|
(define (make-text-port text)
|
|
(let-values ([(in out) (make-pipe)])
|
|
(thread
|
|
(λ ()
|
|
(let loop ()
|
|
(let ([c (read-char in)])
|
|
(unless (eof-object? c)
|
|
(send text insert (string c)
|
|
(send text last-position)
|
|
(send text last-position))
|
|
(loop))))))
|
|
out)))
|