improve sugar/include

pull/2/head
Matthew Butterick 10 years ago
parent 8d39746d6c
commit b008bbfc18

@ -84,17 +84,27 @@
(cons r (loop)))))]) (cons r (loop)))))])
;; Here's where we'll separate the content of the file from the #lang line. ;; Here's where we'll separate the content of the file from the #lang line.
;; 'content' is a one-member list with the file as a syntax object. ;; the resulting material will be stored in 'content-guts'.
(define content-syntax (car content)) ; save the syntax object (its context will be needed momentarily) ;; 'content' is a list of syntax objects from the source file.
;; peel the wrapper off the file. it will come in like so ;; Each object corresponds to a top-level expression in the file, converted to syntax.
;; (module foo whatever/lang (#%module-begin expr ...)) ;; If the file has a #lang line, there's only one expression (because the #lang expands to a single `module` form).
;; the guts are the (expr ...). To get them, we want the cdr of the fourth element. ;; If it doesn't, then there are an indefinite number of expressions.
(define fourth cadddr) ; we don't have `fourth` in the syntax environment. ;; So we'll handle both types with a match.
;; get the guts and package them back into a syntax object using the saved content-syntax as context. (define content-guts
(local-require racket/match) (cond
(define guts (match (syntax->datum content-syntax) [(not (null? content))
[(list 'module modname lang (list '#%module-begin exprs ...)) exprs])) (define content-syntax (car content)) ; save the first syntax object (its context will be needed momentarily)
(define content-guts (datum->syntax content-syntax guts)) ;; peel the wrapper off the file. it will come in like so
;; (module foo whatever/lang (#%module-begin expr ...))
;; the guts are the (expr ...). To get them, we want the cdr of the fourth element.
(define fourth cadddr) ; we don't have `fourth` in the syntax environment.
;; get the guts and package them back into a syntax object using the saved content-syntax as context.
(local-require racket/match racket/function)
(define guts-data (match (map syntax->datum content)
[(list (list 'module modname lang (list '#%module-begin exprs ...))) exprs]
[(list exprs ...) exprs]))
(map (curry datum->syntax content-syntax) guts-data)]
[else null]))
(close-input-port p) (close-input-port p)
;; Preserve src info for content, but set its ;; Preserve src info for content, but set its
;; lexical context to be that of the include expression ;; lexical context to be that of the include expression

@ -5,7 +5,7 @@
@title{Include} @title{Include}
@defmodule[sugar/include] @defmodule[sugar/include]
@defform[(include-without-lang-line path)] @defform[(include-without-lang-line path-spec)]
Like @racket[include], but strips off the @tt{#lang} line of the file. Why? So you can take the code from a working source file and recompile it under a different @tt{#lang}. Why? Well, you could take code from a @tt{#lang typed/racket} source file and recompile as @tt{#lang typed/racket/no-check}. Why? Because then you could invoke your code natively from typed and untyped environments. Inline the syntax in the file designated by @racket[_path-spec], after stripping off the @tt{#lang} line of the file (if it exists, otherwise just @racket[include] the file as usual).
Please, don't use this on a file without a @tt{#lang} line. For that, just use @racket[include]. Why? So you can take the code from a working source file and recompile it under a different @tt{#lang}. Why? Well, you could take code from a @tt{#lang typed/racket} source file and recompile as @tt{#lang typed/racket/no-check}. Why? Because then you could make typed and untyped modules from the same code without the mandatory contracts imposed by @racket[require/typed].

@ -0,0 +1 @@
(define no-lang-symbol 'bar)

@ -193,4 +193,12 @@
(provide included-symbol)) (provide included-symbol))
(require 'include-test) (require 'include-test)
(check-equal? included-symbol 'bar) (check-equal? included-symbol 'bar)
(module no-lang-line-include-test racket/base
(require sugar/include)
(include-without-lang-line "test/no-lang-line-source.rkt")
(provide no-lang-symbol))
(require 'no-lang-line-include-test)
(check-equal? no-lang-symbol 'bar)
Loading…
Cancel
Save