common.rkt (12323B)
1 #lang racket/base 2 ;; Forked from scribble-lib/scribble/lp/lang/common.rkt 3 4 (provide (except-out (all-from-out racket/base) #%module-begin) 5 module-begin/plain 6 module-begin/doc) 7 8 (require (for-syntax racket/base syntax/boundmap racket/list 9 syntax/strip-context 10 syntax/srcloc 11 racket/struct 12 syntax/srcloc 13 debug-scopes/named-scopes/exptime)) 14 15 (begin-for-syntax 16 (define first-id #f) 17 (define main-id #f) 18 (define (mapping-get mapping id) 19 (free-identifier-mapping-get mapping id (lambda () '()))) 20 ;; maps a chunk identifier to its collected expressions 21 (define chunks (make-free-identifier-mapping)) 22 ;; maps a chunk identifier to all identifiers that are used to define it 23 (define chunk-groups (make-free-identifier-mapping)) 24 (define (get-chunk id) (mapping-get chunks id)) 25 (define (add-to-chunk! id exprs) 26 (unless first-id (set! first-id id)) 27 (when (eq? (syntax-e id) '<*>) (set! main-id id)) 28 (free-identifier-mapping-put! 29 chunk-groups id 30 (cons id (mapping-get chunk-groups id))) 31 (free-identifier-mapping-put! 32 chunks id 33 `(,@(mapping-get chunks id) ,@exprs)))) 34 35 (define-for-syntax (tangle orig-stx) 36 (define chunk-mentions '()) 37 (unless first-id 38 (raise-syntax-error 'scribble/lp "no chunks")) 39 (define (restore nstx d) (datum->syntax orig-stx d nstx nstx)) 40 (define (shift nstx) (replace-context orig-stx nstx)) 41 (define body 42 (let ([main-id (or main-id first-id)]) 43 (restore 44 main-id 45 (let loop ([block (get-chunk main-id)]) 46 (append-map 47 (lambda (expr) 48 (if (identifier? expr) 49 (let ([subs (get-chunk expr)]) 50 (if (pair? subs) 51 (begin (set! chunk-mentions (cons expr chunk-mentions)) 52 (loop subs)) 53 (list (shift expr)))) 54 (let ([subs (syntax->list expr)]) 55 (if subs 56 (list (restore expr (loop subs))) 57 (list (shift expr)))))) 58 block))))) 59 (with-syntax ([body (strip-comments body)] 60 ;; Hopefully the scopes are correct enough on the whole body. 61 [body0 (syntax-case body () [(a . _) #'a] [a #'a])] 62 ;; construct arrows manually 63 [((b-use b-id) ...) 64 (append-map (lambda (m) 65 (map (lambda (u) 66 (list (syntax-local-introduce m) 67 (syntax-local-introduce u))) 68 (mapping-get chunk-groups m))) 69 chunk-mentions)]) 70 ;; TODO: use disappeared-use and disappeared-binding. 71 ;; TODO: fix srcloc (already fixed?). 72 ;#`(#,(datum->syntax #'body0 'begin) (let ([b-id (void)]) b-use) ... body0 body ...) 73 (syntax-property 74 (syntax-property #`(#,(datum->syntax #'body0 'begin) . body) 75 'disappeared-binding (syntax->list (syntax-local-introduce #'(b-id ...)))) 76 'disappeared-use (syntax->list (syntax-local-introduce #'(b-use ...)))))) 77 78 (define-for-syntax (strip-comments body) 79 (cond 80 [(syntax? body) 81 (define r (strip-comments (syntax-e body))) 82 (if (eq? r (syntax-e body)) 83 body 84 (datum->syntax body r body body))] 85 [(pair? body) 86 (define a (car body)) 87 (define ad (syntax-e a)) 88 (cond 89 [(and (pair? ad) 90 (memq (syntax-e (car ad)) 91 '(code:comment 92 code:contract))) 93 (strip-comments (cdr body))] 94 [(eq? ad 'code:blank) 95 (strip-comments (cdr body))] 96 [(and (or (eq? ad 'code:hilite) 97 (eq? ad 'code:quote)) 98 (let* ([d (cdr body)] 99 [dd (if (syntax? d) 100 (syntax-e d) 101 d)]) 102 (and (pair? dd) 103 (or (null? (cdr dd)) 104 (and (syntax? (cdr dd)) 105 (null? (syntax-e (cdr dd)))))))) 106 (define d (cdr body)) 107 (define r 108 (strip-comments (car (if (syntax? d) (syntax-e d) d)))) 109 (if (eq? ad 'code:quote) 110 `(quote ,r) 111 r)] 112 [(and (pair? ad) 113 (eq? (syntax-e (car ad)) 114 'code:line)) 115 (if (null? (cdr body)) 116 (strip-comments (cdr ad)) 117 (strip-comments (append (cdr ad) (cdr body))))] 118 [else (cons (strip-comments a) 119 (strip-comments (cdr body)))])] 120 [else body])) 121 122 (define-for-syntax (extract-chunks exprs) 123 (let loop ([exprs exprs]) 124 (syntax-case exprs () 125 [() (void)] 126 [(expr . exprs) 127 (syntax-case #'expr (define-values quote-syntax) 128 [(define-values (lifted) (quote-syntax (a-chunk id body ...))) 129 (eq? (syntax-e #'a-chunk) 'a-chunk) 130 (begin 131 (add-to-chunk! #'id (syntax->list #'(body ...))) 132 (loop #'exprs))] 133 [_ 134 (loop #'exprs)])]))) 135 136 (require (for-syntax racket/syntax 137 syntax/parse)) 138 139 (require (for-syntax racket/pretty 140 "no-auto-require.rkt")) 141 142 (define-for-syntax (strip-source e) 143 (cond [(syntax? e) 144 (update-source-location 145 (datum->syntax e (strip-source (syntax-e e)) e e) 146 #:source #f)] 147 [(pair? e) (cons (strip-source (car e)) (strip-source (cdr e)))] 148 [(vector? e) (list->vector (strip-source (vector->list e)))] 149 [(prefab-struct-key e) 150 => (λ (k) (make-prefab-struct k (strip-source (struct->list e))))] 151 ;; TODO: hash tables 152 [else e])) 153 154 ;; Many thanks to Alex Knauth and Matthew Flatt for finding out how to make 155 ;; module meta-languages. 156 (define-syntax (continue stx) 157 (syntax-case stx () 158 [(_self lang-module-begin maybe-chain₊ . body) 159 (let () 160 (define ch₊ (syntax->list #'maybe-chain₊)) 161 (define expanded (local-expand 162 (datum->syntax stx 163 `(,#'lang-module-begin ,@ch₊ . ,#'body) 164 stx 165 stx) 166 'module-begin 167 (list))) 168 (define meta-language-nesting 169 ;; Use a module-like scope here, instead of (make-syntax-introducer), 170 ;; otherwise DrRacket stops drawing some arrows (why?). 171 (make-module-like-named-scope 'meta-language-nesting)) 172 (syntax-case expanded (#%plain-module-begin) 173 [(#%plain-module-begin . expanded-body) 174 #`(begin 175 . 176 #,(meta-language-nesting #'expanded-body))]))])) 177 178 (define-for-syntax ((make-module-begin submod?) stx) 179 (syntax-parse stx 180 ;; #:no-require-lang is ignored, but still allowed for compatibility. 181 ;; TODO: semantically, the no-require-lang and no-auto-require should be 182 ;; before the lang, as they are arguments to hyper-literate itself. 183 [(_modbeg {~or (lang:id 184 {~optional (~and no-require-lang #:no-require-lang)} 185 {~optional (~and no-auto-require #:no-auto-require)}) 186 ({~optional (~and no-auto-require #:no-auto-require)} 187 (lang:id 188 . chain₊))} 189 body0 . body) 190 (let () 191 (define lang-sym (syntax-e #'lang)) 192 (let ([expanded 193 (expand `(,#'module 194 scribble-lp-tmp-name hyper-literate/private/lp 195 (require hyper-literate/private/chunks-toc-prefix 196 (for-syntax racket/base 197 hyper-literate/private/no-auto-require)) 198 (begin-for-syntax (set-box! no-auto-require? 199 ,(if (attribute no-auto-require) #t #f)) 200 (set-box! preexpanding? #t)) 201 (define-syntax-rule (if-preexpanding a b) a) 202 (define-syntax-rule (when-preexpanding . b) (begin . b)) 203 (define-syntax-rule (unless-preexpanding . b) (begin)) 204 ,@(strip-context #'(body0 . body))))]) 205 (syntax-case expanded () 206 [(module name elang (mb . stuff)) 207 (let () 208 (extract-chunks #'stuff) 209 (define/with-syntax tngl 210 (tangle #'body0)) 211 (define/with-syntax mb9 (datum->syntax #f '#%module-begin)) 212 (define/with-syntax lang-modbeg (datum->syntax #'lang '#%module-begin)) 213 ; See http://stackoverflow.com/questions/37867859/module-meta-language-in-racket : 214 #;(define expanded-main-mod-stx 215 (local-expand 216 (syntax-local-introduce 217 (datum->syntax #f `(,#'module ignored ,(datum->syntax #f lang-sym #'lang #'lang) (,#'mb9 ,(syntax-local-introduce #'tngl))))) 218 'top-level 219 (list))) 220 ;(syntax-case expanded-main-mod-stx ();(module #%plain-module-begin) 221 ;[(module _ lng11 (#%plain-module-begin . mod-body11)) 222 #`(#%plain-module-begin 223 #,@(if submod? 224 (list 225 (with-syntax* 226 ([ctx #'body0 #;(syntax-local-introduce #'body0)] 227 ;; TODO: this is a hack, it would be nice to get 228 ;; the actual source location of the lang. 229 [bd1 (update-source-location #'body0 230 #:line #f 231 #:column #f 232 #:position 7 233 #:span 14)] 234 [lng (datum->syntax #'ctx 'scribble/doclang2 #'bd1 #'bd1)] 235 [begn (datum->syntax #'ctx 'begin)]) 236 (strip-source 237 #`(module* doc lng ;module doc scribble/doclang2 238 #,@(syntax-local-introduce 239 ;; TODO: instead use: 240 ;; (begin-for-syntax (set! preexpanding #f)) 241 ;; and make these identifiers exported by 242 ;; hyper-literate 243 (strip-context 244 #`((require hyper-literate/private/chunks-toc-prefix 245 (for-syntax racket/base 246 hyper-literate/private/no-auto-require)) 247 (begin-for-syntax 248 (set-box! no-auto-require? 249 #,(if (attribute no-auto-require) #t #f)) 250 (set-box! preexpanding? #f)) 251 (define-syntax-rule (if-preexpanding a b) 252 b) 253 (define-syntax-rule (when-preexpanding . b) 254 (begin)) 255 (define-syntax-rule (unless-preexpanding . b) 256 (begin . b)) 257 (require scribble-enhanced/with-manual 258 hyper-literate)))) 259 (begn body0 . body))))) 260 '()) 261 (require lang) 262 (continue lang-modbeg 263 #,(if (attribute chain₊) 264 #'(chain₊) 265 #'()) 266 tngl)) ;; TODO: put . tngl and remove the (begin _) 267 )])))])) 268 269 (define-syntax module-begin/plain (make-module-begin #f)) 270 (define-syntax module-begin/doc (make-module-begin #t))