www

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

context.rkt (3854B)

      1 #lang racket/base
      2 (require syntax/stx
      3          "stx-util.rkt")
      4 (provide (struct-out ref)
      5          (struct-out tail)
      6          path-get
      7          pathseg-get
      8          path-replace
      9          pathseg-replace)
     10 
     11 ;; A Path is a (list-of PathSeg)
     12 ;; where the PathSegs are listed outermost to innermost
     13 ;; for example: (path-get #'((a b) (c d)) (list (make-ref 0) (make-ref 1))) = #'b, not #'c
     14 
     15 ;; A PathSeg is one of:
     16 ;;   - (make-ref number)
     17 ;;   - (make-tail number)
     18 
     19 (define-struct pathseg () #:transparent)
     20 (define-struct (ref pathseg) (n) #:transparent)
     21 (define-struct (tail pathseg) (n) #:transparent)
     22 
     23 ;; path-get : syntax Path -> syntax
     24 (define (path-get stx path)
     25   (let loop ([stx stx] [path path])
     26     (cond [(null? path) stx]
     27           [(pair? path)
     28            (loop (pathseg-get stx (car path)) (cdr path))]
     29           [else
     30            (error 'path-get "bad path: ~s" path)])))
     31 
     32 ;; pathseg-get : syntax PathSeg -> syntax
     33 (define (pathseg-get stx path)
     34   (cond [(ref? path) (pathseg-get/ref stx (ref-n path))]
     35         [(tail? path) (pathseg-get/tail stx (tail-n path))]))
     36 
     37 ;; pathseg-get/ref : syntax number -> syntax
     38 (define (pathseg-get/ref stx0 n0)
     39   (let loop ([n n0] [stx stx0])
     40     (unless (stx-pair? stx)
     41       (error 'pathseg-get "ref path out of bounds for syntax: ~s, ~s" 
     42              n0
     43              (syntax->datum stx0)))
     44     (if (zero? n)
     45         (stx-car* stx)
     46         (loop (sub1 n) (stx-cdr* stx)))))
     47 
     48 ;; pathseg-get/tail : syntax number -> syntax
     49 (define (pathseg-get/tail stx0 n0)
     50   (let loop ([n n0] [stx stx0])
     51     (unless (stx-pair? stx)
     52       (error 'pathseg-get "tail path out of bounds for syntax: ~s, ~s" n0 stx0))
     53     (if (zero? n)
     54         (stx-cdr* stx)
     55         (loop (sub1 n) (stx-cdr* stx)))))
     56 
     57 ;; path-replace : syntax Path syntax -> syntax
     58 (define (path-replace stx path x)
     59   (cond [(null? path) x]
     60         [(pair? path)
     61          (let ([pathseg0 (car path)])
     62            (pathseg-replace stx
     63                             pathseg0
     64                             (path-replace (pathseg-get stx pathseg0)
     65                                           (cdr path)
     66                                           x)))]
     67         [else
     68          (error 'path-replace "bad path: ~s" path)]))
     69 
     70 ;; pathseg-replace : syntax PathSeg syntax -> syntax
     71 (define (pathseg-replace stx pathseg x)
     72   (cond [(ref? pathseg) (pathseg-replace/ref stx (ref-n pathseg) x)]
     73         [(tail? pathseg) (pathseg-replace/tail stx (tail-n pathseg) x)]
     74         [else (error 'pathseg-replace "bad path: ~s" pathseg)]))
     75 
     76 ;; pathseg-replace/ref : syntax number syntax -> syntax
     77 (define (pathseg-replace/ref stx0 n0 x)
     78   (let loop ([n n0] [stx stx0])
     79     (unless (stx-pair? stx)
     80       (error 'pathseg-replace "ref path out of bounds for syntax: ~s, ~s" n0 stx0))
     81     (if (zero? n)
     82         (stx-replcar stx x)
     83         (stx-replcdr stx (loop (sub1 n) (stx-cdr* stx))))))
     84 
     85 ;; pathseg-replace/tail : syntax number syntax -> syntax
     86 (define (pathseg-replace/tail stx0 n0 x)
     87   (let loop ([n n0] [stx stx0])
     88     (unless (stx-pair? stx)
     89       (error 'pathseg-replace "tail path out of bounds for syntax: ~s, ~s" n0 stx0))
     90     (if (zero? n)
     91         (stx-replcdr stx x)
     92         (stx-replcdr stx (loop (sub1 n) (stx-cdr* stx))))))
     93 
     94 ;; stx-replcar : syntax syntax -> syntax
     95 (define (stx-replcar stx x)
     96   (cond [(pair? stx)
     97          (cons x (cdr stx))]
     98         [(syntax? stx)
     99          (syntax-rearm
    100           (datum->syntax stx (cons x (cdr (syntax-e stx))) stx stx)
    101           stx)]
    102         [else (raise-type-error 'stx-replcar "stx-pair" stx)]))
    103 
    104 ;; stx-replcdr : syntax syntax -> syntax
    105 (define (stx-replcdr stx x)
    106   (cond [(pair? stx)
    107          (cons (car stx) x)]
    108         [(and (syntax? stx) (pair? (syntax-e stx)))
    109          (syntax-rearm
    110           (datum->syntax stx (cons (car (syntax-e stx)) x) stx stx)
    111           stx)]
    112         [else (raise-type-error 'stx-replcdr "stx-pair" stx)]))