170 lines
6.5 KiB
Racket
170 lines
6.5 KiB
Racket
|
#lang racket/base
|
||
|
|
|
||
|
|
(require (only-in macro-debugger/stepper-text
|
||
|
|
stepper-text)
|
||
|
|
racket/contract
|
||
|
|
racket/file
|
||
|
|
racket/format
|
||
|
|
racket/match
|
||
|
|
(only-in racket/path
|
||
|
|
path-only)
|
||
|
|
racket/pretty
|
||
|
|
racket/system
|
||
|
|
"../elisp.rkt"
|
||
|
|
"../repl.rkt"
|
||
|
|
"../syntax.rkt"
|
||
|
|
"../util.rkt")
|
||
|
|
|
||
|
|
(provide macro-stepper
|
||
|
|
macro-stepper/next)
|
||
|
|
|
||
|
|
(define step/c (cons/c (or/c 'original string? 'final) string?))
|
||
|
|
(define step-proc/c (-> (or/c 'next 'all) (listof step/c)))
|
||
|
|
(define step-proc #f)
|
||
|
|
|
||
|
|
(define/contract (make-expr-stepper str)
|
||
|
|
(-> string? step-proc/c)
|
||
|
|
(unless (current-session-id)
|
||
|
|
(error 'make-expr-stepper "Does not work without a running REPL"))
|
||
|
|
(define step-num #f)
|
||
|
|
(define last-stx (string->namespace-syntax str))
|
||
|
|
(define/contract (step what) step-proc/c
|
||
|
|
(cond [(not step-num)
|
||
|
|
(set! step-num 0)
|
||
|
|
(list (cons 'original
|
||
|
|
(pretty-format-syntax last-stx)))]
|
||
|
|
[else
|
||
|
|
(define result
|
||
|
|
(let loop ()
|
||
|
|
(define this-stx (expand-once last-stx))
|
||
|
|
(cond [(equal? (syntax->datum last-stx)
|
||
|
|
(syntax->datum this-stx))
|
||
|
|
(cond [(eq? what 'all)
|
||
|
|
(list (cons 'final
|
||
|
|
(pretty-format-syntax this-stx)))]
|
||
|
|
[else (list)])]
|
||
|
|
[else
|
||
|
|
(set! step-num (add1 step-num))
|
||
|
|
(define step
|
||
|
|
(cons (~a step-num ": expand-once")
|
||
|
|
(diff-text (pretty-format-syntax last-stx)
|
||
|
|
(pretty-format-syntax this-stx)
|
||
|
|
#:unified 3)))
|
||
|
|
(set! last-stx this-stx)
|
||
|
|
(cond [(eq? what 'all) (cons step (loop))]
|
||
|
|
[else (list step)])])))
|
||
|
|
(match result
|
||
|
|
[(list) (list (cons 'final
|
||
|
|
(pretty-format-syntax last-stx)))]
|
||
|
|
[v v])]))
|
||
|
|
step)
|
||
|
|
|
||
|
|
(define/contract (make-file-stepper path into-base?)
|
||
|
|
(-> (and/c path-string? absolute-path?) boolean? step-proc/c)
|
||
|
|
(assert-file-stepper-works)
|
||
|
|
(define stx (file->syntax path))
|
||
|
|
(define dir (path-only path))
|
||
|
|
(define ns (make-base-namespace))
|
||
|
|
(define raw-step (parameterize ([current-load-relative-directory dir]
|
||
|
|
[current-namespace ns])
|
||
|
|
(stepper-text stx
|
||
|
|
(if into-base? (λ _ #t) (not-in-base)))))
|
||
|
|
(define step-num #f)
|
||
|
|
(define step-last-after "")
|
||
|
|
(log-racket-mode-debug "~v ~v ~v" path into-base? raw-step)
|
||
|
|
(define/contract (step what) step-proc/c
|
||
|
|
(cond [(not step-num)
|
||
|
|
(set! step-num 0)
|
||
|
|
(list (cons 'original
|
||
|
|
(pretty-format-syntax stx)))]
|
||
|
|
[else
|
||
|
|
(define out (open-output-string))
|
||
|
|
(cond [(parameterize ([current-output-port out])
|
||
|
|
(raw-step what))
|
||
|
|
(log-racket-mode-debug "~v" (get-output-string out))
|
||
|
|
(define in (open-input-string (get-output-string out)))
|
||
|
|
(let loop ()
|
||
|
|
(match (parameterize ([current-input-port in])
|
||
|
|
(read-step))
|
||
|
|
[(? eof-object?)
|
||
|
|
(cond [(eq? what 'all)
|
||
|
|
(list (cons 'final step-last-after))]
|
||
|
|
[else (list)])]
|
||
|
|
[(list title before after)
|
||
|
|
(set! step-num (add1 step-num))
|
||
|
|
(set! step-last-after after)
|
||
|
|
(cons (cons (~a step-num ": " title)
|
||
|
|
(diff-text before after #:unified 3))
|
||
|
|
(loop))]))]
|
||
|
|
[else
|
||
|
|
(list (cons 'final step-last-after))])]))
|
||
|
|
step)
|
||
|
|
|
||
|
|
(define (read-step)
|
||
|
|
(define title (read-line))
|
||
|
|
(define before (read))
|
||
|
|
(define _arrow (read)) ; '==>
|
||
|
|
(define after (read))
|
||
|
|
(read-line)
|
||
|
|
(match (read-line)
|
||
|
|
[(? eof-object? e) e]
|
||
|
|
[_ (list title
|
||
|
|
(pretty-format #:mode 'write before)
|
||
|
|
(pretty-format #:mode 'write after))]))
|
||
|
|
|
||
|
|
(define (assert-file-stepper-works)
|
||
|
|
(define step (stepper-text #'(module example racket/base 42)))
|
||
|
|
(unless (step 'next)
|
||
|
|
(error 'macro-debugger/stepper-text
|
||
|
|
"does not work in your version of Racket.\nPlease try an older or newer version.")))
|
||
|
|
|
||
|
|
(define/contract (macro-stepper what into-base?)
|
||
|
|
(-> (or/c (cons/c 'expr string?) (cons/c 'file path-string?)) elisp-bool/c
|
||
|
|
(list/c step/c))
|
||
|
|
(set! step-proc
|
||
|
|
(match what
|
||
|
|
[(cons 'expr str) (make-expr-stepper str)]
|
||
|
|
[(cons 'file path) (make-file-stepper path (as-racket-bool into-base?))]))
|
||
|
|
(macro-stepper/next 'next))
|
||
|
|
|
||
|
|
(define/contract (macro-stepper/next what) step-proc/c
|
||
|
|
(unless step-proc
|
||
|
|
(error 'macro-stepper "Nothing to expand"))
|
||
|
|
(define v (step-proc what))
|
||
|
|
(match v
|
||
|
|
[(list (cons 'final _)) (set! step-proc #f)]
|
||
|
|
[_ (void)])
|
||
|
|
v)
|
||
|
|
|
||
|
|
;; Borrowed from xrepl.
|
||
|
|
(define not-in-base
|
||
|
|
(λ () (let ([base-stxs #f])
|
||
|
|
(unless base-stxs
|
||
|
|
(set! base-stxs ; all ids that are bound to a syntax in racket/base
|
||
|
|
(parameterize ([current-namespace (make-base-namespace)])
|
||
|
|
(let-values ([(vals stxs) (module->exports 'racket/base)])
|
||
|
|
(map (λ (s) (namespace-symbol->identifier (car s)))
|
||
|
|
(cdr (assq 0 stxs)))))))
|
||
|
|
(λ (id) (not (ormap (λ (s) (free-identifier=? id s)) base-stxs))))))
|
||
|
|
|
||
|
|
(define (diff-text before-text after-text #:unified [-U 3])
|
||
|
|
(define template "racket-mode-syntax-diff-~a")
|
||
|
|
(define (make-temporary-file-with-text str)
|
||
|
|
(define file (make-temporary-file template))
|
||
|
|
(with-output-to-file file #:mode 'text #:exists 'replace
|
||
|
|
(λ () (displayln str)))
|
||
|
|
file)
|
||
|
|
(define before-file (make-temporary-file-with-text before-text))
|
||
|
|
(define after-file (make-temporary-file-with-text after-text))
|
||
|
|
(define out (open-output-string))
|
||
|
|
(begin0 (parameterize ([current-output-port out])
|
||
|
|
(system (format "diff -U ~a ~a ~a" -U before-file after-file))
|
||
|
|
(match (get-output-string out)
|
||
|
|
["" " <empty diff>\n"]
|
||
|
|
[(pregexp "\n(@@.+@@\n.+)$" (list _ v)) v]))
|
||
|
|
(delete-file before-file)
|
||
|
|
(delete-file after-file)))
|
||
|
|
|
||
|
|
(define (pretty-format-syntax stx)
|
||
|
|
(pretty-format #:mode 'write (syntax->datum stx)))
|