www

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

main.rkt (4439B)

      1 #lang racket
      2 
      3 (provide scopes/c
      4          →scopes
      5          →scopes*
      6          (rename-out [→scopes ->scopes]
      7                      [→scopes* ->scopes*])
      8          empty-scopes
      9          empty-scopes-syntax
     10          scopes-add
     11          scopes-remove
     12          scopes-flip
     13          scopes-intersect
     14          (rename-out [scopes-flip scopes-symmetric-difference])
     15          single-scope?
     16          zero-scopes?
     17          scopes-equal?
     18          scope-kind
     19          use-site-scope?
     20          macro-scope?
     21          module-scope?
     22          intdef-scope?
     23          local-scope?
     24          top-scope?
     25          all-scopes-in?
     26          any-scope-in?)
     27 
     28 (define scopes/c
     29   (->* (syntax?) ([or/c 'add 'remove 'flip]) syntax?))
     30 
     31 (define/contract empty-scopes-syntax
     32   syntax?
     33   (datum->syntax #f 'zero))
     34 
     35 (define/contract (→scopes stx)
     36   (-> syntax? scopes/c)
     37   (make-syntax-delta-introducer (datum->syntax stx 'stx)
     38                                 empty-scopes-syntax))
     39 
     40 (define/contract empty-scopes
     41   scopes/c
     42   (→scopes empty-scopes-syntax))
     43 
     44 (define/contract (→scopes* stx)
     45   (-> (or/c syntax? scopes/c) scopes/c)
     46   (if (syntax? stx)
     47       (→scopes stx)
     48       stx))
     49 
     50 (define/contract (scopes-add sc1 sc2)
     51   (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
     52   (→scopes ((→scopes* sc1) ((→scopes* sc2) empty-scopes-syntax)
     53                            'add)))
     54 
     55 (define/contract (scopes-remove sc1 sc2)
     56   (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
     57   (→scopes ((→scopes* sc1) ((→scopes* sc2) empty-scopes-syntax)
     58                            'remove)))
     59 
     60 (define/contract (scopes-flip sc1 sc2)
     61   (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
     62   (→scopes ((→scopes* sc1) ((→scopes* sc2) empty-scopes-syntax)
     63                            'flip)))
     64 
     65 (define/contract (scopes-intersect sc1 sc2)
     66   (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
     67   (scopes-remove sc1 (scopes-remove sc1 sc2)))
     68 
     69 #;(define/contract (scopes-symmetric-difference sc1 sc2)
     70     (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
     71     (scopes-add (scopes-remove sc1 sc2)
     72                 (scopes-remove sc2 sc1)))
     73 
     74 (define/contract (single-scope? sc)
     75   (-> (or/c syntax? scopes/c) boolean?)
     76   (= (length (hash-ref (syntax-debug-info
     77                         ((→scopes* sc) empty-scopes-syntax))
     78                        'context))
     79      1))
     80 
     81 (define/contract (zero-scopes? sc)
     82   (-> (or/c syntax? scopes/c) boolean?)
     83   (= (length (hash-ref (syntax-debug-info
     84                         ((→scopes* sc) empty-scopes-syntax))
     85                        'context))
     86      0))
     87 
     88 (define/contract (scopes-equal? sc1 sc2)
     89   (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) boolean?)
     90   (bound-identifier=? ((→scopes* sc1) empty-scopes-syntax)
     91                       ((→scopes* sc2) empty-scopes-syntax)))
     92 
     93 (define/contract (scope-kind sc)
     94   (-> (and/c (or/c syntax? scopes/c) single-scope?) symbol?)
     95   (define stx ((→scopes* sc) empty-scopes-syntax))
     96   (vector-ref (list-ref (hash-ref (syntax-debug-info stx) 'context) 0) 1))
     97 
     98 (define/contract (use-site-scope? sc)
     99   (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
    100   (eq? (scope-kind sc) 'use-site))
    101 
    102 (define/contract (macro-scope? sc)
    103   (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
    104   (eq? (scope-kind sc) 'macro))
    105 
    106 (define/contract (module-scope? sc)
    107   (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
    108   (eq? (scope-kind sc) 'module))
    109 
    110 (define/contract (intdef-scope? sc)
    111   (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
    112   (eq? (scope-kind sc) 'intdef))
    113 
    114 (define/contract (local-scope? sc)
    115   (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
    116   (eq? (scope-kind sc) 'local))
    117 
    118 ;; This appears on the #'module identifier itself, when expanding a module
    119 ;; Run the macro stepper on an empty #lang racket program, and click on the
    120 ;; #'module identifier, then on the "syntax object" tab to see it.
    121 ;; (Stepper → View syntax properties to enable the "syntax object" tab).
    122 (define/contract (top-scope? sc)
    123   (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
    124   (eq? (scope-kind sc) 'top))
    125 
    126 (define/contract (all-scopes-in? sc1 sc2)
    127   (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) boolean?)
    128   (zero-scopes? (scopes-remove sc2 sc1)))
    129 
    130 (define/contract (any-scope-in? sc1 sc2)
    131   (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) boolean?)
    132   (not (zero-scopes? (scopes-intersect sc1 sc2))))