dispatch/syntax-info.ss at master · untyped/dispatch · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
#lang scheme/base

(require "base.ss")

(require syntax/boundmap)

; Variables --------------------------------------

(define-struct site-info
  (id private-id controller-ids)
  #:transparent
  #:property
  prop:procedure
  (lambda (info stx)
    (syntax-case stx ()
      [id (identifier? #'id) (site-info-private-id info)])))

(define info-cache (make-module-identifier-mapping))

; Procedures -------------------------------------

; site-info -> site-info
(define (site-info-add! info)
  (module-identifier-mapping-put! info-cache (site-info-id info) info)
  info)

; identifier -> boolean
(define (site-info-set? id)
  (with-handlers ([exn? (lambda _ #f)])
    (module-identifier-mapping-get info-cache id)
    #t))

; identifier -> site-info
(define (site-info-ref id)
  (module-identifier-mapping-get info-cache id))

; Provide statements -----------------------------

(provide (struct-out site-info))

(provide/contract
 [site-info-add! (-> site-info? site-info?)]
 [site-info-set? (-> identifier? boolean?)]
 [site-info-ref  (-> identifier? (or/c site-info? #f))])