├── .gitignore └── mini-ml-lib ├── info.rkt └── mini-ml ├── private ├── extract.rkt ├── namespace.rkt └── util │ ├── syntax.rkt │ └── syntax │ ├── class │ └── module-path.rkt │ ├── misc.rkt │ └── require-scope.rkt └── system-f.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | doc/ 3 | *~ 4 | -------------------------------------------------------------------------------- /mini-ml-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps 6 | '("base" 7 | "syntax-classes-lib" 8 | "syntax-generic2" 9 | "threading-lib")) 10 | (define build-deps 11 | '()) 12 | -------------------------------------------------------------------------------- /mini-ml-lib/mini-ml/private/extract.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ; This module defines the building blocks needed to implement /program extraction/, the system by 4 | ; which a language’s custom intermediate representation is translated into Racket core forms. For the 5 | ; most part, this process is direct: extraction is mostly implemented via straightforward, mechanical 6 | ; translation of the custom language’s core forms into their Racket equivalents — custom language 7 | ; definitions become Racket definitions, and custom language expressions become Racket expressions. 8 | ; 9 | ; There are, however, a few subtleties that make the process more complicated. Broadly speaking, there 10 | ; are two significant problems that arise from a naïve approach to program extraction. 11 | ; 12 | ; 1. Avoiding duplication of compile-time effects. When a program includes phase 1 (or higher) code, 13 | ; in some way or another, the code is evaluated during the compilation of the program. Often, we 14 | ; imagine this code as “disappearing” after it is evaluated — macros are expanded leaving a 15 | ; macro-free program behind — but this is not always true. Module-level macro /definitions/ are 16 | ; not “erased” in this sense, since they must be available to other modules that import them. 17 | ; Therefore, some compile-time code may, indeed, be left behind in a fully-expanded program. 18 | ; 19 | ; It is this non-erased code that can cause trouble. The code must be evaluated during expansion 20 | ; of the program, yet it must /also/ be left behind in the expanded code. Ordinarily, the Racket 21 | ; macroexpander will re-evaluate this fully-expanded code as it traverses the module’s expansion 22 | ; a final time, and if the code has any side effects, this can lead to disaster. It will be 23 | ; evaluated twice — once during the custom expansion process, and a second time during the Racket 24 | ; expander’s final pass — leading to an unwanted duplication of effects. 25 | ; 26 | ; The solution to this is /suspension/. We arrange for the evaluation of compile-time code to be 27 | ; skipped (or “suspended”) during the Racket expander’s final pass, avoiding the duplication of 28 | ; effects, but we ensure the code will still be re-evaluated on future visits to the module. The 29 | ; machinery involved in this process is described later in this module, at the top of the section 30 | ; that implements it. 31 | ; 32 | ; 2. Cooperation with Check Syntax. DrRacket’s Check Syntax tool (which is also used by other 33 | ; tooling) is designed to extract static information about the structure of a module and present 34 | ; it to the programmer to help them reason, explore, and structurally modify their program. 35 | ; Compared to other programming languages, this is an especially daunting task in Racket: macros 36 | ; can contort the program in any number of ways, so a development environment has no way of 37 | ; knowing what any identifier in the program is even bound to without running arbitrary Racket 38 | ; code. 39 | ; 40 | ; To make Check Syntax’s task more tractable, the macroexpander cooperates by leaving information 41 | ; behind about where pieces of syntax in a fully-expanded program came from. This is done through 42 | ; a collection of syntax properties: 'origin, 'disappeared-use, 'disappeared-binding, and 43 | ; 'sub-range-binders. While the expander introduces some of these properties automatically, and 44 | ; for most ordinary programs, the automatic mechanisms in place are enough for Check Syntax to 45 | ; work well, the complexity of understanding the structure of a custom language requires some 46 | ; extra cooperation on the part of the language author. 47 | ; 48 | ; For simple cases, like when a macro inspects the transformer binding of an identifier or 49 | ; matches an identifier literally, syntax/parse is capable of adding the necessary residual 50 | ; properties automatically. However, for more complicated situations, additional care is needed. 51 | ; Types are an example of one such situation, as they are erased in the extracted program. Care 52 | ; must be taken to ensure that not only is the binding structure of the types themselves 53 | ; preserved for Check Syntax, but the properties already present on the types (due to 54 | ; macroexpansion at the type level) are also preserved. This module provides some simple 55 | ; functions to make it easier to get things right. 56 | ; 57 | ; This module provides utilities to make solving both of the above two problems simpler. 58 | 59 | (require (for-meta 2 racket/base) 60 | (for-syntax racket/base 61 | racket/contract 62 | racket/list 63 | racket/syntax 64 | syntax/id-set 65 | syntax/parse/define 66 | threading 67 | "util/syntax.rkt") 68 | syntax/parse/define) 69 | 70 | (begin-for-syntax 71 | (provide (contract-out 72 | ; suspension 73 | [suspenders? (-> any/c boolean?)] 74 | [make-suspenders (-> suspenders?)] 75 | [current-suspenders (parameter/c (or/c suspenders? #f))] 76 | [suspend-expression (->* [syntax?] 77 | [suspenders? 78 | #:phase exact-positive-integer? 79 | #:values exact-nonnegative-integer?] 80 | syntax?)] 81 | [suspend-racket-decl (->* [syntax?] 82 | [suspenders? 83 | #:phase exact-positive-integer?] 84 | syntax?)] 85 | [suspenders->racket-decl (->* [] [suspenders?] syntax?)] 86 | 87 | ; residual 88 | [residual? (-> any/c boolean?)] 89 | [make-residual (->* [] 90 | [(listof residual?) 91 | #:origin (or/c syntax? #f) 92 | #:uses (listof identifier?) 93 | #:bindings (listof identifier?) 94 | #:flip-scopes? any/c] 95 | residual?)] 96 | [syntax-track-residual (-> syntax? residual? syntax?)]))) 97 | 98 | ;; --------------------------------------------------------------------------------------------------- 99 | ;; suspension 100 | 101 | ; The process of suspension described at the top of this module is implemented in a conceptually 102 | ; simple way: 103 | ; 104 | ; 1. We keep track whether the current module is being expanded or if it is being visited. 105 | ; 106 | ; 2. We wrap all compile-time expressions in conditional expressions that only evaluate the 107 | ; expression in the second case (when the module is being visited) but not the first (when the 108 | ; module is being expanded). 109 | ; 110 | ; In practice, implementing this is more involved than it sounds. 111 | ; 112 | ; To keep track of whether or not the module is currently being expanded, we can define a compile-time 113 | ; variable, `is-suspended?`, which is initialized to `#f`. We then insert the form 114 | ; 115 | ; (let-syntax ([_ (set! is-suspended? #t)]) (void)) 116 | ; 117 | ; into the body of the module. This will cause the `is-suspended?` variable to be set to `#t` when the 118 | ; `let-syntax` form is expanded, but since the compile-time parts of `let-syntax` are erased in its 119 | ; expansion, the effect will /not/ be performed when the module is visited. We can then instrument 120 | ; expressions inside `define-syntaxes` or `begin-for-syntax` forms to conditionally branch upon the 121 | ; value of the `is-suspended?` variable. 122 | ; 123 | ; However, even this is not enough. Since `begin-for-syntax` forms may be nested, we actually need 124 | ; /several/ `is-suspended?` variables, one at each phase. Likewise, we need to `set!` each of these 125 | ; variables at the relevant phase. For example, for a module that has compile-time code at both 126 | ; phase 1 and phase 2, we want to produce the following declarations: 127 | ; 128 | ; (begin-for-syntax 129 | ; (define is-suspended?/1 #f) 130 | ; (begin-for-syntax 131 | ; (define is-suspended?/2 #f))) 132 | ; 133 | ; (let-syntax ([_ (begin 134 | ; (set! is-suspended?/1 #t) 135 | ; (let-syntax ([_ (set! is-suspended?/2 #t)]) (void)))]) 136 | ; (void)) 137 | ; 138 | ; The generation of these declarations is managed by /suspenders/. A set of suspenders, created with 139 | ; `make-suspenders`, encapsulates a mapping from compile-time phase levels to `is-suspended?` 140 | ; identifiers. The `suspend-expression` function generates a suspended version of an expression at a 141 | ; given phase, and it records in the set of suspenders which phases include suspended expressions. 142 | ; Likewise, the `suspend-racket-decl` function is like `suspend-expression`, except that it handles 143 | ; compile-time declarations, including nested uses of `begin-for-syntax`. The 144 | ; `suspenders->racket-decl` function generates the appropriate declaration of the above shape using 145 | ; the information recorded by calls to `suspend-expression` and `suspend-racket-decl`. 146 | 147 | ; When `suspenders->racket-decl generates a set of nested `let-syntax` forms, as described above, 148 | ; the form cannot actually be directly inserted into a module as-is. The reason for this is that 149 | ; the Racket expander attempts to expand module-level expressions last, after all `define-syntaxes` 150 | ; and `begin-for-syntax` forms have already been expanded. This is a problem, since it will delay the 151 | ; necessary side-effects until the compile-time expressions have already been evaluated, which is too 152 | ; late. This macro forces the expansion of the `let-syntax` forms as soon as it is expanded, 153 | ; intentionally defeating the expander’s partial expansion of module-level expressions, ensuring the 154 | ; side-effects occur when necessary. 155 | (define-simple-macro (force-expansion e:expr) 156 | #:do [(local-expand #'e 'expression '())] 157 | (begin)) 158 | 159 | (begin-for-syntax 160 | (struct suspenders (ids)) 161 | 162 | (define (make-suspenders) 163 | (suspenders (make-hasheqv))) 164 | 165 | (define current-suspenders (make-parameter #f)) 166 | 167 | (define (is-suspended?-id phase [suspenders (current-suspenders)]) 168 | (hash-ref! (suspenders-ids suspenders) phase (lambda () (generate-temporary 'is-suspended?)))) 169 | 170 | ; When generating expressions at arbitrary phases, we have to be careful to arrange for the 171 | ; identifiers we introduce to actually be bound at the appropriate phase. To do this, we apply 172 | ; `syntax-shift-phase-level` to any pieces of syntax we introduce. We have to be careful, however, 173 | ; to restrict ourselves to introducing identifiers bound in '#%kernel, since otherwise, it’s 174 | ; possible the relevant module won’t actually be instantiated at the correct phase. 175 | ; 176 | ; Performing this shifting is noisy, so the `quasishift` macro helps to avoid the noise. It is like 177 | ; `quasisyntax`, except that the resulting syntax object is phase shifted. Syntax objects 178 | ; interpolated into the template using `unsyntax` or `unsytax-splicing` are /not/ shifted, which 179 | ; ensures the original expressions’ phases are left untouched. 180 | ; 181 | ; To interpolate syntax that /should/ be shifted into a template defined using `quasisyntax`, use 182 | ; syntax pattern variables instead of `unsyntax` or `unsyntax-splicing`, since these will be shifted 183 | ; along with the rest of the syntax object. 184 | (define-syntax-parser quasishift 185 | [(_ phase-shift-e:expr template) 186 | #:with shifting-template (let loop ([stx #'template]) 187 | (syntax-parse stx 188 | #:literals [unsyntax unsyntax-splicing] 189 | [(unsyntax ~! e:expr) 190 | #'#,(antishift e)] 191 | [(unsyntax-splicing ~! e:expr) 192 | #'#,@(map antishift e)] 193 | [(a ...+ . b) 194 | (datum->syntax this-syntax 195 | (append (map loop (attribute a)) (loop #'b)) 196 | this-syntax 197 | this-syntax)] 198 | [_ 199 | this-syntax])) 200 | #`(let* ([phase-shift phase-shift-e] 201 | [phase-antishift (- phase-shift)]) 202 | (define (antishift stx) (syntax-shift-phase-level stx phase-antishift)) 203 | (syntax-shift-phase-level #`shifting-template phase-shift))]) 204 | 205 | (define (suspend-expression stx [suspenders (current-suspenders)] 206 | #:phase [phase (add1 (syntax-local-phase-level))] 207 | #:values [num-vals 1]) 208 | (define/with-syntax vals-expr (if (eqv? num-vals 1) 209 | #''#f 210 | #`(values #,@(make-list num-vals #''#f)))) 211 | (quasishift phase (if #,(is-suspended?-id phase suspenders) vals-expr #,stx))) 212 | 213 | (define (suspend-racket-decl stx [suspenders (current-suspenders)] 214 | #:phase [phase (add1 (syntax-local-phase-level))]) 215 | (let loop ([stx stx] 216 | [phase phase]) 217 | (call-with-disarmed-syntax 218 | stx 219 | (syntax-parser 220 | #:context 'suspend-racket-decl 221 | #:literal-sets [(kernel-literals #:phase phase)] 222 | [({~or #%require #%provide #%declare module} ~! . _) 223 | this-syntax] 224 | [({~and head {~or {~and define-values {~bind [stx? #f]}} 225 | {~and define-syntaxes {~bind [stx? #t]}}}} 226 | ~! [x:id ...] e:expr) 227 | #:do [(define e-phase (if (attribute stx?) (add1 phase) phase))] 228 | (datum->syntax this-syntax 229 | (list #'head 230 | (attribute x) 231 | (suspend-expression #'e #:values (length (attribute x)) #:phase phase)) 232 | this-syntax 233 | this-syntax)] 234 | [(head:begin-for-syntax ~! d ...) 235 | (datum->syntax this-syntax 236 | (cons #'head (map (lambda (d) (loop d (add1 phase))) (attribute d))) 237 | this-syntax 238 | this-syntax)] 239 | [_ 240 | (suspend-expression this-syntax #:phase phase)])))) 241 | 242 | (define (suspenders->racket-decl [suspenders (current-suspenders)]) 243 | (unless (zero? (syntax-local-phase-level)) 244 | (raise-arguments-error 245 | 'suspenders->racket-decl "only allowed when transforming relative phase level 0" 246 | "phase level" (syntax-local-phase-level))) 247 | 248 | (define ids (suspenders-ids suspenders)) 249 | (cond 250 | [(hash-empty? ids) 251 | #'(begin)] 252 | [else 253 | (define max-phase (argmax values (hash-keys ids))) 254 | (define-values [defn-decl set-expr] 255 | (for/fold ([defn-decl (syntax-shift-phase-level #'(begin) max-phase)] 256 | [set-expr (syntax-shift-phase-level #'(#%plain-app void) max-phase)]) 257 | ([phase (in-range max-phase 0 -1)]) 258 | (define id (hash-ref ids phase #f)) 259 | (values (quasishift (sub1 phase) 260 | (begin-for-syntax 261 | #,@(if id (list (quasishift phase (define-values [#,id] '#f))) '()) 262 | #,defn-decl)) 263 | (quasishift (sub1 phase) 264 | (let-syntaxes 265 | ([(_) #,(if id 266 | (quasishift phase (begin (set! #,id '#t) #,set-expr)) 267 | set-expr)]) 268 | (#%plain-app void)))))) 269 | #`(begin #,defn-decl (force-expansion #,set-expr))]))) 270 | 271 | ;; --------------------------------------------------------------------------------------------------- 272 | ;; residual tracking 273 | 274 | (begin-for-syntax 275 | (struct residual (origins uses bindings)) 276 | 277 | (define (residual-merge rss) 278 | (residual (append-map residual-origins rss) 279 | (append-map residual-uses rss) 280 | (append-map residual-bindings rss))) 281 | 282 | (define (make-residual [rss '()] 283 | #:origin [origin #f] 284 | #:uses [uses '()] 285 | #:bindings [bindings '()] 286 | #:flip-scopes? [flip-scopes? #t]) 287 | (define maybe-flip (if flip-scopes? syntax-local-introduce values)) 288 | (residual-merge (cons (residual (if origin (list (maybe-flip origin)) '()) 289 | (map maybe-flip uses) 290 | (map maybe-flip bindings)) 291 | rss))) 292 | 293 | (define (syntax-track-residual stx r) 294 | (~> (for/fold ([stx stx]) 295 | ([origin (in-list (residual-origins r))]) 296 | (macro-track-origin stx origin #:flip-scopes? #f)) 297 | (syntax-property-extend 'disappeared-use (residual-uses r) append) 298 | (syntax-property-extend 'disappeared-bindings (residual-bindings r) append)))) 299 | -------------------------------------------------------------------------------- /mini-ml-lib/mini-ml/private/namespace.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ; This module defines syntactic namespaces, which are separate binding environments that can coexist 4 | ; within a single phase. (They have no relation to what Racket calls “namespaces”, which are used for 5 | ; reflective operations.) In a namespace-enabled Racket language, every binding in the program belongs 6 | ; to exactly one namespace, and definitions in a given namespace can only be referenced by uses in the 7 | ; same namespace. 8 | ; 9 | ; For example, in a typed language, types and values may be bound in separate namespaces. The `define` 10 | ; form in such a language would create new bindings in the value namespace, but a `define-type` form 11 | ; would create new bindings in the type namespace. This allows two definitions with the same name to 12 | ; coexist, even in the same scope, so long as they are in separate namespaces: 13 | ; 14 | ; (define (Foo [x : Integer] [y : String]) 15 | ; (Tuple (* x 2) y)) 16 | ; 17 | ; (define-type Foo (Tuple Integer String)) 18 | ; 19 | ; In the above example, `Foo` is defined both as a function in the value namespace and as a type alias 20 | ; in the type namespace. Also note that `Tuple` is *used* in two different ways, based on the 21 | ; containing namespace — it is applied as a function inside the body of the `Foo` function while also 22 | ; being used as a type constructor in the definition of the `Foo` type alias. These uses are 23 | ; unambiguous because the namespace each reference belongs to is syntactically determined: the body of 24 | ; an ordinary definition is always in the value namespace, and the right hand side of a type alias 25 | ; definition is always in the type namespace. 26 | ; 27 | ; Note, however, that the namespaces are not always entirely syntactically separate — individual 28 | ; subforms can be in a separate namespace from their surrounding context. For example, using the above 29 | ; example again, the `x` and `y` identifiers are bound in the value namespace, but their type 30 | ; annotations, `Integer` and `String`, are references in the type namespace. This interleaving of 31 | ; namespaces is not unique to definition forms; arbitrary expressions can also have some subforms 32 | ; remain in the value namespace while others may be in the type namespace. For example, in the 33 | ; type annotation expression 34 | ; 35 | ; (: (Tuple 42 "hello") (Tuple Integer String)) 36 | ; 37 | ; the first subform, (Tuple 42 "hello"), remains in the value namespace, while the second subform, 38 | ; (Tuple Integer String), is expanded in the type namespace. 39 | 40 | (require (for-meta 2 racket/base 41 | racket/syntax 42 | "util/syntax.rkt") 43 | (for-syntax net/base64 44 | racket/base 45 | racket/contract 46 | racket/random 47 | racket/set 48 | racket/syntax 49 | syntax/parse/define 50 | threading 51 | "util/syntax.rkt") 52 | syntax/parse/define) 53 | 54 | (provide define-namespace provide/namespace) 55 | 56 | (begin-for-syntax 57 | (provide (contract-out 58 | [make-namespace (-> symbol? namespace?)] 59 | [namespace-key (-> namespace? symbol?)] 60 | [in-namespace (-> namespace? syntax? syntax?)] 61 | [namespace->expression (-> namespace? syntax?)] 62 | [namespace-exports-submodule-name (-> namespace? symbol?)] 63 | [namespace-exports-submodule-path (->i ([mod-path (or/c module-path? module-path-syntax?)] 64 | [ns namespace?]) 65 | [result (mod-path) (if (syntax? mod-path) 66 | module-path-syntax? 67 | module-path?)])] 68 | [module-exported-namespaces (-> module-path? (set/c #:cmp 'equal namespace?))] 69 | [make-namespaced-module-begin (->* [identifier? namespace?] 70 | [#:module-begin-id identifier?] 71 | (-> syntax? syntax?))]))) 72 | 73 | ;; --------------------------------------------------------------------------------------------------- 74 | ;; core definitions 75 | 76 | ; Since Racket programs contain macros, it isn’t always straightforward to determine which namespace 77 | ; a particular program fragment belongs to, in the same way it isn’t always straightforward to 78 | ; determine which bindings are in scope. Racket solves the latter problem by attaching scoping 79 | ; information to every syntax object in the program, and namespaces solve the former problem the same 80 | ; way. 81 | ; 82 | ; In a non-namespaced program, a syntax object pairs a datum with a set of scopes. A namespaced 83 | ; program extends this with one additional piece of information: the syntax object’s namespace. A 84 | ; syntax object always belongs to exactly one namespace, which is the primary difference between 85 | ; namespaces and scopes: while adding a scope to a syntax object does not affect other scopes already 86 | ; on the object, moving a syntax object into a new namespace removes it from its old namespace. 87 | ; 88 | ; Aside from this difference, namespaces and scopes are identical in how they affect binding. A 89 | ; namespace can be thought of as nothing more than another scope on a given syntax object for the 90 | ; purposes of binding (and indeed, that is how they are currently implemented). 91 | 92 | (begin-for-syntax 93 | (struct namespace (key introducer) 94 | #:property prop:object-name (struct-field-index key) 95 | #:property prop:custom-write 96 | (lambda (ns out mode) 97 | (fprintf out "#" (namespace-key ns))) 98 | #:property prop:equal+hash 99 | (list (lambda (ns-a ns-b recur) (eq? (namespace-key ns-a) (namespace-key ns-b))) 100 | (lambda (ns recur) (eq-hash-code (namespace-key ns))) 101 | (lambda (ns recur) (recur (namespace-key ns))))) 102 | 103 | (define all-namespaces (mutable-set)) 104 | 105 | ; make-namespace : symbol? -> namespace? 106 | ; 107 | ; Creates a new namespace with the provided symbolic key. Two namespaces created with the same key 108 | ; refer to the same namespace. In other words, `make-namespace` is not generative in the same way 109 | ; that prefab structures are not generative. This is mostly an unfortunate artifact of the 110 | ; implementation, but the `define-namespace` form (see below) provides some support for avoiding 111 | ; accidental namespace key collisions. 112 | ; 113 | ; Internally, namespaces are implemented using interned scopes. A procedure returned by 114 | ; `make-interned-syntax-introducer` will manipulate the same scope as a namespace with the same key. 115 | ; Doing so can result in multiple namespace scopes being applied to the same syntax object, so this 116 | ; is strongly discouraged. 117 | (define (make-namespace key) 118 | (define ns (namespace key (make-interned-syntax-introducer key))) 119 | (set-add! all-namespaces ns) 120 | ns) 121 | 122 | ; in-namespace : namespace? syntax? -> syntax? 123 | ; 124 | ; Changes the namespace of a syntax object. 125 | (define (in-namespace new-ns stx) 126 | ((namespace-introducer new-ns) 127 | (for/fold ([stx stx]) 128 | ([ns (in-set all-namespaces)] 129 | #:unless (equal? ns new-ns)) 130 | ((namespace-introducer ns) stx 'remove)) 131 | 'add))) 132 | 133 | ;; --------------------------------------------------------------------------------------------------- 134 | ;; `define-namespace` 135 | 136 | ; The `define-namespace` form provides a shorthand for defining namespaces and namespace forms. The 137 | ; form 138 | ; 139 | ; (define-namespace x) 140 | ; 141 | ; defines three new bindings: `namespace:x`, `in-x-namespace`, and `~x`. `namespace:x` is bound to a 142 | ; namespace value, which can be applied to a syntax object using `in-namespace`. `in-x-namespace` is 143 | ; bound to a procedure that applies the namespace to a syntax object. `~x` is bound to a syntax/parse 144 | ; pattern expander which applies the namespace to the syntax object before parsing any sub-patterns. 145 | ; 146 | ; To avoid key conflicts between namespaces, the `#:unique` option may be provided to 147 | ; `define-namespace`, which will automatically append a globally-unique identifier to the namespace 148 | ; key. This unique identifier will be regenerated each time the `define-namespace` form is compiled, 149 | ; but it will be consistent across multiple visits of the containing module. 150 | 151 | (begin-for-syntax 152 | (define (random-uuid) 153 | (crypto-random-bytes 16)) 154 | 155 | (define (random-uuid/base64) 156 | (bytes->string/utf-8 (subbytes (base64-encode (random-uuid) #"") 0 22)))) 157 | 158 | (define-simple-macro (define-namespace name:id 159 | {~alt {~or {~optional {~seq #:key base-key:id} 160 | #:defaults ([base-key #'name])} 161 | {~optional {~and #:unique unique?}}}} 162 | ...) 163 | #:do [(define name-len (string-length (symbol->string (syntax-e #'name))))] 164 | #:with {~var namespace:name} (derived-id "namespace:" #'name "") 165 | #:with in-name-namespace (derived-id "in-" #'name "-namespace") 166 | #:with {~var ~name} (derived-id "~" #'name "") 167 | #:with key (if (attribute unique?) 168 | (format-id #f "~a-~a" #'base-key (random-uuid/base64)) 169 | #'base-key) 170 | (begin-for-syntax 171 | (define namespace:name (make-namespace 'key)) 172 | (define (in-name-namespace stx) 173 | (in-namespace namespace:name stx)) 174 | (define-syntax ~name 175 | (pattern-expander 176 | (syntax-parser 177 | [(_ {~describe "pattern" pat}) 178 | #'{~and tmp {~parse pat (in-namespace namespace:name #'tmp)}}]))))) 179 | 180 | ;; --------------------------------------------------------------------------------------------------- 181 | ;; importing and exporting namespaced bindings 182 | 183 | ; While interned scopes can be used to relatively cleanly implement namespaces within a single module, 184 | ; things get more complicated once multiple modules come into play. The trouble stems from the fact 185 | ; that modules do not really import and export identifiers, they export symbols — the rich scoping 186 | ; information associated with bindings is discarded when a binding is exported. This makes sense, 187 | ; since that scoping information includes the scope of the module the binding is declared in, among 188 | ; other things, so if the scopes were preserved when the binding was imported by another module, the 189 | ; importing module wouldn’t actually be able to access the binding. Similarly, the various namespace 190 | ; management features provided by `require` subforms such as `rename-in` and `except-in` become much 191 | ; more complicated if several identifiers can be exported from the same module with the same name. 192 | ; 193 | ; It is tempting to repurpose phases for the purpose of namespace management, since modules *can* 194 | ; export multiple identifiers with the same name so long as they are at different phases. However, 195 | ; this doesn’t really work, since phases are designed to be used to create entirely distinct 196 | ; evaluation environments, and the degree of separation they enforce is just too much for namespaces, 197 | ; which need to be able to support truly interleaved binding environments. 198 | ; 199 | ; An alternative solution is to use submodules. Instead of providing identifiers directly, modules 200 | ; provide them through submodules, with a different submodule for each namespace. It’s straightforward 201 | ; for two submodules to provide the same name at the same phase with different bindings, and by using 202 | ; lexically nested submodules (i.e. `module*` submodules with #f for the module language), submodules 203 | ; have access to the full, multi-namespace binding environment of the enclosing module. 204 | ; 205 | ; Finally, providing modules also declare a metadata submodule, named `exported-namespaces`, which 206 | ; provides information about which submodules actually hold the namespaced bindings. Importing modules 207 | ; inspect this submodule (if one exists) and redirect requires to the relevant submodules as 208 | ; necessary, renaming the bindings to local ones with the appropriate namespaces. 209 | ; 210 | ; As a final wrinkle, module languages that export namespaced identifiers require special care. 211 | ; Ordinarily, identifiers imported using `require` can shadow identifiers that come from the module 212 | ; language, which is important since users have no way to suppress imported identifiers that come from 213 | ; the module language. Therefore, rewriting imports from the module language to module-level 214 | ; `require`s is insufficient, since those imports would not be able to be shadowed. A workable 215 | ; approach is to instead use `syntax-local-lift-require` to indirectly declare the imports, since such 216 | ; imports can, in fact, be shadowed by module-level `require`s. 217 | 218 | (begin-for-syntax 219 | (define namespaces-exported-from-current-module (mutable-set)) 220 | 221 | ; namespace-exports-submodule-name : namespace? -> symbol? 222 | ; 223 | ; Returns the name of the submodule used to provide exported bindings in the given namespace. 224 | (define (namespace-exports-submodule-name ns) 225 | (format-symbol "~a-exports" (namespace-key ns))) 226 | 227 | (define (namespace-exports-submodule-path base-mod-path ns) 228 | (module-path-submodule base-mod-path (namespace-exports-submodule-name ns))) 229 | 230 | ; namespace->expression : namespace? -> syntax? 231 | ; 232 | ; Returns a syntax object that, when evaluated as a Racket expression, will produce a namespace with 233 | ; the same key as the given namespace. 234 | (define (namespace->expression ns) 235 | #`(make-namespace '#,(namespace-key ns))) 236 | 237 | ; module-exported-namespaces : module-path? -> (set/c namespace?) 238 | ; 239 | ; Given a module path, returns the set of namespaces in which the referenced module exports 240 | ; identifiers. 241 | (define (module-exported-namespaces mod-path) 242 | (unless (module-declared? mod-path #t) 243 | (raise-arguments-error 'module-exported-namespaces "submodule does not exist" 244 | "module path" mod-path)) 245 | (define exported-namespaces-mod-path (module-path-submodule mod-path 'exported-namespaces)) 246 | (if (module-declared? exported-namespaces-mod-path #t) 247 | (dynamic-require exported-namespaces-mod-path 'exported-namespaces) 248 | (set)))) 249 | 250 | ; A macro that handles kick-starting the namespacing system by exporting identifiers into a namespace 251 | ; from a module written in a non-namespaced language. Use of `provide/namespace` expand into 252 | ; submodules that provide namespaced identifiers indirectly, and they also arrange for the 253 | ; appropriate `exported-namespaces` submodule to be declared at the end of the module. 254 | (define-syntax-parser provide/namespace 255 | [(_ ns-e:expr ps ...) 256 | #:fail-unless (eq? (syntax-local-context) 'module) "not at module level" 257 | #:with ns-e- (local-transformer-expand #'ns-e 'expression '()) 258 | #:do [(define ns (syntax-local-eval #'ns-e-)) 259 | (unless (namespace? ns) 260 | (raise-argument-error 'provide/namespace "namespace?" ns)) 261 | (when (set-empty? namespaces-exported-from-current-module) 262 | (syntax-local-lift-module-end-declaration #'(declare-exported-namespaces-submodule))) 263 | (set-add! namespaces-exported-from-current-module ns)] 264 | #:with mod-name (namespace-exports-submodule-name ns) 265 | #'(begin 266 | (begin-for-syntax 267 | ; for check syntax 268 | (define-values [] (begin (lambda () ns-e-) (values)))) 269 | (module+ mod-name 270 | (provide ps ...)))]) 271 | 272 | (define-syntax-parser declare-exported-namespaces-submodule 273 | [(_) 274 | #:with [ns-e ...] (set-map namespaces-exported-from-current-module namespace->expression) 275 | #'(begin-for-syntax 276 | (module* exported-namespaces #f 277 | (provide exported-namespaces) 278 | (define exported-namespaces (set ns-e ...))))]) 279 | 280 | ;; --------------------------------------------------------------------------------------------------- 281 | ;; `#%module-begin` and the reader 282 | 283 | ; The initial binding environment for a module is determined by its /module language/, which is 284 | ; effectively a `#%require` of all identifiers from a give module. However, unlike an ordinary 285 | ; `#%require`, the imports from the module language can be shadowed by module-level `#%require`s, 286 | ; since there is no way for imports from the module language to be explicitly suppressed (in contrast 287 | ; to the fine-grained namespace control allowed by Racket’s `require` form, which includes forms like 288 | ; `only-in` and `except-in`). 289 | ; 290 | ; With namespaces, we need to emulate the behavior of the module language, but in a namespace-aware 291 | ; way. Given that the exports of a module are distributed across several submodules, it’s impossible 292 | ; to import all of them using the module language alone (since it can only refer to a single module). 293 | ; What we can do instead is to provide a custom `#%module-begin` binding from the module language and 294 | ; nothing else, and we can arrange for it to introduce the necessary namespaced imports. To allow the 295 | ; imports to be shadowed, we can use `syntax-local-lift-require` instead of expanding to `#%require` 296 | ; directly, since the imports will be in their own scope and will not collide with other 297 | ; `#%require`-introduced identifiers. 298 | ; 299 | ; However, to do this, `#%module-begin` somehow needs to know about the module language, which is not 300 | ; normally made available. We could hardcode a separate `#%module-begin` binding for each module 301 | ; language, but this makes extending languages more awkward. Another approach is to adjust the reader 302 | ; to explicitly pass the module language to `#%module-begin`, which allows the same `#%module-begin` 303 | ; binding to be reused. This code takes that second approach, though it might be worth revisiting in 304 | ; the future if it turns out to not be worth the effort. 305 | ; 306 | ; The `make-namespaced-module-begin` function produces a transformer that can be used as a 307 | ; `#%module-begin` binding for a namespace-aware language. It cooperates with the reader functions 308 | ; produced by `make-namespaced-module-reader` to take advantage of the module language information. 309 | 310 | (begin-for-syntax 311 | ; Trampoline into a 'module context to establish a lift target for requires (lifts are not legal in 312 | ; a 'module-begin context). 313 | (define (make-namespaced-module-begin wrap-body-id default-ns 314 | #:module-begin-id [modbeg-id #'#%plain-module-begin]) 315 | (syntax-parser 316 | [(_ lang-mod-path:module-path d ...) 317 | (quasisyntax/loc this-syntax 318 | (#,modbeg-id (do-namespaced-module-begin lang-mod-path #,default-ns 319 | #,(quasisyntax/loc this-syntax 320 | (#,wrap-body-id d ...)))))]))) 321 | 322 | (define-syntax-parser do-namespaced-module-begin 323 | [(_ lang-mod-path default-ns d) 324 | #:do [(define ns-rsc 325 | (make-require-scope! 326 | (for/list ([ns (in-set (module-exported-namespaces (syntax->datum #'lang-mod-path)))]) 327 | (in-namespace ns (namespace-exports-submodule-path #'lang-mod-path ns)))))] 328 | (in-namespace (syntax-e #'default-ns) (require-scope-introduce ns-rsc #'d 'add))]) 329 | 330 | (module* module-reader racket/base 331 | (require racket/contract 332 | racket/path 333 | racket/sequence) 334 | 335 | (provide (contract-out [make-namespaced-module-reader 336 | (->* [module-path?] 337 | [#:language-name symbol?] 338 | (values (-> input-port? none/c) 339 | (-> any/c 340 | input-port? 341 | syntax? 342 | (or/c exact-positive-integer? #f) 343 | (or/c exact-nonnegative-integer? #f) 344 | (or/c exact-positive-integer? #f) 345 | syntax?) 346 | (-> input-port? 347 | syntax? 348 | (or/c exact-positive-integer? #f) 349 | (or/c exact-nonnegative-integer? #f) 350 | (or/c exact-positive-integer? #f) 351 | (-> any/c any/c any))))])) 352 | 353 | (define (make-namespaced-module-reader module-language 354 | #:language-name [language-name module-language]) 355 | (values 356 | ; read 357 | (lambda (in) (raise-arguments-error language-name "cannot be used in ‘read’ mode")) 358 | 359 | ; read-syntax 360 | (lambda (src-name in reader-mod-path line col pos) 361 | (define stxs 362 | (parameterize ([read-accept-lang #f]) 363 | (sequence->list (in-producer (lambda () (read-syntax src-name in)) eof-object?)))) 364 | (define module-name 365 | (or (and (path? src-name) 366 | (let ([filename (file-name-from-path src-name)]) 367 | (and filename 368 | (string->symbol (path->string (path-replace-extension filename #"")))))) 369 | 'anonymous-module)) 370 | (define lang-mod-path (datum->syntax #f module-language reader-mod-path reader-mod-path)) 371 | (datum->syntax #f 372 | (list (datum->syntax #f 'module) 373 | (datum->syntax #f module-name) 374 | lang-mod-path 375 | (list* (datum->syntax #f '#%module-begin) lang-mod-path stxs)) 376 | (vector src-name line col pos 377 | (and pos (let-values ([(l c p) (port-next-location in)]) 378 | (and p (- p pos))))))) 379 | 380 | ; get-info 381 | (lambda (in mod-path line col pos) 382 | (lambda (key default) 383 | (case key 384 | [(module-language) module-language] 385 | [else default])))))) 386 | -------------------------------------------------------------------------------- /mini-ml-lib/mini-ml/private/util/syntax.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "syntax/class/module-path.rkt" 4 | "syntax/misc.rkt" 5 | "syntax/require-scope.rkt") 6 | 7 | (provide (all-from-out "syntax/class/module-path.rkt" 8 | "syntax/misc.rkt" 9 | "syntax/require-scope.rkt")) 10 | -------------------------------------------------------------------------------- /mini-ml-lib/mini-ml/private/util/syntax/class/module-path.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require syntax/parse) 4 | 5 | (provide module-path) 6 | 7 | (define-syntax-class module-path 8 | #:description "module path" 9 | #:commit 10 | #:attributes [] 11 | #:datum-literals [submod] 12 | [pattern _:root-module-path] 13 | [pattern (submod ~! {~or _:root-module-path "." ".."} _:id ...+)]) 14 | 15 | (define-syntax-class root-module-path 16 | #:description "root module path" 17 | #:commit 18 | #:attributes [] 19 | #:datum-literals [quote lib file] 20 | [pattern (quote ~! _:id)] 21 | [pattern _:relative-path-string] 22 | [pattern (lib ~! _:relative-path-string ...+)] 23 | [pattern (file ~! _:string)] 24 | [pattern _:id] 25 | [pattern _:literal-path]) 26 | 27 | (define-syntax-class relative-path-string 28 | #:description "relative path string" 29 | #:commit 30 | #:opaque 31 | #:attributes [] 32 | [pattern s:string #:when (relative-path? (syntax-e #'s))]) 33 | 34 | (define-syntax-class literal-path 35 | #:description "literal path" 36 | #:commit 37 | #:opaque 38 | #:attributes [] 39 | [pattern v #:when (path? (syntax-e #'v))]) 40 | -------------------------------------------------------------------------------- /mini-ml-lib/mini-ml/private/util/syntax/misc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base) 4 | racket/contract 5 | racket/match 6 | syntax/parse 7 | syntax/parse/define 8 | threading) 9 | 10 | (provide (contract-out [module-path-syntax? (-> syntax? boolean?)] 11 | [module-path-submodule (->i ([mod-path (or/c module-path? module-path-syntax?)] 12 | [submod-name (mod-path) 13 | (if (syntax? mod-path) 14 | (or/c symbol? identifier?) 15 | symbol?)]) 16 | [result (mod-path) (if (syntax? mod-path) 17 | module-path-syntax? 18 | module-path?)])] 19 | [syntax-armed? (-> syntax? boolean?)] 20 | [call-with-disarmed-syntax (->* [(and/c syntax? (not/c syntax-tainted?)) 21 | (-> (and/c syntax? (not/c syntax-armed?)) 22 | (and/c syntax? (not/c syntax-tainted?)))] 23 | [#:use-mode? any/c 24 | #:failure-proc (-> any)] 25 | any)] 26 | [syntax-property-extend (->* [syntax? any/c any/c] 27 | [(-> any/c any/c any/c)] 28 | syntax?)] 29 | [adjust-property (-> syntax? any/c (-> any/c any/c) syntax?)] 30 | [recursively-adjust-property (-> (and/c syntax? (not/c syntax-tainted?)) 31 | any/c 32 | (-> any/c any/c) 33 | syntax?)] 34 | [derived-id (-> string? syntax? string? syntax?)] 35 | [macro-track-origin (->* [syntax? syntax?] [#:flip-scopes? any/c] syntax?)] 36 | [introduce-everywhere (-> syntax? (-> syntax? syntax?) syntax?)]) 37 | quote-syntax/launder) 38 | 39 | ;; --------------------------------------------------------------------------------------------------- 40 | ;; module paths 41 | 42 | (define (module-path-syntax? stx) 43 | (and (syntax? stx) (module-path? (syntax->datum stx)))) 44 | 45 | (define (module-path-submodule base-path submod-name) 46 | (if (syntax? base-path) 47 | (syntax-parse base-path 48 | #:context 'module-path-submodule 49 | #:datum-literals [submod] 50 | [(head:submod ~! more ...) 51 | (datum->syntax this-syntax 52 | `(,#'head ,@(attribute more) ,(datum->syntax #f submod-name)) 53 | this-syntax 54 | this-syntax)] 55 | [_ 56 | (datum->syntax this-syntax 57 | (list (datum->syntax #'here 'submod) 58 | this-syntax 59 | (datum->syntax #f submod-name)) 60 | this-syntax 61 | this-syntax)]) 62 | (match base-path 63 | [(cons 'submod more) 64 | `(submod ,@more ,submod-name)] 65 | [_ 66 | `(submod ,base-path ,submod-name)]))) 67 | 68 | ;; --------------------------------------------------------------------------------------------------- 69 | ;; taints 70 | 71 | (define (syntax-armed? stx) 72 | (define (tainted? v) 73 | (and (syntax? v) (syntax-tainted? v))) 74 | (or (syntax-tainted? stx) 75 | (match (syntax-e stx) 76 | [(list* as ... b) 77 | (or (ormap tainted? as) (tainted? b))] 78 | [(vector as ...) 79 | (ormap tainted? as)] 80 | [(hash-table [ks vs] ...) 81 | (ormap tainted? vs)] 82 | [(? prefab-struct-key (app struct->vector (vector _ as ...))) 83 | (ormap tainted? as)] 84 | [(box a) 85 | (tainted? a)] 86 | [_ #f]))) 87 | 88 | (define/contract (call-with-disarmed-syntax stx proc 89 | #:use-mode? [use-mode? #f] 90 | #:failure-proc [failure-proc #f]) 91 | (->* [(and/c syntax? (not/c syntax-tainted?)) 92 | (-> (and/c syntax? (not/c syntax-armed?)) 93 | (and/c syntax? (not/c syntax-tainted?)))] 94 | [#:use-mode? any/c 95 | #:failure-proc (-> any)] 96 | any) 97 | (let ([disarmed-stx (syntax-disarm stx #f)]) 98 | (if (syntax-armed? disarmed-stx) 99 | (if failure-proc 100 | (failure-proc) 101 | (raise-arguments-error 'call-with-disarmed-syntax "could not disarm syntax object" 102 | "syntax object" stx)) 103 | (syntax-rearm (proc disarmed-stx) stx use-mode?)))) 104 | 105 | ;; --------------------------------------------------------------------------------------------------- 106 | ;; properties 107 | 108 | (define (syntax-property-extend stx key new-val [extend cons]) 109 | (define old-val (syntax-property stx key)) 110 | (syntax-property stx key (if old-val (extend new-val old-val) new-val))) 111 | 112 | ; Modifies the property of a syntax object by applying a procedure to its value. If the syntax object 113 | ; does not contain any such property, the original syntax object is returned. Otherwise, the 114 | ; property’s value is recursively traversed as a tree of cons pairs, and the procedure is applied to 115 | ; each leaf to produce a new result. 116 | (define (adjust-property stx key proc) 117 | (let ([val (syntax-property stx key)]) 118 | (if val 119 | (syntax-property stx key 120 | (let loop ([val val]) 121 | (cond [(list? val) (map loop val)] 122 | [(pair? val) (cons (loop (car val)) (loop (cdr val)))] 123 | [else (proc val)]))) 124 | stx))) 125 | 126 | ; Like adjust-property, but recursively walks the syntax object and applies the function to each 127 | ; subform. Handles arming and disarming as necessary. 128 | (define (recursively-adjust-property stx key proc) 129 | (let loop ([stx stx]) 130 | (call-with-disarmed-syntax 131 | stx 132 | (lambda (disarmed) 133 | (~> (match (syntax-e disarmed) 134 | [(list a ...) (map loop a)] 135 | [(list* a ..1 b) (append (map loop a) (loop b))] 136 | [a a]) 137 | (datum->syntax disarmed _ disarmed disarmed) 138 | (adjust-property key proc)))))) 139 | 140 | ;; --------------------------------------------------------------------------------------------------- 141 | ;; cooperating with check syntax 142 | 143 | ; Unhygienically forges a new identifier from an existing one and adds an appropriate 144 | ; 'sub-range-binders property to track the relationship between the two. 145 | (define (derived-id prefix id suffix) 146 | (define id-str (symbol->string (syntax-e id))) 147 | (define id-len (string-length id-str)) 148 | (define new-id (datum->syntax id (string->symbol (string-append prefix id-str suffix)))) 149 | (syntax-property new-id 'sub-range-binders 150 | (vector (syntax-local-introduce new-id) (string-length prefix) id-len 0.5 0.5 151 | (syntax-local-introduce id) 0 id-len 0.5 0.5))) 152 | 153 | ; A small wrapper around `syntax-track-origin` that extracts the identifier prepended to the 'origin 154 | ; property from the provided original syntax, assuming the new syntax was produced by a Racket-like 155 | ; macro transformation. By default, it applies `syntax-local-introduce` to the extracted identifier 156 | ; before passing it to `syntax-track-origin`. 157 | (define (macro-track-origin new-stx orig-stx #:flip-scopes? [flip-scopes? #t]) 158 | (define id-stx (syntax-parse orig-stx 159 | #:context 'macro-track-origin 160 | [x:id #'x] 161 | [(head:id . _) #'head])) 162 | (syntax-track-origin new-stx 163 | orig-stx 164 | (if flip-scopes? 165 | (syntax-local-introduce id-stx) 166 | id-stx))) 167 | 168 | ; Applies the given syntax introducer procedure to both the given syntax object and all 169 | ; syntax objects inside syntax properties of the given syntax object that are used by Check Syntax. 170 | (define (introduce-everywhere stx introduce) 171 | (define (introduce-stx v) 172 | (if (syntax? v) (introduce v) v)) 173 | (~> (introduce stx) 174 | (recursively-adjust-property 'origin introduce-stx) 175 | (recursively-adjust-property 'disappeared-use introduce-stx) 176 | (recursively-adjust-property 'disappeared-binding introduce-stx) 177 | (recursively-adjust-property 'sub-range-binders 178 | (match-lambda 179 | [(vector (? syntax? id-1) start-1 span-1 x-1 y-1 180 | (? syntax? id-2) start-2 span-2 x-2 y-2) 181 | (vector (introduce id-1) start-1 span-1 x-1 y-1 182 | (introduce id-2) start-2 span-2 x-2 y-2)] 183 | [other other])))) 184 | 185 | ; Like `quote-syntax`, but adds a macro-introduction scope so that the syntax will not be original in 186 | ; the sense of `syntax-original?`, and Check Syntax will ignore it for the purpose of drawing binding 187 | ; arrows. Note that if the syntax will eventually end up in binding position, this is a bad idea, 188 | ; since the extra scope will prevent uses from seeing the binding. 189 | (define-syntax-parser quote-syntax/launder 190 | [(_ stx) 191 | (datum->syntax this-syntax 192 | (list #'quote-syntax 193 | ((make-syntax-introducer) #'stx)) 194 | this-syntax 195 | this-syntax)]) 196 | -------------------------------------------------------------------------------- /mini-ml-lib/mini-ml/private/util/syntax/require-scope.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ; This module implements /require scopes/, which provide a syntax introducer-like interface on top of 4 | ; `syntax-local-lift-require`. A require scope, created with `make-require-scope!`, encapsulates a set 5 | ; of scopes that provide access to a set of module imports, which can be flipped on, added to, or 6 | ; removed from a syntax object using `require-scope-introduce`. Creating a require scope immediately 7 | ; lifts one or more `#%require` forms to the top level of the module currently being expanded to make 8 | ; the imports available, whether or not the resulting require scope is applied to any syntax objects. 9 | 10 | (require racket/contract 11 | racket/list 12 | syntax/parse 13 | "misc.rkt") 14 | 15 | (provide (contract-out [require-scope? (-> any/c boolean?)] 16 | [make-require-scope! (->* [(listof syntax?)] 17 | [#:flip-scopes? any/c 18 | #:origin (or/c syntax? #f)] 19 | require-scope?)] 20 | [require-scope-introduce (->* [require-scope? syntax?] 21 | [(or/c 'flip 'add 'remove)] 22 | syntax?)]) 23 | phase-level) 24 | 25 | ;; --------------------------------------------------------------------------------------------------- 26 | ;; raw require spec normalization 27 | 28 | ; `make-require-scope!` accepts a list of multiple raw require specs, but `syntax-local-lift-require` 29 | ; only allows lifting a single spec at a time. This is unfortunate, as since there is no equivalent to 30 | ; `combine-in` for raw require specs, this potentially demands several lifts for a single call to 31 | ; `make-require-scope!`. Since each lifted `#%require` is associated with a fresh scope, a naïve 32 | ; implementation of `make-require-scope` would create a new scope for each spec. This enormous number 33 | ; of scopes has poor performance implications, and it can cause unbound or ambiguous identifier errors 34 | ; to become difficult to read (since they may have dozens of distinct “lifted-require” scopes). 35 | ; 36 | ; While avoiding multiple lifts per call to `make-require-scope!` is, in general, impossible, it is 37 | ; still possible to drastically reduce the number of separate lifts by grouping imports by phase. 38 | ; While it isn’t possible to include imports with two different phase shifts in a single spec, all 39 | ; imports with the same phase shift can be contained within a single `for-meta` form. Therefore, we 40 | ; normalize every raw require spec given to `make-require-scope!` to find its phase shift, then 41 | ; collect specs with the same phase shift into grouped specs prior to lifting. 42 | 43 | (define-syntax-class phase-level 44 | #:description "phase level" 45 | #:commit 46 | #:attributes [] 47 | [pattern _:exact-integer] 48 | [pattern #f]) 49 | 50 | (define-syntax-class (normalized-raw-require-spec #:allow-just-meta? [allow-just-meta? #t] 51 | #:allow-phase-shift? [allow-phase-shift? #t]) 52 | #:description (if (or allow-just-meta? allow-phase-shift?) 53 | "raw require spec" 54 | "phaseless raw require spec") 55 | #:commit 56 | #:attributes [[phase-restriction 1] [phase-shift 1] [phaseless-spec 1]] 57 | #:datum-literals [for-meta for-syntax for-template for-label just-meta] 58 | [pattern (just-meta ~! p:phase-level rs ...) 59 | #:declare rs (normalized-raw-require-spec #:allow-just-meta? #f 60 | #:allow-phase-shift? allow-phase-shift?) 61 | #:fail-unless allow-just-meta? "invalid nesting" 62 | #:attr [phase-shift 1] (append* (attribute rs.phase-shift)) 63 | #:attr [phaseless-spec 1] (append* (attribute rs.phaseless-spec)) 64 | #:attr [phase-restriction 1] (make-list (length (attribute phaseless-spec)) #'p)] 65 | [pattern ({~or* {~seq for-meta ~! p:phase-level} 66 | {~seq for-syntax ~! {~bind [p #'1]}} 67 | {~seq for-template ~! {~bind [p #'-1]}} 68 | {~seq for-label ~! {~bind [p #'#f]}}} 69 | rs ...) 70 | #:declare rs (normalized-raw-require-spec #:allow-just-meta? allow-just-meta? 71 | #:allow-phase-shift? #f) 72 | #:fail-unless allow-phase-shift? "invalid nesting" 73 | #:attr [phase-restriction 1] (append* (attribute rs.phase-restriction)) 74 | #:attr [phaseless-spec 1] (append* (attribute rs.phaseless-spec)) 75 | #:attr [phase-shift 1] (make-list (length (attribute phaseless-spec)) #'p)] 76 | [pattern rs 77 | #:attr [phase-restriction 1] (list #f) 78 | #:attr [phase-shift 1] (list #'0) 79 | #:attr [phaseless-spec 1] (list #'rs)]) 80 | 81 | ; Groups raw require specs by their relative phase shift, as described above. Returns a hash that maps 82 | ; phase levels to raw require specs. 83 | (define (group-raw-require-specs-by-phase stxs) 84 | (for/fold ([phase=>specs (hasheqv)]) 85 | ([stx (in-list stxs)]) 86 | (syntax-parse stx 87 | #:context 'make-require-scope! 88 | [rs:normalized-raw-require-spec 89 | (for/fold ([phase=>specs phase=>specs]) 90 | ([phase-restriction (in-list (attribute rs.phase-restriction))] 91 | [phase-shift (in-list (attribute rs.phase-shift))] 92 | [phaseless-spec (in-list (attribute rs.phaseless-spec))]) 93 | (define restricted-spec 94 | (if phase-restriction 95 | #`(just-meta #,phase-restriction #,phaseless-spec) 96 | phaseless-spec)) 97 | (hash-update phase=>specs 98 | (syntax-e phase-shift) 99 | (lambda (specs) (cons restricted-spec specs)) 100 | '()))]))) 101 | 102 | ;; --------------------------------------------------------------------------------------------------- 103 | 104 | (define scopeless-stx (datum->syntax #f #f)) 105 | 106 | (struct require-scope (introducer)) 107 | 108 | (define (make-require-scope! raw-require-specs 109 | #:flip-scopes? [flip-scopes? #t] 110 | #:origin [origin #f]) 111 | (unless (syntax-transforming?) 112 | (raise-arguments-error 'make-require-scope! "not currently expanding")) 113 | 114 | (define flipped-specs (if flip-scopes? 115 | (map syntax-local-introduce raw-require-specs) 116 | raw-require-specs)) 117 | (define maybe-track (if origin 118 | (lambda (stx) (macro-track-origin stx origin #:flip-scopes? flip-scopes?)) 119 | values)) 120 | 121 | (define phase=>specs (group-raw-require-specs-by-phase flipped-specs)) 122 | (define scoped-stx (for/fold ([scoped-stx scopeless-stx]) 123 | ([(phase specs) (in-hash phase=>specs)]) 124 | (define shifted-spec (maybe-track #`(for-meta #,phase #,@specs))) 125 | (syntax-local-lift-require shifted-spec scoped-stx))) 126 | (require-scope (make-syntax-delta-introducer scoped-stx scopeless-stx))) 127 | 128 | (define (require-scope-introduce rsc stx [mode 'flip]) 129 | ((require-scope-introducer rsc) stx mode)) 130 | -------------------------------------------------------------------------------- /mini-ml-lib/mini-ml/system-f.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; System F 4 | ; 5 | ; d ::= 6 | ; (#%define x : t e) 7 | ; (#%define-syntax x any) 8 | ; (#%define-type (x x ...) (x t ...) ...) 9 | ; (#%define-main e) 10 | ; (#%begin d ...) 11 | ; (#%begin-for-syntax any ...) 12 | ; 13 | ; e ::= 14 | ; x 15 | ; (#%datum literal) 16 | ; (#%lambda [x : t] e) 17 | ; (#%app e e) 18 | ; (#%Lambda [x : t] e) 19 | ; (#%App e t) 20 | ; (#%case e [(x [x : t] ...) e] ...) 21 | ; 22 | ; t ::= 23 | ; x 24 | ; (#%app t t) 25 | ; (#%forall [x : t] t) 26 | 27 | (require (for-meta 2 racket/base 28 | racket/syntax 29 | syntax/parse/class/struct-id 30 | "private/util/syntax.rkt") 31 | (for-syntax racket/base 32 | racket/contract 33 | racket/format 34 | racket/list 35 | racket/match 36 | racket/set 37 | racket/syntax 38 | syntax/id-table 39 | syntax/parse/class/local-value 40 | syntax/parse/define 41 | syntax-generic2 42 | threading 43 | "private/util/syntax.rkt") 44 | syntax/parse/define 45 | "private/extract.rkt" 46 | "private/namespace.rkt") 47 | 48 | (provide (rename-out [system-f:#%module-begin #%module-begin])) 49 | 50 | (define-namespace value #:unique) 51 | (define-namespace type #:unique) 52 | 53 | (provide/namespace namespace:value 54 | (rename-out [#%require require] 55 | [#%provide provide] 56 | [system-f:shift shift] 57 | [#%define define] 58 | [#%define-syntax define-syntax] 59 | [#%define-main define-main] 60 | [#%begin begin] 61 | [#%begin-for-syntax begin-for-syntax] 62 | [#%lambda lambda] 63 | [#%lambda λ] 64 | [#%App App] 65 | [#%Lambda Lambda] 66 | [sysf:+ +] 67 | [sysf:unit unit] 68 | [sysf:println println])) 69 | 70 | (provide/namespace namespace:type 71 | (rename-out [#%forall forall]) 72 | Type -> Unit Integer String) 73 | 74 | ;; --------------------------------------------------------------------------------------------------- 75 | ;; reader 76 | 77 | (module reader racket/base 78 | (require (submod "private/namespace.rkt" module-reader)) 79 | 80 | (provide (rename-out [system-f:read read] 81 | [system-f:read-syntax read-syntax]) 82 | get-info) 83 | 84 | (define-values [system-f:read system-f:read-syntax get-info] 85 | (make-namespaced-module-reader 'mini-ml/system-f #:language-name 'system-f))) 86 | 87 | ;; --------------------------------------------------------------------------------------------------- 88 | ;; keywords 89 | 90 | (begin-for-syntax 91 | (define-syntax-class system-f-keyword-class 92 | #:description #f 93 | #:attributes [-literals] 94 | [pattern 95 | x:id 96 | #:attr -literals (derived-id "core-" #'x "-literals")])) 97 | 98 | (define-simple-macro (define-keywords [class:system-f-keyword-class (x:id ...)] ...) 99 | #:with [unique-x ...] (remove-duplicates (append* (attribute x)) bound-identifier=?) 100 | (begin 101 | (define-syntax unique-x (generics)) ... 102 | (begin-for-syntax 103 | (define-literal-set class.-literals [x ...]) ...))) 104 | 105 | (define-keywords 106 | (decl [#%require #%provide #%define #%define-syntax #%define-type #%define-main #%begin 107 | #%begin-for-syntax]) 108 | (expr [system-f:#%datum #%lambda system-f:#%app #%Lambda #%App #%case]) 109 | (type [#%type:app #%forall]) 110 | (require-spec [#%binding #%union]) 111 | (provide-spec [#%binding #%union])) 112 | 113 | ;; --------------------------------------------------------------------------------------------------- 114 | ;; `define-syntax-info` 115 | 116 | ; It’s common to want to attach compile-time information to an identifier, which is normally done 117 | ; using a struct that holds the information, but this becomes awkward if a single identifier needs to 118 | ; serve multiple meanings (such as, for example, a data constructor that serves as both a variable and 119 | ; a pattern). The traditional approach is to use structure type properties, but this can be 120 | ; cumbersome. Syntax generics make things easier, but they use dispatch machinery that makes them more 121 | ; awkward than necessary to match on with syntax/parse. 122 | ; 123 | ; `define-syntax-info` is a thin wrapper around syntax generics to better serve the above use case. 124 | ; The definitions are morally like structures, with fields containing data, but that data is actually 125 | ; just stored in a closure inside a generic definition. Accessing the data is done via a syntax class, 126 | ; which binds the fields as attributes. 127 | 128 | (begin-for-syntax 129 | (define dispatch-on-id-only 130 | (syntax-parser 131 | [x:id #'x] 132 | [_ #f])) 133 | 134 | (define-simple-macro (define-syntax-info name:id [field:id ...] 135 | {~alt {~optional {~seq #:name err-name:expr} 136 | #:defaults ([err-name #`'#,(symbol->string 137 | (syntax-e #'name))])} 138 | {~optional {~seq #:constructor-name 139 | {~or ctor-id:id {~and #f {~bind [omit-ctor? #t]}}}}}} 140 | ...) 141 | #:attr make-name (and (not (attribute omit-ctor?)) 142 | (or (attribute ctor-id) (derived-id "make-" #'name ""))) 143 | #:with name? (format-id #'name "~a?" #'name) 144 | #:with expand-name (derived-id "expand-" #'name "") 145 | #:with name-id (derived-id "" #'name "-id") 146 | #:with [field-tmp ...] (generate-temporaries (attribute field)) 147 | (begin 148 | (define-syntax-generic name #:dispatch-on dispatch-on-id-only) 149 | {~? (define (make-name field-tmp ...) 150 | (generics [name (lambda (stx) (values field-tmp ...))]))} 151 | (define (expand-name stx [sc #f]) 152 | (apply-as-transformer name sc stx)) 153 | (define-syntax-class (name-id [sc #f]) 154 | #:description err-name 155 | #:commit 156 | #:attributes [field ...] 157 | [pattern x 158 | #:when (name? #'x sc) 159 | #:do [(define-values [field-tmp ...] (expand-name #'x sc))] 160 | {~@ #:attr field field-tmp} ...]))) 161 | 162 | ; Variables, type variables, and type constructors are really just special bindings with a type or 163 | ; kind attached. Module-level runtime variables also have an associated Racket binding, for use 164 | ; during program extraction. 165 | (define-syntax-info var (type) 166 | #:name "variable" 167 | #:constructor-name make-local-var) 168 | (define-syntax-info module-var (racket-id) 169 | #:constructor-name #f) 170 | (define (make-module-var type racket-id) 171 | (generics 172 | [var (lambda (stx) type)] 173 | [module-var (lambda (stx) racket-id)])) 174 | 175 | (define-syntax-info type-var (kind) #:name "type variable") 176 | (define-syntax-info type-constructor (kind) #:name "type constructor")) 177 | 178 | ;; --------------------------------------------------------------------------------------------------- 179 | ;; type operations 180 | 181 | (begin-for-syntax 182 | (define-syntax-class type 183 | #:description "type" 184 | #:opaque 185 | #:attributes [] 186 | [pattern _:expr]) 187 | 188 | (define/contract type->string 189 | (-> syntax? string?) 190 | (syntax-parser 191 | #:context 'type->string 192 | #:literal-sets [core-type-literals] 193 | #:datum-literals [:] 194 | [x:id 195 | (~a (syntax-e #'x))] 196 | [(#%type:app ~! t1:type t2:type) 197 | (~a "(" (type->string #'t1) " " (type->string #'t2) ")")] 198 | [(#%forall ~! [x:id : k:type] t:type) 199 | (~a "(forall [" (syntax-e #'x) " : " (type->string #'k) "] " (type->string #'t) ")")])) 200 | 201 | (define/contract (type=! actual-t expected-t [sc #f] #:src src-stx) 202 | (-> syntax? syntax? (or/c scope? #f) #:src syntax? void?) 203 | (let loop ([actual-t actual-t] 204 | [expected-t expected-t] 205 | [ctx (make-immutable-free-id-table)]) 206 | (syntax-parse (list actual-t expected-t) 207 | #:context 'type=! 208 | #:literal-sets [core-type-literals] 209 | #:datum-literals [:] 210 | [[{~var actual-x (type-var-id sc)} {~var expected-x (type-var-id sc)}] 211 | #:when (free-identifier=? #'actual-x #'expected-x) 212 | (void)] 213 | [[{~var actual-x (type-constructor-id sc)} {~var expected-x (type-constructor-id sc)}] 214 | #:when (free-identifier=? #'actual-x #'expected-x) 215 | (void)] 216 | [[actual-x:id expected-x:id] 217 | #:when (eq? (free-id-table-ref ctx #'actual-x) (free-id-table-ref ctx #'expected-x)) 218 | (void)] 219 | [[(#%type:app actual-t1:type actual-t2:type) (#%type:app expected-t1:type expected-t2:type)] 220 | #:when (and (loop #'actual-t1 #'expected-t1 ctx) 221 | (loop #'actual-t2 #'expected-t2 ctx)) 222 | (void)] 223 | [[(#%forall [actual-x:id : actual-k:type] actual-t:type) 224 | (#%forall [expected-x:id : expected-k:type] expected-t:type)] 225 | #:when (and (loop #'actual-k #'expected-k ctx) 226 | (loop #'actual-t #'expected-t 227 | (let ([v (gensym)]) 228 | (free-id-table-set* ctx #'actual-x v #'expected-x v)))) 229 | (void)] 230 | [[_ _] 231 | (raise-syntax-error 232 | 'system-f "type error" src-stx #f '() 233 | (format "\n expected type: ~a\n actual type: ~a" 234 | (type->string expected-t) 235 | (type->string actual-t)))])))) 236 | 237 | ;; --------------------------------------------------------------------------------------------------- 238 | ;; expander 239 | 240 | (begin-for-syntax 241 | (define (system-f-fallback thing) 242 | (define msg (string-append "not a valid " thing)) 243 | (lambda (stx) (raise-syntax-error 'system-f msg stx))) 244 | 245 | (define pair-only 246 | (syntax-parser 247 | [(x:id . _) #'x] 248 | [_ #f])) 249 | 250 | (define-syntax-generic system-f-decl (system-f-fallback "declaration")) 251 | (define-syntax-generic system-f-expr (system-f-fallback "expression")) 252 | (define-syntax-generic system-f-type (system-f-fallback "type")) 253 | (define-syntax-generic system-f-require-spec (system-f-fallback "require spec") 254 | #:dispatch-on pair-only) 255 | (define-syntax-generic system-f-provide-spec (system-f-fallback "provide spec") 256 | #:dispatch-on pair-only) 257 | 258 | ; `make-variable-like-transformer` is an awkward way to solve a common problem: wanting a macro that 259 | ; only ever expands as a single identifier, not at the head of a list. Let’s try just baking that 260 | ; in, instead. 261 | (define-values [prop:id-only? id-only?? id-only?-ref] (make-struct-type-property 'id-only?)) 262 | (define-syntax-class (id-only [sc #f]) 263 | #:description #f 264 | #:commit 265 | #:attributes [] 266 | [pattern {~var x (local-value id-only?? (scope-defctx sc))} 267 | #:do [(define id-only? (id-only?-ref (attribute x.local-value)))] 268 | #:when (if (procedure? id-only?) 269 | (id-only? (attribute x.local-value)) 270 | id-only?)]) 271 | (define (id-only? stx [sc #f]) 272 | (syntax-parse stx 273 | [_:id-only #t] 274 | [(_:id-only . _) #t] 275 | [_ #f])) 276 | 277 | ; The common case of `prop:id-only?` is to implement a transformer like 278 | ; `make-variable-like-transformer`, which just expands to a particular piece of syntax, but it needs 279 | ; to do just a little bit extra in order to make the source locations nice. This implements that. 280 | (define (make-substituting-transformer replacement-stx) 281 | (define replacement-datum (syntax-e replacement-stx)) 282 | (lambda (id-stx) (datum->syntax replacement-stx replacement-datum id-stx replacement-stx))) 283 | 284 | (struct e+t (e t) #:transparent) 285 | 286 | (define (e+t-e/t=! v t [sc #f] #:src src-stx) 287 | (type=! (e+t-t v) t sc #:src src-stx) 288 | (e+t-e v)) 289 | 290 | (define (expand-module stxs) 291 | (define sc (make-definition-scope)) 292 | 293 | (define (do-initial-defs+requires-pass stxs) 294 | (let loop ([stxs-to-go (map (lambda (stx) (in-scope sc stx)) stxs)] 295 | [stxs-deferred '()]) 296 | (match stxs-to-go 297 | ['() 298 | (reverse stxs-deferred)] 299 | [(cons stx stxs-to-go*) 300 | (syntax-parse stx 301 | #:literal-sets [core-decl-literals] 302 | #:literals [#%plain-module-begin begin-for-syntax] 303 | #:datum-literals [:] 304 | [(head:#%require ~! rs ...) 305 | #:with [expanded-rs ...] (append-map (lambda (rs) (expand-system-f-require-spec rs sc)) 306 | (attribute rs)) 307 | #:with [racket-rs ...] (map system-f-require-spec->racket-require-spec 308 | (attribute expanded-rs)) 309 | #:do [(define rsc (make-require-scope! (attribute racket-rs) #:origin this-syntax)) 310 | (define (rsc-introduce stx) (require-scope-introduce rsc stx 'add))] 311 | (loop (map rsc-introduce stxs-to-go*) 312 | (map rsc-introduce (cons (datum->syntax this-syntax 313 | (cons #'head (attribute expanded-rs)) 314 | this-syntax 315 | this-syntax) 316 | stxs-deferred)))] 317 | [(head:#%define ~! x:id : {~type t:type} e:expr) 318 | #:do [(define t- (e+t-e/t=! (expand-type #'t #f) #'Type sc #:src #'t)) 319 | (define x- (scope-bind! sc #'x (make-local-var t-)))] 320 | (loop stxs-to-go* (cons (datum->syntax this-syntax 321 | (list #'head x- ': t- #'e) 322 | this-syntax 323 | this-syntax) 324 | stxs-deferred))] 325 | [(head:#%define-syntax ~! x:id e) 326 | #:with e- (local-transformer-expand 327 | #`(let ([transformer e]) 328 | (generics [system-f-decl transformer] 329 | [system-f-expr transformer])) 330 | 'expression 331 | '() 332 | (list (scope-defctx sc))) 333 | #:with x- (scope-bind! sc #'x #'e-) 334 | (loop stxs-to-go* (cons (datum->syntax this-syntax 335 | (list #'head #'x- #'e-) 336 | this-syntax 337 | this-syntax) 338 | stxs-deferred))] 339 | [(head:#%begin ~! d ...) 340 | (loop (append (for/list ([d (in-list (attribute d))]) 341 | (macro-track-origin d this-syntax)) 342 | stxs-to-go*) 343 | stxs-deferred)] 344 | [(head:#%begin-for-syntax ~! d ...) 345 | #:with (#%plain-module-begin (begin-for-syntax d- ...)) 346 | (local-expand #'(#%plain-module-begin (begin-for-syntax d ...)) 'module-begin '()) 347 | (loop stxs-to-go* (cons (datum->syntax this-syntax 348 | (cons #'head (attribute d-)) 349 | this-syntax 350 | this-syntax) 351 | stxs-deferred))] 352 | [({~or #%define-type} 353 | ~! . _) 354 | (error "not yet implemented")] 355 | [({~or #%provide #%define-main} ~! . _) 356 | (loop stxs-to-go* (cons this-syntax stxs-deferred))] 357 | [_ 358 | (loop (cons (macro-track-origin (apply-as-transformer system-f-decl sc this-syntax) 359 | this-syntax) 360 | stxs-to-go*) 361 | stxs-deferred)])]))) 362 | 363 | (define (do-expand-exprs stxs) 364 | (define-values [expanded-decls main-decls] 365 | (for/fold ([expanded-decls '()] 366 | [main-decls '()]) 367 | ([stx (in-list stxs)]) 368 | (syntax-parse stx 369 | #:literal-sets [core-decl-literals] 370 | #:datum-literals [:] 371 | [({~or #%require #%define-syntax #%begin-for-syntax} ~! . _) 372 | ; already handled in first pass 373 | (values (cons this-syntax expanded-decls) main-decls)] 374 | [(head:#%provide ~! ps ...) 375 | #:do [(define expanded-pss (append-map (lambda (ps) (expand-system-f-provide-spec ps sc)) 376 | (attribute ps)))] 377 | (values (cons (datum->syntax this-syntax 378 | (cons #'head expanded-pss) 379 | this-syntax 380 | this-syntax) 381 | expanded-decls) 382 | main-decls)] 383 | [(head:#%define ~! x:id : t:type e:expr) 384 | #:do [(define e- (e+t-e/t=! (expand-expr #'e sc) #'t sc #:src #'e))] 385 | (values (cons (datum->syntax this-syntax 386 | (list #'head #'x ': #'t e-) 387 | this-syntax 388 | this-syntax) 389 | expanded-decls) 390 | main-decls)] 391 | [(head:#%define-main ~! e:expr) 392 | #:do [(define e- (e+t-e (expand-expr #'e sc)))] 393 | (values (cons (datum->syntax this-syntax 394 | (list #'head e-) 395 | this-syntax 396 | this-syntax) 397 | expanded-decls) 398 | (cons this-syntax main-decls))] 399 | [_ 400 | (raise-syntax-error 'system-f 401 | "internal error: unexpected form when expanding module body" 402 | this-syntax)]))) 403 | (when (> (length main-decls) 1) 404 | (raise-syntax-error 'system-f "multiple main declarations" #f #f (reverse main-decls))) 405 | (reverse expanded-decls)) 406 | 407 | (do-expand-exprs (do-initial-defs+requires-pass stxs))) 408 | 409 | (define-syntax-class system-f-literal 410 | #:description #f 411 | #:commit 412 | #:attributes [] 413 | [pattern _:exact-integer] 414 | [pattern _:string]) 415 | 416 | (define (expand-expr stx sc) 417 | (define (recur stx) (expand-expr stx sc)) 418 | (syntax-parse stx 419 | #:literal-sets [core-expr-literals] 420 | #:datum-literals [:] 421 | [{~var x (var-id sc)} 422 | (e+t this-syntax (attribute x.type))] 423 | [(system-f:#%datum ~! lit:system-f-literal) 424 | (e+t this-syntax (match (syntax-e #'lit) 425 | [(? exact-integer?) #'Integer] 426 | [(? string?) #'String]))] 427 | [lit:system-f-literal 428 | (recur (datum->syntax this-syntax 429 | (list (datum->syntax #'here 'system-f:#%datum) #'lit) 430 | this-syntax))] 431 | [(head:system-f:#%app ~! f:expr e:expr) 432 | ; TODO: share code with type application and kindchecking type ctor application 433 | #:do [(match-define (e+t f- f-t) (recur #'f)) 434 | (define-values [e-t r-t] 435 | (syntax-parse f-t 436 | #:literal-sets [core-type-literals] 437 | #:literals [->] 438 | [(#%type:app (#%type:app -> e-t:type) r-t:type) 439 | (values #'e-t #'r-t)] 440 | [_ 441 | (raise-syntax-error 442 | 'system-f "cannot apply a value that is not a function" this-syntax #'f '() 443 | (~a "\n expected type: ((-> t1) t2)\n actual type: " (type->string f-t)))]))] 444 | (e+t (datum->syntax this-syntax 445 | (list #'head f- (e+t-e/t=! (recur #'e) e-t sc #:src #'e)) 446 | this-syntax 447 | this-syntax) 448 | r-t)] 449 | [(head:#%lambda ~! [x:id : {~type t:type}] e:expr) 450 | #:do [(define sc* (make-expression-scope sc)) 451 | (define t- (e+t-e/t=! (expand-type #'t sc) #'Type sc #:src #'t)) 452 | (define x- (scope-bind! sc* #'x (make-local-var t-))) 453 | (match-define (e+t e- e-t) (expand-expr (in-scope sc* #'e) sc*))] 454 | (e+t (datum->syntax this-syntax 455 | (list #'head (list x- ': t-) e-) 456 | this-syntax 457 | this-syntax) 458 | #`(#%type:app (#%type:app -> #,t-) #,e-t))] 459 | [(head:#%App ~! e:expr {~type t:expr}) 460 | #:do [(match-define (e+t e- e-t) (recur #'e)) 461 | (define-values [x x-k unquantified-t] 462 | (syntax-parse e-t 463 | #:literal-sets [core-type-literals] 464 | #:literals [->] 465 | [(#%forall ~! [x:id : x-k:type] unquantified-t:type) 466 | (values #'x #'x-k #'unquantified-t)] 467 | [_ 468 | (raise-syntax-error 469 | 'system-f "cannot apply a value with a monomorphic type to a type" 470 | this-syntax #'e '() 471 | (~a "\n expected type: (forall [x : k] t)\n actual type: " 472 | (type->string e-t)))])) 473 | (define t- (e+t-e/t=! (expand-type #'t sc) x-k sc #:src #'t)) 474 | (define sc* (make-expression-scope sc)) 475 | (scope-bind! sc* x (generics #:property prop:id-only? #t 476 | [system-f-type (make-substituting-transformer t-)])) 477 | (define instantiated-t (e+t-e (expand-type (in-scope sc* unquantified-t) sc*)))] 478 | (e+t (datum->syntax this-syntax 479 | (list #'head e- t-) 480 | this-syntax 481 | this-syntax) 482 | instantiated-t)] 483 | [(head:#%Lambda ~! [{~type x:id} : {~type k:type}] e:expr) 484 | #:do [(define sc* (make-expression-scope sc)) 485 | (define k- (e+t-e/t=! (expand-type #'k sc) #'Type sc #:src #'k)) 486 | (define x- (scope-bind! sc* #'x (make-type-var k-))) 487 | (match-define (e+t e- e-t) (expand-expr (in-scope sc* #'e) sc*))] 488 | (e+t (datum->syntax this-syntax 489 | (list #'head (list x- ': k-) e-) 490 | this-syntax 491 | this-syntax) 492 | #`(#%forall [#,x- : #,k-] #,e-t))] 493 | [(#%case ~! . _) 494 | (error "not implemented yet")] 495 | [(_ . _) 496 | #:when (or (not (system-f-expr? this-syntax sc)) 497 | (id-only? this-syntax sc)) 498 | (recur (datum->syntax this-syntax 499 | (cons (datum->syntax #'here 'system-f:#%app) this-syntax) 500 | this-syntax))] 501 | [_ 502 | (recur (macro-track-origin (apply-as-transformer system-f-expr sc this-syntax) this-syntax))])) 503 | 504 | (define (expand-type stx sc) 505 | (define (recur stx) (expand-type stx sc)) 506 | (syntax-parse stx 507 | #:literal-sets [core-type-literals] 508 | [{~var x (type-var-id sc)} 509 | (e+t this-syntax (attribute x.kind))] 510 | [{~var x (type-constructor-id sc)} 511 | (e+t this-syntax (attribute x.kind))] 512 | [(head:#%type:app ~! t1:type t2:type) 513 | #:do [(match-define (e+t t1- k1) (recur #'t1)) 514 | (define-values [k2 kr] 515 | (syntax-parse k1 516 | #:literal-sets [core-type-literals] 517 | #:literals [->] 518 | [(#%type:app (#%type:app -> k2:type) kr:type) 519 | (values #'k2 #'kr)] 520 | [_ 521 | (raise-syntax-error 522 | 'system-f "cannot apply a type that is not a constructor" this-syntax #'t1 '() 523 | (~a "\n expected kind: ((-> k1) k2)\n actual kind: " (type->string k1)))]))] 524 | (e+t (datum->syntax this-syntax 525 | (list #'head t1- (e+t-e/t=! (recur #'t2) k2 sc #:src #'t2)) 526 | this-syntax 527 | this-syntax) 528 | kr)] 529 | [(head:#%forall ~! [x:id : k:type] t:type) 530 | #:do [(define sc* (make-expression-scope sc)) 531 | (define k- (e+t-e/t=! (recur #'k) #'Type sc #:src #'k)) 532 | (define x- (scope-bind! sc* #'x (make-type-var k-))) 533 | (match-define (e+t t- t-k) (expand-type (in-scope sc* #'t) sc*))] 534 | (e+t (datum->syntax this-syntax 535 | (list #'head (list x- ': k-) t-) 536 | this-syntax 537 | this-syntax) 538 | t-k)] 539 | [(_ . _) 540 | #:when (or (not (system-f-type? this-syntax sc)) 541 | (id-only? this-syntax sc)) 542 | (recur (datum->syntax this-syntax 543 | (cons (datum->syntax #'here '#%type:app) this-syntax) 544 | this-syntax))] 545 | [_ 546 | (recur (macro-track-origin (apply-as-transformer system-f-type sc this-syntax) 547 | this-syntax))])) 548 | 549 | (define (shift-phase phase shift) 550 | (and phase shift (+ phase shift))) 551 | 552 | (define (calculate-phase-shift new-phase orig-phase) 553 | (and new-phase orig-phase (- new-phase orig-phase))) 554 | 555 | (define-syntax-class require-#%binding 556 | #:description #f 557 | #:no-delimit-cut 558 | #:attributes [head external-id external-phase ns-key mod-path internal-id internal-phase] 559 | #:literal-sets [core-require-spec-literals] 560 | #:datum-literals [=>] 561 | [pattern (head:#%binding ~! external-id:id #:at external-phase:phase-level 562 | #:from {~or ns-key:id #f} #:in mod-path:module-path 563 | => internal-id:id #:at internal-phase:phase-level)]) 564 | 565 | (define (expand-system-f-require-spec stx sc) 566 | (define (recur stx) (expand-system-f-require-spec stx sc)) 567 | (syntax-parse stx 568 | #:literal-sets [core-require-spec-literals] 569 | #:datum-literals [=>] 570 | [mod-path:module-path 571 | #:and ~! 572 | #:do [(define nss (module-exported-namespaces (syntax->datum #'mod-path)))] 573 | (for*/list ([ns (in-list (cons #f (set->list nss)))] 574 | [ns-mod-path (in-value (if ns 575 | (namespace-exports-submodule-path #'mod-path ns) 576 | #'mod-path))] 577 | [exports (in-list (syntax-local-module-exports ns-mod-path))] 578 | [phase (in-value (car exports))] 579 | [external-sym (in-list (cdr exports))]) 580 | (define internal-id (datum->syntax this-syntax external-sym this-syntax this-syntax)) 581 | (define ns-internal-id (if ns (in-namespace ns internal-id) internal-id)) 582 | (datum->syntax #f 583 | (list (datum->syntax #'here '#%binding) 584 | external-sym '#:at phase 585 | '#:from (and ns (namespace-key ns)) '#:in #'mod-path 586 | '=> ns-internal-id '#:at 0)))] 587 | [:require-#%binding 588 | (list (datum->syntax this-syntax 589 | (list #'head #'external-id '#:at #'external-phase 590 | '#:from (attribute ns-key) '#:in #'mod-path 591 | '=> (syntax-local-identifier-as-binding #'internal-id) 592 | '#:at #'internal-phase) 593 | this-syntax 594 | this-syntax))] 595 | [(#%union ~! rs ...) 596 | (for*/list ([rs (in-list (attribute rs))] 597 | [expanded-rs (in-list (recur rs))]) 598 | (macro-track-origin expanded-rs this-syntax))] 599 | [_ 600 | (recur (macro-track-origin (apply-as-transformer system-f-require-spec sc this-syntax) 601 | this-syntax))])) 602 | 603 | (define (local-expand-system-f-require-spec stx [sc #f]) 604 | (datum->syntax #f (cons (datum->syntax #'here '#%union) (expand-system-f-require-spec stx sc)))) 605 | 606 | (define-syntax-class provide-#%binding 607 | #:description #f 608 | #:no-delimit-cut 609 | #:attributes [head internal-id external-id phase ns-key] 610 | #:literal-sets [core-provide-spec-literals] 611 | #:datum-literals [=>] 612 | [pattern (head:#%binding ~! internal-id:id => external-id:id 613 | #:at phase:phase-level #:in {~or ns-key:id #f})]) 614 | 615 | (define (expand-system-f-provide-spec stx sc) 616 | (define (recur stx) (expand-system-f-provide-spec stx sc)) 617 | (syntax-parse stx 618 | #:literal-sets [core-provide-spec-literals] 619 | #:datum-literals [=>] 620 | [x:id 621 | (list (datum->syntax #f 622 | (list (datum->syntax #'here '#%binding) 623 | #'x '=> #'x '#:at 0 '#:in (namespace-key namespace:value))))] 624 | [_:provide-#%binding 625 | (list this-syntax)] 626 | [(#%union ~! ps ...) 627 | (for*/list ([ps (in-list (attribute ps))] 628 | [expanded-ps (in-list (recur ps))]) 629 | (macro-track-origin expanded-ps this-syntax))] 630 | [_ 631 | (recur (macro-track-origin (apply-as-transformer system-f-provide-spec sc this-syntax) 632 | this-syntax))])) 633 | 634 | (define (local-expand-system-f-provide-spec stx [sc #f]) 635 | (datum->syntax #f (cons (datum->syntax #'here '#%union) (expand-system-f-provide-spec stx sc))))) 636 | 637 | (define-syntax system-f:shift 638 | (generics 639 | [system-f-require-spec 640 | (syntax-parser 641 | #:literal-sets [core-require-spec-literals] 642 | [(_ phase-stx:phase-level rs ...) 643 | #:do [(define phase (syntax-e #'phase-stx))] 644 | #:with (#%union b ...) (local-expand-system-f-require-spec #`(#%union rs ...)) 645 | #`(#%union #,@(for/list ([b-stx (in-list (attribute b))]) 646 | (define/syntax-parse b:require-#%binding b-stx) 647 | (datum->syntax b-stx 648 | (list #'b.head #'b.external-id '#:at #'b.external-phase 649 | '#:from (attribute b.ns-key) '#:in #'b.mod-path 650 | '=> #'b.internal-id 651 | '#:at (shift-phase (syntax-e #'b.internal-phase) phase)) 652 | b-stx 653 | b-stx)))])] 654 | [system-f-provide-spec 655 | (syntax-parser 656 | #:literal-sets [core-provide-spec-literals] 657 | [(_ phase-stx:phase-level ps ...) 658 | #:do [(define phase (syntax-e #'phase-stx))] 659 | #:with [(#%union b ...)] (local-expand-system-f-provide-spec #`(#%union ps ...)) 660 | #`(#%union #,@(for/list ([b-stx (in-list (attribute b))]) 661 | (define/syntax-parse b:provide-#%binding b-stx) 662 | (datum->syntax b-stx 663 | (list #'b.head #'b.internal-id '=> #'b.external-id 664 | '#:at (shift-phase (syntax-e #'b.phase) phase) 665 | '#:in (attribute b.ns-key)) 666 | b-stx 667 | b-stx)))])])) 668 | 669 | ;; --------------------------------------------------------------------------------------------------- 670 | ;; extraction 671 | 672 | ; Once a module has been expanded to the System F core language, it needs to be translated into the 673 | ; corresponding Racket code that can actually be executed. We call this process “extraction” — a 674 | ; Racket program is “extracted” from the System F one. For the most part, this translation is 675 | ; direct — System F declarations are mapped to Racket definitions, System F expressions are mapped to 676 | ; Racket expressions, etc. — but there are some subtleties involved along the way. 677 | ; 678 | ; One such subtlety is the handling of typed bindings. System F types are erased, so the extracted 679 | ; Racket program does not include types, but what about provided bindings? If one System F module 680 | ; imports another, then it needs to know the type of each binding in order to ensure its use is 681 | ; well-typed. Therefore, each System F `#%define` is actually translated into two Racket definitions: 682 | ; one using `define` and another using `define-syntax`. The `define` binding is bound to the actual 683 | ; extracted Racket expression, while the `define-syntax` binding is bound to a `module-var` that 684 | ; references the `define` binding. 685 | ; 686 | ; The main subtlety in the above approach is ensuring the right bindings are referenced in the right 687 | ; places. Extracted expressions should refer to the `define` binding, since they are already 688 | ; typechecked and ought to refer to the ordinary Racket variable, but references inside `#%provide` 689 | ; declarations ought to refer to the `define-syntax` binding so that importing modules can access the 690 | ; type information. The solution is to use the same identifier for both bindings, but to add a fresh 691 | ; scope to the `define` bindings to make them distinct. The same scope is added to the extracted 692 | ; right-hand side of each `#%define` declaration, but nowhere else, which redirects exactly the 693 | ; appropriate references. 694 | 695 | (begin-for-syntax 696 | (define (system-f-decl->racket-decl stx internal-introduce) 697 | (macro-track-origin 698 | (syntax-parse stx 699 | #:literal-sets [core-decl-literals] 700 | #:datum-literals [:] 701 | [(#%require ~! . _) 702 | ; requires are lifted during expansion, so we don’t need to do anything with them here 703 | #'(begin)] 704 | [(#%provide ~! ps ...) 705 | #`(begin #,@(map system-f-provide-spec->racket-decl (attribute ps)))] 706 | [(#%define ~! x:id : t:type e:expr) 707 | #:with internal-x (internal-introduce #'x) 708 | #`(begin 709 | (define internal-x #,(~> (system-f-expr->racket-expr (internal-introduce #'e)) 710 | (syntax-track-residual (system-f-type->residual #'t)))) 711 | (define-syntax x (make-module-var (quote-syntax/launder t) 712 | (quote-syntax/launder internal-x))))] 713 | [(#%define-syntax ~! x:id e) 714 | #`(define-syntax x #,(suspend-expression #'e))] 715 | [(#%begin-for-syntax ~! d ...) 716 | #`(begin-for-syntax #,@(map suspend-racket-decl (attribute d)))] 717 | [(#%define-main ~! e:expr) 718 | #`(module* main #f 719 | (#%plain-module-begin 720 | #,(system-f-expr->racket-expr (internal-introduce #'e))))] 721 | [_ 722 | (raise-syntax-error 723 | 'system-f 724 | "internal error: unexpected declaration form found during extraction to racket" 725 | this-syntax)]) 726 | stx)) 727 | 728 | (define (system-f-expr->racket-expr stx) 729 | (macro-track-origin 730 | (syntax-parse stx 731 | #:literal-sets [core-expr-literals] 732 | #:datum-literals [:] 733 | [x:module-var-id 734 | (attribute x.racket-id)] 735 | [_:id 736 | this-syntax] 737 | [(system-f:#%datum ~! lit:system-f-literal) 738 | #'(#%datum . lit)] 739 | [(system-f:#%app ~! f:expr e:expr) 740 | #`(#%plain-app #,(system-f-expr->racket-expr #'f) #,(system-f-expr->racket-expr #'e))] 741 | [(#%lambda ~! [x:id : t:type] e:expr) 742 | (~> #`(#%plain-lambda [x] #,(system-f-expr->racket-expr #'e)) 743 | (syntax-track-residual (system-f-type->residual #'t)))] 744 | [(#%App ~! e:expr t:type) 745 | (~> (system-f-expr->racket-expr #'e) 746 | (syntax-track-residual (system-f-type->residual #'t)))] 747 | [(#%Lambda ~! [x:id : k:type] e:expr) 748 | (~> (system-f-expr->racket-expr #'e) 749 | (syntax-track-residual (make-residual (list (system-f-type->residual #'k)) 750 | #:bindings (list #'x))))] 751 | [_ 752 | (raise-syntax-error 753 | 'system-f 754 | "internal error: unexpected expression form found during extraction to racket" 755 | this-syntax)]) 756 | stx)) 757 | 758 | (define system-f-type->residual 759 | (syntax-parser 760 | #:literal-sets [core-type-literals] 761 | #:datum-literals [:] 762 | [_:id 763 | (make-residual #:origin this-syntax)] 764 | [(#%type:app ~! t1:type t2:type) 765 | (make-residual (list (system-f-type->residual #'t1) 766 | (system-f-type->residual #'t2)) 767 | #:origin this-syntax)] 768 | [(#%forall ~! [x:id : k:type] t:type) 769 | (make-residual (list (system-f-type->residual #'k) 770 | (system-f-type->residual #'t)) 771 | #:origin this-syntax 772 | #:bindings (list #'x))] 773 | [_ 774 | (raise-syntax-error 775 | 'system-f 776 | "internal error: unexpected type form found during extraction to racket" 777 | this-syntax)])) 778 | 779 | (define (system-f-require-spec->racket-require-spec stx) 780 | (macro-track-origin 781 | (syntax-parse stx 782 | [:require-#%binding 783 | #:with adjusted-mod-path (if (attribute ns-key) 784 | (let ([ns (make-namespace (syntax-e #'ns-key))]) 785 | (namespace-exports-submodule-path #'mod-path ns)) 786 | #'mod-path) 787 | #:with phase-shift (calculate-phase-shift (syntax-e #'internal-phase) 788 | (syntax-e #'external-phase)) 789 | #:with rename-spec #'(rename adjusted-mod-path internal-id external-id) 790 | #`(just-meta external-phase #,(if (zero? (syntax-e #'phase-shift)) 791 | #'rename-spec 792 | #'(for-meta phase-shift rename-spec)))] 793 | [_ 794 | (raise-syntax-error 795 | 'system-f 796 | "internal error: unexpected require spec found during extraction to racket" 797 | this-syntax)]) 798 | stx)) 799 | 800 | (define (system-f-provide-spec->racket-decl stx) 801 | (macro-track-origin 802 | (syntax-parse stx 803 | [:provide-#%binding 804 | #:do [(define ns (and (attribute ns-key) (make-namespace (syntax-e #'ns-key))))] 805 | #:with racket-spec #'(for-meta phase (rename-out [internal-id external-id])) 806 | (if (attribute ns-key) 807 | #'(provide/namespace (make-namespace 'ns-key) racket-spec) 808 | #'(provide racket-spec))] 809 | [_ 810 | (raise-syntax-error 811 | 'system-f 812 | "internal error: unexpected provide spec found during extraction to racket" 813 | this-syntax)]) 814 | stx)) 815 | 816 | (define system-f-debug-print-decl? 817 | (syntax-parser 818 | #:literal-sets [core-decl-literals] 819 | [({~or #%require #%define-syntax #%begin-for-syntax} ~! . _) #f] 820 | [_ #t]))) 821 | 822 | (define-syntax system-f:#%module-begin 823 | (make-namespaced-module-begin #'do-module-begin namespace:value)) 824 | 825 | (define-syntax-parser do-module-begin 826 | [(_ decl ...) 827 | #:with [expanded-decl ...] (expand-module (attribute decl)) 828 | #:do [(println (syntax-local-introduce 829 | #`(system-f:#%module-begin 830 | #,@(filter system-f-debug-print-decl? (attribute expanded-decl)))))] 831 | #:do [(define internal-introducer (make-syntax-introducer #t)) 832 | (define (internal-introduce stx) 833 | (introduce-everywhere stx (lambda (stx) (internal-introducer stx 'add)))) 834 | (define suspenders (make-suspenders))] 835 | #:with [racket-decl ...] (parameterize ([current-suspenders suspenders]) 836 | (for/list ([expanded-decl (in-list (attribute expanded-decl))]) 837 | (system-f-decl->racket-decl expanded-decl internal-introduce))) 838 | ; Add an extra scope to everything to “freshen” binders. The expander complains if an identifier 839 | ; bound by a module-level binding form has *exactly* the same scopes as an existing binding, since 840 | ; the new binding would conflict with the old one. By adding a new scope to everything, the 841 | ; bindings remain distinct. As a wrinkle, we also need to add the scope inside syntax properties 842 | ; used by Check Syntax, since otherwise the binding structure of the program will be inconsistent 843 | ; with the information contained in the properties. 844 | #:do [(define finalizer-introducer (make-syntax-introducer #t))] 845 | #:with [introduced-decl ...] (for/list ([racket-decl (in-list (attribute racket-decl))]) 846 | (introduce-everywhere 847 | racket-decl 848 | (lambda (stx) (finalizer-introducer stx 'add)))) 849 | #`(begin 850 | #,(suspenders->racket-decl suspenders) 851 | introduced-decl ...)]) 852 | 853 | ;; --------------------------------------------------------------------------------------------------- 854 | 855 | (define-syntax Type (make-type-var #'Type)) 856 | (define-syntax -> (make-type-var 857 | #'(#%type:app (#%type:app -> Type) (#%type:app (#%type:app -> Type) Type)))) 858 | (define-syntax Integer (make-type-var #'Type)) 859 | (define-syntax String (make-type-var #'Type)) 860 | (define-syntax Unit (make-type-var #'Type)) 861 | 862 | (define-syntax-parser define-system-f-primitive 863 | [(_ x:id : t:type racket-id:id) 864 | #'(define-syntax x 865 | (make-module-var 866 | (e+t-e/t=! (expand-type #'t #f) #'Type #:src (quote-syntax t)) 867 | #'racket-id))]) 868 | 869 | (define ((curried-+ a) b) (+ a b)) 870 | (define-system-f-primitive sysf:+ : ((-> Integer) ((-> Integer) Integer)) curried-+) 871 | (define unit (void)) 872 | (define-system-f-primitive sysf:unit : Unit unit) 873 | (define-system-f-primitive sysf:println : (#%forall [a : Type] ((-> a) Unit)) println) 874 | --------------------------------------------------------------------------------