www

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs

emit.rkt (1293B)

      1 #lang racket/base
      2 (require racket/contract/base)
      3 
      4 (define current-expand-observe
      5   (dynamic-require ''#%expobs 'current-expand-observe))
      6 
      7 (define (emit-remark #:unmark? [unmark? (syntax-transforming?)] . args)
      8   (let ([observe (current-expand-observe)])
      9     (when observe
     10       (let ([args (flatten-emit-args args unmark?)])
     11         (observe 'local-remark args)))))
     12 
     13 (define (emit-local-step before after #:id id)
     14   (let ([observe (current-expand-observe)])
     15     (when observe
     16       (observe 'local-artificial-step
     17                (list (list id)
     18                      before (syntax-local-introduce before)
     19                      (syntax-local-introduce after) after)))))
     20 
     21 (define emit-arg/c
     22   (recursive-contract
     23    (or/c string?
     24          syntax?
     25          (listof emit-arg/c)
     26          (-> emit-arg/c))))
     27 
     28 (define (flatten-emit-args x unmark?)
     29   (define (loop x onto)
     30     (cond [(string? x)
     31            (cons x onto)]
     32           [(syntax? x)
     33            (cons (if unmark? (syntax-local-introduce x) x) onto)]
     34           [(list? x)
     35            (foldr loop onto x)]
     36           [(procedure? x)
     37            (loop (x) onto)]))
     38   (loop x null))
     39 
     40 (provide/contract
     41  [emit-remark
     42   (->* () (#:unmark? any/c) #:rest (listof emit-arg/c)
     43        any)]
     44  [emit-local-step
     45   (-> syntax? syntax? #:id identifier? any)])