From 8d39746d6c4c0c0d5de488ee24944ac4cca69254 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 1 Apr 2015 13:40:41 -0700 Subject: [PATCH] add sugar/include --- include.rkt | 133 ++++++++++++++++++++++++++++++++++++++ main.rkt | 2 + scribblings/include.scrbl | 11 ++++ scribblings/sugar.scrbl | 2 + test/source.rkt | 3 + tests.rkt | 11 +++- 6 files changed, 161 insertions(+), 1 deletion(-) create mode 100644 include.rkt create mode 100644 scribblings/include.scrbl create mode 100644 test/source.rkt diff --git a/include.rkt b/include.rkt new file mode 100644 index 0000000..f31e709 --- /dev/null +++ b/include.rkt @@ -0,0 +1,133 @@ +#lang racket/base + +(require (for-syntax racket/base + syntax/path-spec + racket/private/increader + compiler/cm-accomplice)) + +(provide include-without-lang-line) + +(define-syntax (do-include stx) + (syntax-case stx () + [(_ orig-stx ctx loc fn reader) + ;; Parse the file name + (let ([orig-c-file (resolve-path-spec (syntax fn) (syntax loc) (syntax orig-stx))] + [ctx (syntax ctx)] + [loc (syntax loc)] + [reader (syntax reader)] + [orig-stx (syntax orig-stx)] + [rkt->ss (lambda (p) + (let ([b (path->bytes p)]) + (if (regexp-match? #rx#"[.]rkt$" b) + (path-replace-suffix p #".ss") + p)))]) + + (let ([c-file (if (file-exists? orig-c-file) + orig-c-file + (let ([p2 (rkt->ss orig-c-file)]) + (if (file-exists? p2) + p2 + orig-c-file)))]) + + (register-external-file c-file) + + (let ([read-syntax (if (syntax-e reader) + (reader-val + (let loop ([e (syntax->datum + (local-expand reader 'expression null))]) + (cond + [(reader? e) e] + [(pair? e) (or (loop (car e)) + (loop (cdr e)))] + [else #f]))) + (lambda (src in) + (parameterize ([read-accept-reader #t]) + (read-syntax src in))))]) + (unless (and (procedure? read-syntax) + (procedure-arity-includes? read-syntax 2)) + (raise-syntax-error + #f + "reader is not a procedure of two arguments" + orig-stx)) + + ;; Open the included file + (let ([p (with-handlers ([exn:fail? + (lambda (exn) + (raise-syntax-error + #f + (format + "can't open include file (~a)" + (if (exn? exn) + (exn-message exn) + exn)) + orig-stx + c-file))]) + (open-input-file c-file))]) + (port-count-lines! p) + ;; Read expressions from file + (let ([content + (let loop () + (let ([r (with-handlers ([exn:fail? + (lambda (exn) + (close-input-port p) + (raise-syntax-error + #f + (format + "read error (~a)" + (if (exn? exn) + (exn-message exn) + exn)) + orig-stx))]) + (read-syntax c-file p))]) + (if (eof-object? r) + null + (cons r (loop)))))]) + + ;; 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. + (define content-syntax (car content)) ; save the syntax object (its context will be needed momentarily) + ;; 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) + (define guts (match (syntax->datum content-syntax) + [(list 'module modname lang (list '#%module-begin exprs ...)) exprs])) + (define content-guts (datum->syntax content-syntax guts)) + (close-input-port p) + ;; Preserve src info for content, but set its + ;; lexical context to be that of the include expression + (let ([lexed-content + (let loop ([content content-guts]) ;; start with the new content-guts + (cond + [(pair? content) + (cons (loop (car content)) + (loop (cdr content)))] + [(null? content) null] + [else + (let ([v (syntax-e content)]) + (datum->syntax + ctx + (cond + [(pair? v) + (loop v)] + [(vector? v) + (list->vector (loop (vector->list v)))] + [(box? v) + (box (loop (unbox v)))] + [else + v]) + content + content))]))]) + * + (datum->syntax + (quote-syntax here) + `(begin ,@lexed-content) + orig-stx)))))))])) + +(define-syntax (include-without-lang-line stx) + (syntax-case stx () + [(_ fn) + (with-syntax ([_stx stx]) + (syntax/loc stx (do-include _stx _stx _stx fn #f)))])) \ No newline at end of file diff --git a/main.rkt b/main.rkt index 52eb2b7..fa356d3 100644 --- a/main.rkt +++ b/main.rkt @@ -7,6 +7,7 @@ "debug.rkt" "define.rkt" "file.rkt" + "include.rkt" "list.rkt" "misc.rkt" "string.rkt" @@ -21,6 +22,7 @@ "debug.rkt" "define.rkt" "file.rkt" + "include.rkt" "list.rkt" "misc.rkt" "string.rkt" diff --git a/scribblings/include.scrbl b/scribblings/include.scrbl new file mode 100644 index 0000000..beff43a --- /dev/null +++ b/scribblings/include.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual + +@(require scribble/eval (for-label racket sugar)) + +@title{Include} +@defmodule[sugar/include] + +@defform[(include-without-lang-line path)] +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. + +Please, don't use this on a file without a @tt{#lang} line. For that, just use @racket[include]. \ No newline at end of file diff --git a/scribblings/sugar.scrbl b/scribblings/sugar.scrbl index a5554e7..e486347 100644 --- a/scribblings/sugar.scrbl +++ b/scribblings/sugar.scrbl @@ -28,6 +28,8 @@ A collection of small functions to help make Racket code simpler & more readable @include-section["file.scrbl"] +@include-section["include.scrbl"] + @include-section["len.scrbl"] @include-section["list.scrbl"] diff --git a/test/source.rkt b/test/source.rkt new file mode 100644 index 0000000..d82d324 --- /dev/null +++ b/test/source.rkt @@ -0,0 +1,3 @@ +#lang typed/racket + +(define included-symbol 'bar) \ No newline at end of file diff --git a/tests.rkt b/tests.rkt index 6179dd2..d13c4fb 100644 --- a/tests.rkt +++ b/tests.rkt @@ -184,4 +184,13 @@ (define-values (str-prolog str-doc) (xml-string->xexprs str)) (check-equal? str-prolog (prolog (list (p-i (location 1 0 1) (location 1 38 39) 'xml "version=\"1.0\" encoding=\"utf-8\"")) #f null)) (check-equal? str-doc '(root () "hello world")) -(check-equal? (xexprs->xml-string str-prolog str-doc) str) \ No newline at end of file +(check-equal? (xexprs->xml-string str-prolog str-doc) str) + + +(module include-test racket/base + (require sugar/include) + (include-without-lang-line "test/source.rkt") + (provide included-symbol)) + +(require 'include-test) +(check-equal? included-symbol 'bar) \ No newline at end of file