46 lines
1.3 KiB
Racket
46 lines
1.3 KiB
Racket
#lang racket/base
|
|
(require racket/contract/base)
|
|
|
|
(define current-expand-observe
|
|
(dynamic-require ''#%expobs 'current-expand-observe))
|
|
|
|
(define (emit-remark #:unmark? [unmark? (syntax-transforming?)] . args)
|
|
(let ([observe (current-expand-observe)])
|
|
(when observe
|
|
(let ([args (flatten-emit-args args unmark?)])
|
|
(observe 'local-remark args)))))
|
|
|
|
(define (emit-local-step before after #:id id)
|
|
(let ([observe (current-expand-observe)])
|
|
(when observe
|
|
(observe 'local-artificial-step
|
|
(list (list id)
|
|
before (syntax-local-introduce before)
|
|
(syntax-local-introduce after) after)))))
|
|
|
|
(define emit-arg/c
|
|
(recursive-contract
|
|
(or/c string?
|
|
syntax?
|
|
(listof emit-arg/c)
|
|
(-> emit-arg/c))))
|
|
|
|
(define (flatten-emit-args x unmark?)
|
|
(define (loop x onto)
|
|
(cond [(string? x)
|
|
(cons x onto)]
|
|
[(syntax? x)
|
|
(cons (if unmark? (syntax-local-introduce x) x) onto)]
|
|
[(list? x)
|
|
(foldr loop onto x)]
|
|
[(procedure? x)
|
|
(loop (x) onto)]))
|
|
(loop x null))
|
|
|
|
(provide/contract
|
|
[emit-remark
|
|
(->* () (#:unmark? any/c) #:rest (listof emit-arg/c)
|
|
any)]
|
|
[emit-local-step
|
|
(-> syntax? syntax? #:id identifier? any)])
|