This repository was archived by the owner on Oct 26, 2023. It is now read-only.
forked from AlexKnauth/debug
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathrepl.rkt
More file actions
108 lines (98 loc) · 3.55 KB
/
repl.rkt
File metadata and controls
108 lines (98 loc) · 3.55 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
#lang racket/base
(provide debug-repl resume)
(require "private/make-variable-like-transformer.rkt"
racket/list
racket/splicing
(for-syntax racket/base
racket/list
syntax/parse
pretty-format
))
(define current-debug-repl-escape (make-parameter #f))
(begin-for-syntax
;; syntax-find-local-variables : Syntax -> (Listof Id)
(define (syntax-find-local-variables stx)
(define debug-info (syntax-debug-info stx (syntax-local-phase-level) #t))
(unless (hash-has-key? debug-info 'bindings)
(pretty-eprintf
(string-append
"warning: debug-repl cannot find the local bindings\n"
" debug-info: ~v\n")
debug-info))
(define context (hash-ref debug-info 'context))
(define bindings (hash-ref debug-info 'bindings '()))
(remove-duplicates
(for/list ([binding (in-list bindings)]
#:when (hash-has-key? binding 'local)
#:when (context-subset? (hash-ref binding 'context) context))
(datum->syntax stx (hash-ref binding 'name) stx))
bound-identifier=?))
;; context-subset? : Context Context -> Boolean
(define (context-subset? a b)
;; TODO: use an actual set-of-scopes subset function
(list-prefix? a b))
;; non-macro-id? : Id -> Boolean
(define NON-MACRO (gensym 'NON-MACRO))
(define (non-macro-id? id)
(eq? NON-MACRO (syntax-local-value id (λ () NON-MACRO))))
)
(define-syntax debug-repl
(lambda (stx)
(syntax-parse stx
[(debug-repl)
#:do [(define all-vars (syntax-find-local-variables stx))
(define-values [xs ms]
(partition non-macro-id? all-vars))]
#:with [x ...] xs
#:with [m ...] ms
#:with [mv ...] (map (λ (m)
(datum->syntax
stx
`(quote ,(syntax-local-value m))))
ms)
#:with varref (syntax-local-introduce #'(#%variable-reference))
#'(debug-repl/varref+hash
varref
(list (list (quote-syntax x) (λ () x)) ...)
(list (list (quote-syntax m) mv) ...))])))
;; debug-repl/varref+hash :
;; Variable-Ref
;; (Listof (List Id (-> Any)))
;; (Listof (List Id Any))
;; ->
;; Any
(define (debug-repl/varref+hash varref var-list macro-list)
(define ns (variable-reference->namespace varref))
(define intro (make-syntax-introducer #true))
(for ([pair (in-list var-list)])
(namespace-define-transformer-binding!
ns
(intro (first pair))
(make-variable-like-transformer #`(#,(second pair)))))
(for ([pair (in-list macro-list)])
(namespace-define-transformer-binding!
ns
(intro (first pair))
(second pair)))
(define old-prompt-read (current-prompt-read))
(define old-eval (current-eval))
(define (new-prompt-read)
(write-char #\-)
(old-prompt-read))
(define (new-eval stx)
(old-eval (intro stx)))
(let/ec k
(parameterize ([current-namespace ns]
[current-prompt-read new-prompt-read]
[current-eval new-eval]
[current-debug-repl-escape k])
(read-eval-print-loop))))
;; namespace-define-transformer-binding! : Namespace Symbol Any -> Void
(define (namespace-define-transformer-binding! ns sym val)
(eval #`(define-syntax #,(datum->syntax #f sym) #,val) ns))
;; resume : Any ... -> Nothing
(define (resume . vs)
(define k (current-debug-repl-escape))
(unless k
(error 'resume "must be called within a debug-repl"))
(apply k vs))