doclang.rkt (3560B)
1 #lang racket/base 2 3 (require "decode.rkt" 4 (for-syntax racket/base 5 syntax/kerncase)) 6 7 (provide (except-out (all-from-out racket/base) #%module-begin) 8 (rename-out [*module-begin #%module-begin])) 9 10 ;; Module wrapper ---------------------------------------- 11 12 (define-syntax (*module-begin stx) 13 (syntax-case stx () 14 [(_ id post-process exprs . body) 15 #'(#%module-begin 16 (doc-begin id post-process exprs . body))])) 17 18 (define-syntax (doc-begin stx) 19 (syntax-case stx () 20 [(_ m-id post-process exprs) 21 #`(begin 22 (define m-id (post-process (decode (list . #,(reverse (syntax->list #'exprs)))))) 23 (provide m-id))] 24 [(_ m-id post-process exprs . body) 25 ;; `body' probably starts with lots of string constants; it's 26 ;; slow to trampoline on every string, so do them in a batch 27 ;; here: 28 (let loop ([body #'body] 29 [accum null]) 30 (syntax-case body () 31 [(s . rest) 32 (string? (syntax-e #'s)) 33 (loop #'rest (cons #'s accum))] 34 [() 35 (with-syntax ([(accum ...) accum]) 36 #`(doc-begin m-id post-process (accum ... . exprs)))] 37 [(body1 . body) 38 (with-syntax ([exprs (append accum #'exprs)]) 39 (let ([expanded (local-expand 40 #'body1 'module 41 (append (kernel-form-identifier-list) 42 (syntax->list #'(provide 43 require))))]) 44 (syntax-case expanded (begin) 45 [(begin body1 ...) 46 #`(doc-begin m-id post-process exprs body1 ... . body)] 47 [(id . rest) 48 (and (identifier? #'id) 49 (ormap (lambda (kw) (free-identifier=? #'id kw)) 50 (syntax->list #'(require 51 provide 52 define-values 53 define-syntaxes 54 begin-for-syntax 55 module 56 module* 57 #%require 58 #%provide 59 #%declare)))) 60 #`(begin #,expanded (doc-begin m-id post-process exprs . body))] 61 [_else 62 #`(doc-begin m-id post-process 63 ((pre-part #,expanded body1) . exprs) 64 . body)])))]))])) 65 66 (define-syntax (pre-part stx) 67 (syntax-case stx () 68 [(_ s e) 69 (if (string? (syntax-e #'s)) 70 #'s 71 (with-syntax ([loc (datum->syntax #f 'loc #'e)]) 72 #'(check-pre-part e (quote-syntax loc))))])) 73 74 (define (check-pre-part v loc-stx) 75 (if (pre-part? v) 76 v 77 (error 78 (format 79 "~a: not valid in document body (need a pre-part for decode) in: ~e" 80 (cond 81 [(and (syntax-source loc-stx) 82 (syntax-line loc-stx)) 83 (format "~a:~a:~a" 84 (syntax-source loc-stx) 85 (syntax-line loc-stx) 86 (syntax-column loc-stx))] 87 [(and (syntax-source loc-stx) 88 (syntax-position loc-stx)) 89 (format "~a:::~a" 90 (syntax-source loc-stx) 91 (syntax-position loc-stx))] 92 [else 'document]) 93 v))))