diff --git a/quad/quad/doclang-raw.rkt b/quad/quad/doclang-raw.rkt new file mode 100755 index 00000000..f47f50a6 --- /dev/null +++ b/quad/quad/doclang-raw.rkt @@ -0,0 +1,79 @@ +#lang racket/base + +(require (for-syntax racket/base + syntax/kerncase)) + +(provide (except-out (all-from-out racket/base) #%module-begin) + (rename-out [*module-begin #%module-begin])) + +;; Module wrapper ---------------------------------------- + +(define-syntax (*module-begin stx) + (syntax-case stx () + [(_ id post-process . body) + (with-syntax ([exprs #'()]) + #'(#%module-begin + (doc-begin id post-process exprs . body)))])) + +(define-syntax (doc-begin stx) + (syntax-case stx () + [(_ m-id post-process (expr ...)) + ;; unlike regular doclang, don't `provide` m-id (we'll do that in main-base wrapper) + #`(define m-id (post-process (list . #,(reverse (syntax->list #'(expr ...))))))] + [(_ m-id post-process exprs . body) + ;; `body' probably starts with lots of string constants; it's + ;; slow to trampoline on every string, so do them in a batch + ;; here: + (let loop ([body #'body] + [accum null]) + (syntax-case body () + [(s . rest) + (string? (syntax-e #'s)) + (loop #'rest (cons #'s accum))] + [() + (with-syntax ([(accum ...) accum]) + #`(doc-begin m-id post-process (accum ... . exprs)))] + [(body1 . body) + (with-syntax ([exprs (append accum #'exprs)]) + (let ([expanded (local-expand + #'body1 'module + (append (kernel-form-identifier-list) + (syntax->list #'(provide + require + #%provide + #%require))))]) + (syntax-case expanded (begin) + [(begin body1 ...) + #`(doc-begin m-id post-process exprs body1 ... . body)] + [(id . rest) + (and (identifier? #'id) + (ormap (lambda (kw) (free-identifier=? #'id kw)) + (syntax->list #'(require + provide + define-values + define-syntaxes + begin-for-syntax + module + module* + #%require + #%provide)))) + #`(begin #,expanded (doc-begin m-id post-process exprs . body))] + [_else + #`(doc-begin m-id post-process + ((pre-part #,expanded body1) . exprs) + . body)])))]))])) + +(define-syntax (pre-part stx) + (syntax-case stx () + [(_ s e) + (if (string? (syntax-e #'s)) + #'s + (with-syntax ([src (syntax-source #'e)] + [line (syntax-line #'e)] + [col (syntax-column #'e)] + [pos (syntax-position #'e)] + [span (syntax-column #'e)]) + #'(check-pre-part e (vector 'src 'line 'col 'pos 'span))))])) + +(define (check-pre-part v s) + v) \ No newline at end of file diff --git a/quad/quad/lang.rkt b/quad/quad/lang.rkt index 356443f5..7131b691 100644 --- a/quad/quad/lang.rkt +++ b/quad/quad/lang.rkt @@ -1,8 +1,24 @@ #lang racket/base -(require (for-syntax racket/base)) +(require (for-syntax racket/base) + quad + (prefix-in doclang: "doclang-raw.rkt")) (provide (rename-out [quad-mb #%module-begin]) - #%top-interaction) + #%top-interaction + #%top + #%app + #%datum + (except-out (all-from-out racket/base) #%module-begin)) +(define-for-syntax export-name 'quad) (define-syntax (quad-mb stx) (syntax-case stx () - [(_ . ARGS) #'(#%module-begin . ARGS)])) \ No newline at end of file + [(_ . ARGS) + (with-syntax ([EXPORT (datum->syntax stx export-name)]) + #'(doclang:#%module-begin + EXPORT ; positional arg for doclang-raw: name of export + (λ (xs) + (define x (q #:elems xs)) + (println x) + x) ; positional arg for doclang-raw: post-processor + (provide EXPORT) + (begin . ARGS)))])) \ No newline at end of file