common.rkt (5808B)
1 #lang racket/base 2 3 (provide (except-out (all-from-out racket/base) #%module-begin) 4 module-begin/plain 5 module-begin/doc) 6 7 (require (for-syntax racket/base syntax/boundmap racket/list 8 syntax/strip-context)) 9 10 (begin-for-syntax 11 (define first-id #f) 12 (define main-id #f) 13 (define (mapping-get mapping id) 14 (free-identifier-mapping-get mapping id (lambda () '()))) 15 ;; maps a chunk identifier to its collected expressions 16 (define chunks (make-free-identifier-mapping)) 17 ;; maps a chunk identifier to all identifiers that are used to define it 18 (define chunk-groups (make-free-identifier-mapping)) 19 (define (get-chunk id) (mapping-get chunks id)) 20 (define (add-to-chunk! id exprs) 21 (unless first-id (set! first-id id)) 22 (when (eq? (syntax-e id) '<*>) (set! main-id id)) 23 (free-identifier-mapping-put! 24 chunk-groups id 25 (cons id (mapping-get chunk-groups id))) 26 (free-identifier-mapping-put! 27 chunks id 28 `(,@(mapping-get chunks id) ,@exprs)))) 29 30 (define-syntax (tangle stx) 31 (define chunk-mentions '()) 32 (unless first-id 33 (raise-no-chunks-error)) 34 (define orig-stx (syntax-case stx () [(_ orig) #'orig])) 35 (define (restore nstx d) (datum->syntax orig-stx d nstx nstx)) 36 (define (shift nstx) (replace-context orig-stx nstx)) 37 (define body 38 (let ([main-id (or main-id first-id)]) 39 (restore 40 main-id 41 (let loop ([block (get-chunk main-id)]) 42 (append-map 43 (lambda (expr) 44 (if (identifier? expr) 45 (let ([subs (get-chunk expr)]) 46 (if (pair? subs) 47 (begin (set! chunk-mentions (cons expr chunk-mentions)) 48 (loop subs)) 49 (list (shift expr)))) 50 (let ([subs (syntax->list expr)]) 51 (if subs 52 (list (restore expr (loop subs))) 53 (list (shift expr)))))) 54 block))))) 55 (with-syntax ([(body ...) (strip-comments body)] 56 ;; construct arrows manually 57 [((b-use b-id) ...) 58 (append-map (lambda (m) 59 (map (lambda (u) 60 (list (syntax-local-introduce m) 61 (syntax-local-introduce u))) 62 (mapping-get chunk-groups m))) 63 chunk-mentions)]) 64 #`(begin body ... (let ([b-id (void)]) b-use) ...))) 65 66 (define-for-syntax (strip-comments body) 67 (cond 68 [(syntax? body) 69 (define r (strip-comments (syntax-e body))) 70 (if (eq? r (syntax-e body)) 71 body 72 (datum->syntax body r body body))] 73 [(pair? body) 74 (define a (car body)) 75 (define ad (syntax-e a)) 76 (cond 77 [(and (pair? ad) 78 (memq (syntax-e (car ad)) 79 '(code:comment 80 code:contract))) 81 (strip-comments (cdr body))] 82 [(eq? ad 'code:blank) 83 (strip-comments (cdr body))] 84 [(and (or (eq? ad 'code:hilite) 85 (eq? ad 'code:quote)) 86 (let* ([d (cdr body)] 87 [dd (if (syntax? d) 88 (syntax-e d) 89 d)]) 90 (and (pair? dd) 91 (or (null? (cdr dd)) 92 (and (syntax? (cdr dd)) 93 (null? (syntax-e (cdr dd)))))))) 94 (define d (cdr body)) 95 (define r 96 (strip-comments (car (if (syntax? d) (syntax-e d) d)))) 97 (if (eq? ad 'code:quote) 98 `(quote ,r) 99 r)] 100 [(and (pair? ad) 101 (eq? (syntax-e (car ad)) 102 'code:line)) 103 (strip-comments (append (cdr ad) (cdr body)))] 104 [else (cons (strip-comments a) 105 (strip-comments (cdr body)))])] 106 [else body])) 107 108 (define-for-syntax (extract-chunks exprs) 109 (let loop ([exprs exprs]) 110 (syntax-case exprs () 111 [() (void)] 112 [(expr . exprs) 113 (syntax-case #'expr (define-syntax quote-syntax) 114 [(define-values (lifted) (quote-syntax (a-chunk id body ...))) 115 (eq? (syntax-e #'a-chunk) 'a-chunk) 116 (begin 117 (add-to-chunk! #'id (syntax->list #'(body ...))) 118 (loop #'exprs))] 119 [_ 120 (loop #'exprs)])]))) 121 122 (define-for-syntax ((make-module-begin submod?) stx) 123 (syntax-case stx () 124 [(_) (raise-no-chunks-error)] 125 [(_ body0 . body) 126 (let ([expanded 127 (expand `(,#'module scribble-lp-tmp-name scribble/private/lp 128 ,@(strip-context #'(body0 . body))))]) 129 (syntax-case expanded () 130 [(module name lang (mb . stuff)) 131 (begin (extract-chunks #'stuff) 132 #`(#%module-begin 133 (tangle body0) 134 ;; The `doc` submodule allows a `scribble/lp` module 135 ;; to be provided to `scribble`: 136 #,@(if submod? 137 (list 138 (let ([submod 139 (strip-context 140 #`(module doc scribble/doclang2 141 (require scribble/manual 142 (only-in scribble/private/lp chunk CHUNK)) 143 (begin body0 . body)))]) 144 (syntax-case submod () 145 [(_ . rest) 146 (datum->syntax submod (cons #'module* #'rest))]))) 147 '())))]))])) 148 149 (define-syntax module-begin/plain (make-module-begin #f)) 150 (define-syntax module-begin/doc (make-module-begin #t)) 151 152 (define-for-syntax (raise-no-chunks-error) 153 (raise-syntax-error 'scribble/lp "no chunks"))