Simple debugger-like thing

gistfile1.rkt

#lang racket

(require racket/control
         gui-debugger/annotator)

(provide debug step! set-breakpoint!)

;; original and annotated syntax objects
(define orig-stx #f)
(define ann-stx #f)
;; break on these ids
(define break-ids '())

;; current debugging information
(define cur-info #f)
(define cur-marks #f)

;; continuation to resume
(define resume #f)

;; to determine if we need to break
(define ((break? src) pos)
  (ormap (λ (id) (get-app-at-pos pos id orig-stx))
         break-ids))

(define (get-app-at-pos pos id stx)
  (cond [(and (= pos (syntax-position stx)) (app-of id stx)) stx]
        [else
         (define subs (syntax->list stx))
         (and subs
              (foldl (λ (stx acc) (or (get-app-at-pos pos id stx) acc))
                     #f subs))]))

(define (app-of id stx)
  (syntax-case stx ()
    [(id2 e ...)
     (and (identifier? #'id2)
          (free-identifier=? id #'id2))
     #t]
    [_ #f]))

(define (debug stx)
  (define-values (new-stx breakpoints)
    (annotate-for-single-stepping
     (expand-syntax stx)
     break?
     ;; set current debugging info and set the continuation
     ;; so that step! can renew it
     (λ (debug-info marks)
       (printf "hit breakpoint, what next?~n")
       (set! cur-info debug-info)
       (set! cur-marks marks)
       (control k (set! resume k)))
     ;; no-op
     (λ (debug-info marks val) val)
     ;; record-bound-identifier - use this to construct env
     (lambda (type bound binding)
       (void))
     ;; record-top-level-identifier - similarly
     (lambda (mod var rd/wr)
       (void))))
  (set! orig-stx stx)
  (set! ann-stx new-stx)
  (eval new-stx))

(define (step!)
  (if (not resume)
      (printf "no expression set for debugging~n")
      (and resume (resume #f))))

(define (set-breakpoint! stx)
  (unless (identifier? stx)
    (raise-syntax-error 'set-breakpoint! "expected an identifier" stx))
  (set! break-ids (cons stx break-ids)))