Skip to content

Commit 7b47364

Browse files
resyntax-ci[bot]rfindler
resyntax-ci[bot]
authored and
rfindler
committed
Fix 1 occurrence of define-case-lambda-to-define
This use of `case-lambda` is equivalent to using `define` with optional arguments.
1 parent 2d573ac commit 7b47364

File tree

1 file changed

+108
-112
lines changed

1 file changed

+108
-112
lines changed

‎drracket-core-lib/drracket/private/syncheck-debug.rkt‎

Lines changed: 108 additions & 112 deletions
Original file line numberDiff line numberDiff line change
@@ -10,118 +10,114 @@
1010
;; origin and source fields of an expanded sexp
1111
;; also the 'bound-in-source syntax property
1212

13-
(define debug-origin
14-
(case-lambda
15-
[(original-object) (debug-origin original-object (expand original-object))]
16-
[(original-object expanded-object)
17-
(define-values (expanded-datum stx-ht) (syntax-object->datum/ht expanded-object))
18-
19-
(define output-text (make-object text%))
20-
(define output-port (make-text-port output-text))
21-
(define info-text (make-object text%))
22-
(define info-port (make-text-port info-text))
23-
24-
;; assume that there aren't any eq? sub structures, only eq? flat stuff (symbols, etc)
25-
;; this is guaranteed by syntax-object->datum/ht
26-
(define range-start-ht (make-hasheq))
27-
(define range-ht (make-hasheq))
28-
(define original-output-port (current-output-port))
29-
(define (range-pretty-print-pre-hook x v)
30-
(hash-set! range-start-ht x (send output-text last-position)))
31-
(define (range-pretty-print-post-hook x v)
32-
(hash-set! range-ht x
33-
(cons
34-
(cons
35-
(hash-ref range-start-ht x)
36-
(send output-text last-position))
37-
(hash-ref range-ht x (λ () null)))))
38-
39-
(define (make-modern text)
40-
(send text change-style
41-
(make-object style-delta% 'change-family 'modern)
42-
0
43-
(send text last-position)))
44-
45-
(define dummy
46-
(begin (pretty-print (syntax->datum original-object) output-port)
47-
(newline output-port)
48-
(parameterize ([current-output-port output-port]
49-
[pretty-print-pre-print-hook range-pretty-print-pre-hook]
50-
[pretty-print-post-print-hook range-pretty-print-post-hook]
51-
[pretty-print-columns 30])
52-
(pretty-print expanded-datum))
53-
(make-modern output-text)))
54-
55-
(define ranges
56-
(sort
57-
(apply append (hash-map range-ht (λ (k vs) (map (λ (v) (cons k v)) vs))))
58-
(λ (x y)
59-
(<= (- (car (cdr x)) (cdr (cdr x)))
60-
(- (car (cdr y)) (cdr (cdr y)))))))
61-
62-
(define (show-info stx)
63-
(fprintf info-port "datum: ~s\nsource: ~a\nposition: ~s\noffset: ~s\noriginal: ~s\nbound-in-source: ~s\n\n"
64-
(syntax->datum stx)
65-
(syntax-source stx)
66-
(syntax-position stx)
67-
(syntax-span stx)
68-
(syntax-original? stx)
69-
(syntax-property stx 'bound-in-source))
70-
(let loop ([origin (syntax-property stx 'origin)])
71-
(cond
72-
[(pair? origin)
73-
(loop (car origin))
74-
(loop (cdr origin))]
75-
[(syntax? origin)
76-
(display " " info-port)
77-
(display origin info-port)
78-
(newline info-port)
79-
(fprintf info-port
80-
" original? ~a\n datum:\n ~a\n\n"
81-
(and (syntax? origin) (syntax-original? origin))
82-
(and (syntax? origin) (syntax->datum origin)))]
83-
[else (void)])))
84-
85-
(for-each
86-
(λ (range)
87-
(let* ([obj (car range)]
88-
[stx (hash-ref stx-ht obj)]
89-
[start (cadr range)]
90-
[end (cddr range)])
91-
(when (syntax? stx)
92-
(send output-text set-clickback start end
93-
(λ _
94-
(send info-text begin-edit-sequence)
95-
(send info-text erase)
96-
(show-info stx)
97-
(make-modern info-text)
98-
(send info-text end-edit-sequence))))))
99-
ranges)
100-
101-
(newline output-port)
102-
(newline output-port)
103-
(let ([before (send output-text last-position)])
104-
(display "all" output-port)
105-
(send output-text set-clickback
106-
before
107-
(send output-text last-position)
108-
(λ _
109-
(send info-text begin-edit-sequence)
110-
(send info-text erase)
111-
(for-each (λ (rng)
112-
(let ([stx (hash-ref stx-ht (car rng))])
113-
(when (syntax? stx)
114-
(show-info stx))))
115-
ranges)
116-
(make-modern info-text)
117-
(send info-text end-edit-sequence))))
118-
119-
(let ()
120-
(define f (make-object frame% "Syntax 'origin Browser" #f 600 300))
121-
(define p (make-object horizontal-panel% f))
122-
(make-object editor-canvas% p output-text)
123-
(make-object editor-canvas% p info-text)
124-
(send f show #t))]))
13+
(define (debug-origin original-object [expanded-object (expand original-object)])
14+
(define-values (expanded-datum stx-ht) (syntax-object->datum/ht expanded-object))
15+
16+
(define output-text (make-object text%))
17+
(define output-port (make-text-port output-text))
18+
(define info-text (make-object text%))
19+
(define info-port (make-text-port info-text))
20+
21+
;; assume that there aren't any eq? sub structures, only eq? flat stuff (symbols, etc)
22+
;; this is guaranteed by syntax-object->datum/ht
23+
(define range-start-ht (make-hasheq))
24+
(define range-ht (make-hasheq))
25+
(define original-output-port (current-output-port))
26+
(define (range-pretty-print-pre-hook x v)
27+
(hash-set! range-start-ht x (send output-text last-position)))
28+
(define (range-pretty-print-post-hook x v)
29+
(hash-set! range-ht
30+
x
31+
(cons (cons (hash-ref range-start-ht x) (send output-text last-position))
32+
(hash-ref range-ht x (λ () null)))))
33+
34+
(define (make-modern text)
35+
(send text change-style
36+
(make-object style-delta% 'change-family 'modern)
37+
0
38+
(send text last-position)))
39+
40+
(define dummy
41+
(begin
42+
(pretty-print (syntax->datum original-object) output-port)
43+
(newline output-port)
44+
(parameterize ([current-output-port output-port]
45+
[pretty-print-pre-print-hook range-pretty-print-pre-hook]
46+
[pretty-print-post-print-hook range-pretty-print-post-hook]
47+
[pretty-print-columns 30])
48+
(pretty-print expanded-datum))
49+
(make-modern output-text)))
50+
51+
(define ranges
52+
(sort (apply append (hash-map range-ht (λ (k vs) (map (λ (v) (cons k v)) vs))))
53+
(λ (x y) (<= (- (car (cdr x)) (cdr (cdr x))) (- (car (cdr y)) (cdr (cdr y)))))))
54+
55+
(define (show-info stx)
56+
(fprintf
57+
info-port
58+
"datum: ~s\nsource: ~a\nposition: ~s\noffset: ~s\noriginal: ~s\nbound-in-source: ~s\n\n"
59+
(syntax->datum stx)
60+
(syntax-source stx)
61+
(syntax-position stx)
62+
(syntax-span stx)
63+
(syntax-original? stx)
64+
(syntax-property stx 'bound-in-source))
65+
(let loop ([origin (syntax-property stx 'origin)])
66+
(cond
67+
[(pair? origin)
68+
(loop (car origin))
69+
(loop (cdr origin))]
70+
[(syntax? origin)
71+
(display " " info-port)
72+
(display origin info-port)
73+
(newline info-port)
74+
(fprintf info-port
75+
" original? ~a\n datum:\n ~a\n\n"
76+
(and (syntax? origin) (syntax-original? origin))
77+
(and (syntax? origin) (syntax->datum origin)))]
78+
[else (void)])))
79+
80+
(for-each (λ (range)
81+
(let* ([obj (car range)]
82+
[stx (hash-ref stx-ht obj)]
83+
[start (cadr range)]
84+
[end (cddr range)])
85+
(when (syntax? stx)
86+
(send output-text set-clickback
87+
start
88+
end
89+
(λ _
90+
(send info-text begin-edit-sequence)
91+
(send info-text erase)
92+
(show-info stx)
93+
(make-modern info-text)
94+
(send info-text end-edit-sequence))))))
95+
ranges)
96+
97+
(newline output-port)
98+
(newline output-port)
99+
(let ([before (send output-text last-position)])
100+
(display "all" output-port)
101+
(send output-text set-clickback
102+
before
103+
(send output-text last-position)
104+
(λ _
105+
(send info-text begin-edit-sequence)
106+
(send info-text erase)
107+
(for-each (λ (rng)
108+
(let ([stx (hash-ref stx-ht (car rng))])
109+
(when (syntax? stx)
110+
(show-info stx))))
111+
ranges)
112+
(make-modern info-text)
113+
(send info-text end-edit-sequence))))
114+
115+
(let ()
116+
(define f (make-object frame% "Syntax 'origin Browser" #f 600 300))
117+
(define p (make-object horizontal-panel% f))
118+
(make-object editor-canvas% p output-text)
119+
(make-object editor-canvas% p info-text)
120+
(send f show #t)))
125121

126122
;; build-ht : stx -> hash-table
127123
;; the resulting hash-table maps from the each sub-object's to its syntax.

0 commit comments

Comments
 (0)