1#lang racket/base
2(require "../compile/serialize-property.rkt"
3         "full-binding.rkt"
4         "../common/phase+space.rkt")
5
6(provide make-module-binding
7         module-binding-update
8         module-binding?
9
10         module-binding-module
11         module-binding-phase
12         module-binding-sym
13         module-binding-nominal-module
14         module-binding-nominal-phase+space
15         module-binding-nominal-sym
16         module-binding-nominal-require-phase+space-shift
17         module-binding-extra-inspector
18         module-binding-extra-nominal-bindings
19
20         deserialize-full-module-binding
21         deserialize-simple-module-binding)
22
23;; ----------------------------------------
24
25(define (make-module-binding module phase sym
26                             #:nominal-module [nominal-module module]
27                             #:nominal-phase+space [nominal-phase+space phase]
28                             #:nominal-sym [nominal-sym sym]
29                             #:nominal-require-phase+space-shift [nominal-require-phase+space-shift 0]
30                             #:frame-id [frame-id #f]
31                             #:free=id [free=id #f]
32                             #:extra-inspector [extra-inspector #f]
33                             #:extra-nominal-bindings [extra-nominal-bindings null])
34  (cond
35   [(or frame-id
36        free=id
37        extra-inspector
38        (not (and (eqv? nominal-phase+space phase)
39                  (eq? nominal-sym sym)
40                  (eqv? nominal-require-phase+space-shift 0)
41                  (null? extra-nominal-bindings))))
42    (full-module-binding frame-id
43                         free=id
44                         module phase sym
45                         nominal-module nominal-phase+space nominal-sym
46                         nominal-require-phase+space-shift
47                         extra-inspector
48                         extra-nominal-bindings)]
49   [else
50    (simple-module-binding module phase sym nominal-module)]))
51
52(define (module-binding-update b
53                               #:module [module (module-binding-module b)]
54                               #:phase [phase (module-binding-phase b)]
55                               #:sym [sym (module-binding-sym b)]
56                               #:nominal-module [nominal-module (module-binding-nominal-module b)]
57                               #:nominal-phase+space [nominal-phase+space (module-binding-nominal-phase+space b)]
58                               #:nominal-sym [nominal-sym (module-binding-nominal-sym b)]
59                               #:nominal-require-phase+space-shift [nominal-require-phase+space-shift (module-binding-nominal-require-phase+space-shift b)]
60                               #:frame-id [frame-id (binding-frame-id b)]
61                               #:free=id [free=id (binding-free=id b)]
62                               #:extra-inspector [extra-inspector (module-binding-extra-inspector b)]
63                               #:extra-nominal-bindings [extra-nominal-bindings (module-binding-extra-nominal-bindings b)])
64  (make-module-binding module phase sym
65                       #:nominal-module nominal-module
66                       #:nominal-phase+space nominal-phase+space
67                       #:nominal-sym nominal-sym
68                       #:nominal-require-phase+space-shift nominal-require-phase+space-shift
69                       #:frame-id frame-id
70                       #:free=id free=id
71                       #:extra-inspector extra-inspector
72                       #:extra-nominal-bindings extra-nominal-bindings))
73
74(define (module-binding? b)
75  ;; must not overlap with `local-binding?`
76  (or (simple-module-binding? b)
77      (full-module-binding? b)))
78
79;; See `identifier-binding` docs for information about these fields:
80(struct full-module-binding full-binding (module phase sym
81                                           nominal-module nominal-phase+space nominal-sym
82                                           nominal-require-phase+space-shift
83                                           extra-inspector ; preserves access to protected definitions
84                                           extra-nominal-bindings)
85  #:authentic
86  #:transparent
87  #:property prop:serialize
88  (lambda (b ser-push! state)
89    ;; Dropping the frame id may simplify the representation:
90    (define simplified-b
91      (if (full-binding-frame-id b)
92          (module-binding-update b #:frame-id #f)
93          b))
94    (cond
95      [(full-module-binding? simplified-b)
96       (ser-push! 'tag '#:module-binding)
97       (ser-push! (full-module-binding-module b))
98       (ser-push! (full-module-binding-sym b))
99       (ser-push! (full-module-binding-phase b))
100       (ser-push! (full-module-binding-nominal-module b))
101       (ser-push! (full-module-binding-nominal-phase+space b))
102       (ser-push! (full-module-binding-nominal-sym b))
103       (ser-push! (full-module-binding-nominal-require-phase+space-shift b))
104       (ser-push! (full-binding-free=id b))
105       (if (full-module-binding-extra-inspector b)
106           (ser-push! 'tag '#:inspector)
107           (ser-push! #f))
108       (ser-push! (full-module-binding-extra-nominal-bindings b))]
109      [else
110       (ser-push! simplified-b)])))
111
112(struct simple-module-binding (module phase sym nominal-module)
113  #:authentic
114  #:transparent
115  #:property prop:serialize
116  (lambda (b ser-push! state)
117    (ser-push! 'tag '#:simple-module-binding)
118    (ser-push! (simple-module-binding-module b))
119    (ser-push! (simple-module-binding-sym b))
120    (ser-push! (simple-module-binding-phase b))
121    (ser-push! (simple-module-binding-nominal-module b))))
122
123(define (deserialize-full-module-binding module sym phase
124                                         nominal-module
125                                         nominal-phase+space
126                                         nominal-sym
127                                         nominal-require-phase+space-shift
128                                         free=id
129                                         extra-inspector
130                                         extra-nominal-bindings)
131  (make-module-binding module phase sym
132                       #:nominal-module nominal-module
133                       #:nominal-phase+space (intern-phase+space nominal-phase+space)
134                       #:nominal-sym nominal-sym
135                       #:nominal-require-phase+space-shift (intern-phase+space-shift nominal-require-phase+space-shift)
136                       #:free=id free=id
137                       #:extra-inspector extra-inspector
138                       #:extra-nominal-bindings extra-nominal-bindings))
139
140(define (deserialize-simple-module-binding module sym phase nominal-module)
141  (simple-module-binding module phase sym nominal-module))
142
143;; ----------------------------------------
144
145(define (module-binding-module b)
146  (if (simple-module-binding? b)
147      (simple-module-binding-module b)
148      (full-module-binding-module b)))
149
150(define (module-binding-phase b)
151  (if (simple-module-binding? b)
152      (simple-module-binding-phase b)
153      (full-module-binding-phase b)))
154
155(define (module-binding-sym b)
156  (if (simple-module-binding? b)
157      (simple-module-binding-sym b)
158      (full-module-binding-sym b)))
159
160(define (module-binding-nominal-module b)
161  (if (simple-module-binding? b)
162      (simple-module-binding-nominal-module b)
163      (full-module-binding-nominal-module b)))
164
165(define (module-binding-nominal-phase+space b)
166  (if (simple-module-binding? b)
167      (simple-module-binding-phase b)
168      (full-module-binding-nominal-phase+space b)))
169
170(define (module-binding-nominal-sym b)
171  (if (simple-module-binding? b)
172      (simple-module-binding-sym b)
173      (full-module-binding-nominal-sym b)))
174
175(define (module-binding-nominal-require-phase+space-shift b)
176  (if (simple-module-binding? b)
177      0
178      (full-module-binding-nominal-require-phase+space-shift b)))
179
180(define (module-binding-extra-inspector b)
181  (if (simple-module-binding? b)
182      #f
183      (full-module-binding-extra-inspector b)))
184
185(define (module-binding-extra-nominal-bindings b)
186  (if (simple-module-binding? b)
187      null
188      (full-module-binding-extra-nominal-bindings b)))
189