suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Added #:no-auto-require, added partial support for #, in chunks.

Browse Source
This commit is contained in:
Georges Dupéron 2016-08-01 18:11:42 +02:00
parent d62546af81
commit 32821668c0
3 changed files with 58 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
private/common.rkt
View File

@ -147,16 +147,22 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require (only-in typed/racket)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WORKAROUND ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require (for-syntax racket/pretty))
(require (for-syntax racket/pretty
"no-auto-require.rkt"))
(define-for-syntax ((make-module-begin submod?) stx)
(syntax-parse stx
[(_modbeg (lang:id (~optional (~and no-require-lang #:no-require-lang)))
[(_modbeg (lang:id (~optional (~and no-require-lang #:no-require-lang))
(~optional (~and no-auto-require #:no-auto-require)))
body0 . body)
(let ()
(define lang-sym (syntax-e #'lang))
(let ([expanded
(expand `(,#'module
scribble-lp-tmp-name hyper-literate/private/lp
(require (for-syntax racket/base
hyper-literate/private/no-auto-require))
(begin-for-syntax (set-box! no-auto-require?
,(if (attribute no-auto-require) #t #f)))
(define-syntax-rule (if-preexpanding a b) a)
(define-syntax-rule (when-preexpanding . b) (begin . b))
(define-syntax-rule (unless-preexpanding . b) (begin))
@ -204,11 +210,15 @@
;; and make these identifiers exported by
;; hyper-literate
(strip-context
#'(#;(define-syntax-rule (if-preexpanding a b)
#`((require (for-syntax racket/base
hyper-literate/private/no-auto-require))
(begin-for-syntax (set-box! no-auto-require?
#,(if (attribute no-auto-require) #t #f)))
(define-syntax-rule (if-preexpanding a b)
b)
#;(define-syntax-rule (when-preexpanding . b)
(define-syntax-rule (when-preexpanding . b)
(begin))
#;(define-syntax-rule
(define-syntax-rule
(unless-preexpanding . b)
(begin . b))
(require scribble/manual

125
private/lp.rkt
View File

@ -20,6 +20,7 @@
(define (init-chunk-number id)
(free-identifier-mapping-put! chunk-numbers id 2)))
(require (for-syntax "no-auto-require.rkt"))
(define-for-syntax ((make-chunk racketblock unsyntax?) stx)
(syntax-parse stx
[(_ (~optional (~seq #:save-as save-as)) name expr ...)
@ -46,100 +47,52 @@
;; Later support for UNSYNTAX within @CHUNK may be added.
(if unsyntax?
;; New hack:
(let ()
(display (syntax->datum #'name))
(display " 1 ")
(displayln (hash-ref (syntax-debug-info #'name) 'context))
#;(syntax-local-lift-expression
#'(quote-syntax (a-chunk name (expr ...))))
(syntax-local-lift-module-end-declaration
#'(begin
(require macro-debugger/syntax-browser)
(define-syntax (step3 stx22)
(syntax-case stx22 ()
[(_ aaa bbb xxx)
(let ()
(define +aaa (make-syntax-delta-introducer #'aaa (datum->syntax #f 'none)))
(define +bbb (make-syntax-delta-introducer (syntax-local-identifier-as-binding #'bbb) (datum->syntax #f 'none)))
(define aaa-bbb (+bbb (+aaa (datum->syntax #f 'none) 'add) 'remove))
(define bbb-aaa (+aaa (+bbb (datum->syntax #f 'none) 'add) 'remove))
(define +_aaa-bbb (make-syntax-delta-introducer aaa-bbb (datum->syntax #f 'none)))
(define +_bbb-aaa (make-syntax-delta-introducer aaa-bbb (datum->syntax #f 'none)))
(newline)
(display "aaaU ") (displayln (hash-ref (syntax-debug-info (syntax-local-identifier-as-binding #'aaa)) 'context))
(display "bbb ") (displayln (hash-ref (syntax-debug-info #'bbb) 'context))
(display "+aaa ") (displayln (hash-ref (syntax-debug-info (+aaa (datum->syntax #f 'none) 'add)) 'context))
(display "+bbb ") (displayln (hash-ref (syntax-debug-info (+bbb (datum->syntax #f 'none) 'add)) 'context))
(display "aaa-bbb ") (displayln (hash-ref (syntax-debug-info aaa-bbb) 'context))
(display "bbb-aaa ") (displayln (hash-ref (syntax-debug-info bbb-aaa) 'context))
(syntax-local-lift-expression (+_aaa-bbb #'xxx 'remove))
#'(void))]))
(define-syntax (fo _)
(define a #'here)
(define b (syntax-local-introduce #'here))
(define intr (make-syntax-delta-introducer b a))
(display (syntax->datum #'name))
(display " 2 ")
(displayln (hash-ref (syntax-debug-info #'name) 'context))
(display "a2 ")
(displayln (hash-ref (syntax-debug-info a) 'context))
(display "b2 ")
(displayln (hash-ref (syntax-debug-info b) 'context))
(display "i2 ")
(displayln (hash-ref (syntax-debug-info (intr (datum->syntax #f 'xxx) 'add)) 'context))
#;(syntax-local-lift-expression
#`(quote-syntax (a-chunk xyz
(begin
(displayln "hi")
(require macro-debugger/syntax-browser)
(browse-syntax (quote-syntax (a-chunk name expr ...)))))))
#;(syntax-local-lift-expression
#`(quote-syntax (a-chunk name
;#,(hash-ref (syntax-debug-info a) 'context)
;#,(hash-ref (syntax-debug-info b) 'context)
expr ...)))
#;#'(begin)
#`(step3 #,a
#,b
(quote-syntax (a-chunk name
;#,(hash-ref (syntax-debug-info a) 'context)
;#,(hash-ref (syntax-debug-info b) 'context)
expr ...))))
(fo))));(quote-syntax (a-chunk name expr ...)))
(syntax-local-lift-module-end-declaration
#'(begin
(define-syntax (macro-to-expand-unsyntax _)
(define a #'here)
(define b (syntax-local-identifier-as-binding
(syntax-local-introduce #'here)))
(define intr (make-syntax-delta-introducer b a))
(syntax-local-lift-expression
(intr #`(quote-syntax (a-chunk name expr ...)) 'flip))
#'(begin))
(macro-to-expand-unsyntax)))
;; Default (old) behaviour, which does not support escaping (via #,):
(syntax-local-lift-expression
#'(quote-syntax (a-chunk name (expr ...)))))
;; Extract require forms
(with-syntax ([tag tag]
[str str]
[((for-label-mod ...) ...)
(map (lambda (expr)
(syntax-case expr (require)
[(require mod ...)
(let loop ([mods (syntax->list #'(mod ...))])
(cond
[(null? mods) null]
[else
(syntax-case (car mods)
(for-syntax quote submod)
[(submod ".." . _)
(loop (cdr mods))]
[(submod "." . _)
(loop (cdr mods))]
[(quote x)
(loop (cdr mods))]
[(for-syntax x ...)
(append (loop (syntax->list #'(x ...)))
(loop (cdr mods)))]
[x
(cons #'x (loop (cdr mods)))])]))]
[else null]))
(syntax->list #'(expr ...)))]
(if (unbox no-auto-require?)
#'()
(map (lambda (expr)
(syntax-case expr (require)
[(require mod ...)
(let loop ([mods (syntax->list
#'(mod ...))])
(cond
[(null? mods) null]
[else
(syntax-case (car mods)
(for-syntax quote submod)
[(submod ".." . _)
(loop (cdr mods))]
[(submod "." . _)
(loop (cdr mods))]
[(quote x)
(loop (cdr mods))]
[(for-syntax x ...)
(append (loop (syntax->list
#'(x ...)))
(loop (cdr mods)))]
[x
(cons #'x (loop (cdr mods)))])]))]
[else null]))
(syntax->list #'(expr ...))))]
[(rest ...) (if n
#`((subscript #,(format "~a" n)))

4
private/no-auto-require.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang racket/base
(provide no-auto-require?)
(define no-auto-require? (box #f))