98 lines
3.6 KiB
Racket
98 lines
3.6 KiB
Racket
#lang scheme/base
|
|
|
|
(provide (except-out (all-from-out scheme/base) #%module-begin)
|
|
(rename-out [module-begin #%module-begin]))
|
|
|
|
(require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase
|
|
syntax/strip-context))
|
|
|
|
;; --- MF: bad hack for getting rid of comments
|
|
(provide code:comment)
|
|
(define-syntax (code:comment stx)
|
|
(if (eq? (syntax-local-context) 'expression)
|
|
(syntax (void))
|
|
(syntax (define (f x) x))))
|
|
;; --- MF
|
|
|
|
(begin-for-syntax
|
|
(define first-id #f)
|
|
(define main-id #f)
|
|
(define (mapping-get mapping id)
|
|
(free-identifier-mapping-get mapping id (lambda () '())))
|
|
;; maps a chunk identifier to its collected expressions
|
|
(define chunks (make-free-identifier-mapping))
|
|
;; maps a chunk identifier to all identifiers that are used to define it
|
|
(define chunk-groups (make-free-identifier-mapping))
|
|
(define (get-chunk id) (mapping-get chunks id))
|
|
(define (add-to-chunk! id exprs)
|
|
(unless first-id (set! first-id id))
|
|
(when (eq? (syntax-e id) '<*>) (set! main-id id))
|
|
(free-identifier-mapping-put!
|
|
chunk-groups id
|
|
(cons id (mapping-get chunk-groups id)))
|
|
(free-identifier-mapping-put!
|
|
chunks id
|
|
`(,@(mapping-get chunks id) ,@exprs))))
|
|
|
|
(define-syntax (tangle stx)
|
|
(define chunk-mentions '())
|
|
(define stupid-internal-definition-sytnax
|
|
(unless first-id
|
|
(raise-syntax-error 'scribble/lp "no chunks")))
|
|
(define orig-stx (syntax-case stx () [(_ orig) #'orig]))
|
|
(define (restore nstx d) (datum->syntax orig-stx d nstx nstx))
|
|
(define (shift nstx) (replace-context orig-stx nstx))
|
|
(define body
|
|
(let ([main-id (or main-id first-id)])
|
|
(restore
|
|
main-id
|
|
(let loop ([block (get-chunk main-id)])
|
|
(append-map
|
|
(lambda (expr)
|
|
(if (identifier? expr)
|
|
(let ([subs (get-chunk expr)])
|
|
(if (pair? subs)
|
|
(begin (set! chunk-mentions (cons expr chunk-mentions))
|
|
(loop subs))
|
|
(list (shift expr))))
|
|
(let ([subs (syntax->list expr)])
|
|
(if subs
|
|
(list (restore expr (loop subs)))
|
|
(list (shift expr))))))
|
|
block)))))
|
|
(with-syntax ([(body ...) body]
|
|
;; construct arrows manually
|
|
[((b-use b-id) ...)
|
|
(append-map (lambda (m)
|
|
(map (lambda (u)
|
|
(list (syntax-local-introduce m)
|
|
(syntax-local-introduce u)))
|
|
(mapping-get chunk-groups m)))
|
|
chunk-mentions)])
|
|
#`(begin body ... (let ([b-id (void)]) b-use) ...)))
|
|
|
|
(define-for-syntax (extract-chunks exprs)
|
|
(let loop ([exprs exprs])
|
|
(syntax-case exprs ()
|
|
[() (void)]
|
|
[(expr . exprs)
|
|
(syntax-case #'expr (define-syntax quote-syntax)
|
|
[(define-values (lifted) (quote-syntax (a-chunk id body ...)))
|
|
(eq? (syntax-e #'a-chunk) 'a-chunk)
|
|
(begin
|
|
(add-to-chunk! #'id (syntax->list #'(body ...)))
|
|
(loop #'exprs))]
|
|
[_
|
|
(loop #'exprs)])])))
|
|
|
|
(define-syntax (module-begin stx)
|
|
(syntax-case stx ()
|
|
[(_ id exprs . body)
|
|
(let ([expanded
|
|
(expand `(,#'module scribble-lp-tmp-name scribble/private/lp
|
|
,@(strip-context #'(id exprs . body))))])
|
|
(syntax-case expanded ()
|
|
[(module name lang (mb . stuff))
|
|
(begin (extract-chunks #'stuff)
|
|
#'(#%module-begin (tangle id)))]))]))
|