Fixed potential conflicts with the injected (require lang).
This commit is contained in:
Georges Dupéron
parent
ae152d4ab9
commit
fef2ed1769
2
info.rkt
2
info.rkt
|
|
@ -17,5 +17,5 @@
|
|||
("test/test.hl.rkt" () (omit-start))
|
||||
("test/test2.hl.rkt" () (omit-start))))
|
||||
(define pkg-desc "Description Here")
|
||||
(define version "0.0")
|
||||
(define version "0.1")
|
||||
(define pkg-authors '(|Georges Dupéron|))
|
||||
|
|
|
|||
23
lang/first-line-utils.rkt
Normal file
23
lang/first-line-utils.rkt
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/port)
|
||||
|
||||
(provide read-syntax-whole-first-line)
|
||||
|
||||
(define (read-line-length port)
|
||||
(let* ([peeking (peeking-input-port port)]
|
||||
[start (file-position peeking)]
|
||||
[_ (read-line peeking)]
|
||||
[end (file-position peeking)])
|
||||
(- end start)))
|
||||
|
||||
(define (narrow-to-one-line port)
|
||||
(make-limited-input-port port (read-line-length port)))
|
||||
|
||||
(define (read-syntax-whole-first-line source-name in)
|
||||
(define in1 (narrow-to-one-line in))
|
||||
(let loop ([res '()])
|
||||
(define res+ (read-syntax source-name in1))
|
||||
(if (eof-object? res+)
|
||||
(reverse res)
|
||||
(loop (cons res+ res)))))
|
||||
|
|
@ -1,31 +1,19 @@
|
|||
#lang racket/base
|
||||
|
||||
(require scribble/reader
|
||||
racket/port)
|
||||
racket/port
|
||||
racket/syntax
|
||||
syntax/strip-context
|
||||
"first-line-utils.rkt")
|
||||
|
||||
(provide meta-read-inside
|
||||
meta-read-syntax-inside)
|
||||
|
||||
(define (read-line-length port)
|
||||
(let* ([peeking (peeking-input-port port)]
|
||||
[start (file-position peeking)]
|
||||
[_ (read-line peeking)]
|
||||
[end (file-position peeking)])
|
||||
(- end start)))
|
||||
|
||||
(define (narrow-to-one-line port)
|
||||
(make-limited-input-port port (read-line-length port)))
|
||||
|
||||
(define (meta-read-inside in . args)
|
||||
(displayln args)
|
||||
(apply read-inside args))
|
||||
|
||||
(define (meta-read-syntax-inside source-name in . args)
|
||||
(define in1 (narrow-to-one-line in))
|
||||
(with-syntax ([rd1 (let loop ([res '()])
|
||||
(define res+ (read-syntax source-name in1))
|
||||
(if (eof-object? res+)
|
||||
(reverse res)
|
||||
(loop (cons res+ res))))]
|
||||
[rd (apply read-syntax-inside source-name in args)])
|
||||
(with-syntax* ([rd1 (read-syntax-whole-first-line source-name in)]
|
||||
[rd (apply read-syntax-inside source-name in args)])
|
||||
#'(rd1 . rd)))
|
||||
|
|
@ -9,8 +9,29 @@ hyper-literate/lang
|
|||
;; don't use scribble-base-info for the #:info arg, since
|
||||
;; scribble/lp files are not directly scribble'able.
|
||||
#:language-info (scribble-base-language-info)
|
||||
#:info (scribble-base-reader-info)
|
||||
#:info (wrapped-scribble-base-reader-info)
|
||||
(require "meta-first-line.rkt"
|
||||
(only-in scribble/base/reader
|
||||
scribble-base-reader-info
|
||||
scribble-base-language-info))
|
||||
scribble-base-language-info)
|
||||
"first-line-utils.rkt")
|
||||
|
||||
(define orig-scribble-base-reader-info
|
||||
(scribble-base-reader-info))
|
||||
|
||||
(define (wrapped-scribble-base-reader-info)
|
||||
(lambda (key defval default)
|
||||
(case key
|
||||
[(color-lexer)
|
||||
(let ([lexr (orig-scribble-base-reader-info key defval default)])
|
||||
(let ([first? #t])
|
||||
(λ (in offset mode)
|
||||
(when first?
|
||||
(set! first? #f)
|
||||
;; TODO: should return (values "#:opt" 'hash-colon-keyword …) for
|
||||
;; the options
|
||||
(read-syntax-whole-first-line (object-name in) in))
|
||||
;; Note that offset and mode are optional
|
||||
(lexr in offset mode))))]
|
||||
[else
|
||||
(orig-scribble-base-reader-info key defval default)])))
|
||||
|
|
|
|||
|
|
@ -7,6 +7,8 @@
|
|||
|
||||
(require (for-syntax racket/base syntax/boundmap racket/list
|
||||
syntax/strip-context
|
||||
syntax/srcloc
|
||||
racket/struct
|
||||
syntax/srcloc))
|
||||
|
||||
(begin-for-syntax
|
||||
|
|
@ -29,30 +31,14 @@
|
|||
chunks id
|
||||
`(,@(mapping-get chunks id) ,@exprs))))
|
||||
|
||||
(define-for-syntax (tangle orig-stx req-lng)
|
||||
(define-for-syntax (tangle orig-stx)
|
||||
(define chunk-mentions '())
|
||||
(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)])
|
||||
;; HACK to get arrows drawn for built-ins imported by the module language.
|
||||
;; TODO: it fails with type-expander.lp2.rkt, because it re-requires λ
|
||||
;; (the new-λ) from 'main.
|
||||
(when req-lng
|
||||
(free-identifier-mapping-put!
|
||||
chunk-groups main-id
|
||||
(cons main-id (mapping-get chunk-groups main-id)))
|
||||
(free-identifier-mapping-put!
|
||||
chunks main-id
|
||||
`(,#`(require #,(datum->syntax main-id
|
||||
req-lng
|
||||
req-lng
|
||||
req-lng))
|
||||
,@(mapping-get chunks main-id))))
|
||||
;;;;;;;;;;;;;;
|
||||
(restore
|
||||
main-id
|
||||
(let loop ([block (get-chunk main-id)])
|
||||
|
|
@ -69,7 +55,7 @@
|
|||
(list (restore expr (loop subs)))
|
||||
(list (shift expr))))))
|
||||
block)))))
|
||||
(with-syntax ([(body ...) (strip-comments body)]
|
||||
(with-syntax ([(body0 body ...) (strip-comments body)]
|
||||
;; construct arrows manually
|
||||
[((b-use b-id) ...)
|
||||
(append-map (lambda (m)
|
||||
|
|
@ -78,12 +64,13 @@
|
|||
(syntax-local-introduce u)))
|
||||
(mapping-get chunk-groups m)))
|
||||
chunk-mentions)])
|
||||
;(displayln (dynamic-require 'tyyyyyyyyyyyped/racket '#%module-begin))
|
||||
;; TODO: use disappeared-use and disappeared-binding.
|
||||
;; TODO: fix srcloc (already fixed?).
|
||||
#`(begin (let ([b-id (void)]) b-use) ... body ...)
|
||||
#;(replace-context #'#%module-begin;modbeg-ty
|
||||
#`(begin (let ([b-id (void)]) b-use) ... body ...))))
|
||||
;#`(#,(datum->syntax #'body0 'begin) (let ([b-id (void)]) b-use) ... body0 body ...)
|
||||
(syntax-property
|
||||
(syntax-property #`(#,(datum->syntax #'body0 'begin) body0 body ...)
|
||||
'disappeared-binding (syntax->list #'(b-id ...)))
|
||||
'disappeared-use (syntax->list #'(b-use ...)))))
|
||||
|
||||
(define-for-syntax (strip-comments body)
|
||||
(cond
|
||||
|
|
@ -144,18 +131,45 @@
|
|||
(require (for-syntax racket/syntax
|
||||
syntax/parse))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(require (only-in typed/racket)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WORKAROUND ;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(require (for-syntax racket/pretty
|
||||
"no-auto-require.rkt"))
|
||||
|
||||
(define-for-syntax (strip-source e)
|
||||
(cond [(syntax? e)
|
||||
(update-source-location
|
||||
(datum->syntax e (strip-source (syntax-e e)) e e)
|
||||
#:source #f)]
|
||||
[(pair? e) (cons (strip-source (car e)) (strip-source (cdr e)))]
|
||||
[(vector? e) (list->vector (strip-source (vector->list e)))]
|
||||
[(prefab-struct-key e)
|
||||
=> (λ (k) (make-prefab-struct k (strip-source (struct->list e))))]
|
||||
;; TODO: hash tables
|
||||
[else e]))
|
||||
|
||||
;; Many thanks to Alex Knauth and Matthew Flatt for finding out how to make
|
||||
;; module meta-languages.
|
||||
(define-syntax (continue stx)
|
||||
(syntax-case stx ()
|
||||
[(_self lang-module-begin . body)
|
||||
(let ([expanded (local-expand
|
||||
#`(lang-module-begin . body)
|
||||
'module-begin
|
||||
(list))])
|
||||
(syntax-case expanded (#%plain-module-begin)
|
||||
[(#%plain-module-begin . expanded-body)
|
||||
#`(begin
|
||||
.
|
||||
#,((make-syntax-introducer) #'expanded-body))]))]))
|
||||
|
||||
(define-for-syntax ((make-module-begin submod?) stx)
|
||||
(syntax-parse stx
|
||||
;; #:no-require-lang is ignored, but still allowed for compatibility.
|
||||
[(_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))
|
||||
(displayln (list (syntax-source #'lang) (syntax-line #'lang) (syntax-column #'lang) (syntax-position #'lang) (syntax-original? #'lang)))
|
||||
(let ([expanded
|
||||
(expand `(,#'module
|
||||
scribble-lp-tmp-name hyper-literate/private/lp
|
||||
|
|
@ -163,7 +177,8 @@
|
|||
(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)))
|
||||
,(if (attribute no-auto-require) #t #f))
|
||||
(set-box! preexpanding? #t))
|
||||
(define-syntax-rule (if-preexpanding a b) a)
|
||||
(define-syntax-rule (when-preexpanding . b) (begin . b))
|
||||
(define-syntax-rule (unless-preexpanding . b) (begin))
|
||||
|
|
@ -172,25 +187,20 @@
|
|||
[(module name elang (mb . stuff))
|
||||
(let ()
|
||||
(extract-chunks #'stuff)
|
||||
(dynamic-require lang-sym #f)
|
||||
(namespace-require `(for-meta -1 ,lang-sym))
|
||||
#;(begin
|
||||
(define/with-syntax tngl (tangle #'body0))
|
||||
(define/with-syntax (tngl0 . tngl*) #'tngl)
|
||||
(define/with-syntax (ex-mod ex-nam ex-lng (ex-#%m . ex-rest))
|
||||
(expand-syntax
|
||||
#`(#,#'module hyper-literate-temp-expand #,lang-sym
|
||||
#,(replace-context #'here #'tngl))))
|
||||
#`(ex-#%m #,(datum->syntax (syntax-local-introduce #'ex-rest)
|
||||
'(#%require lang-sym))
|
||||
. ex-rest))
|
||||
(define/with-syntax tngl
|
||||
(tangle #'body0 (if (attribute no-require-lang) #f #'lang)))
|
||||
;(replace-context
|
||||
;(namespace-symbol->identifier '#%module-begin)
|
||||
;#`(#,(syntax/loc #'lang #%module-begin) …)
|
||||
#`(#,(namespace-symbol->identifier '#%module-begin)
|
||||
tngl
|
||||
(tangle #'body0))
|
||||
(define/with-syntax mb9 (datum->syntax #f '#%module-begin))
|
||||
(define/with-syntax lang-modbeg (datum->syntax #'lang '#%module-begin))
|
||||
; See http://stackoverflow.com/questions/37867859/module-meta-language-in-racket :
|
||||
#;(define expanded-main-mod-stx
|
||||
(local-expand
|
||||
(syntax-local-introduce
|
||||
(datum->syntax #f `(,#'module ignored ,(datum->syntax #f lang-sym #'lang #'lang) (,#'mb9 ,(syntax-local-introduce #'tngl)))))
|
||||
'top-level
|
||||
(list)))
|
||||
;(syntax-case expanded-main-mod-stx ();(module #%plain-module-begin)
|
||||
;[(module _ lng11 (#%plain-module-begin . mod-body11))
|
||||
#`(#%plain-module-begin
|
||||
#,@(if submod?
|
||||
(list
|
||||
(with-syntax*
|
||||
|
|
@ -204,32 +214,34 @@
|
|||
#:span 14)]
|
||||
[lng (datum->syntax #'ctx 'scribble/doclang2 #'bd1 #'bd1)]
|
||||
[begn (datum->syntax #'ctx 'begin)])
|
||||
#`(module* doc lng ;module doc scribble/doclang2
|
||||
#,@(syntax-local-introduce
|
||||
;; TODO: instead use:
|
||||
;; (begin-for-syntax (set! preexpanding #f))
|
||||
;; and make these identifiers exported by
|
||||
;; hyper-literate
|
||||
(strip-context
|
||||
#`((require hyper-literate/private/chunks-toc-prefix
|
||||
(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)
|
||||
(begin))
|
||||
(define-syntax-rule (unless-preexpanding . b)
|
||||
(begin . b))
|
||||
(require scribble-enhanced/with-manual
|
||||
hyper-literate))))
|
||||
(begn body0 . body))
|
||||
;(strip-context
|
||||
#;#`(modl doc lng ;module doc scribble/doclang2
|
||||
|
||||
(begn body0 . body))))
|
||||
'())))])))]))
|
||||
(strip-source
|
||||
#`(module* doc lng ;module doc scribble/doclang2
|
||||
#,@(syntax-local-introduce
|
||||
;; TODO: instead use:
|
||||
;; (begin-for-syntax (set! preexpanding #f))
|
||||
;; and make these identifiers exported by
|
||||
;; hyper-literate
|
||||
(strip-context
|
||||
#`((require hyper-literate/private/chunks-toc-prefix
|
||||
(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))
|
||||
(set-box! preexpanding? #f))
|
||||
(define-syntax-rule (if-preexpanding a b)
|
||||
b)
|
||||
(define-syntax-rule (when-preexpanding . b)
|
||||
(begin))
|
||||
(define-syntax-rule (unless-preexpanding . b)
|
||||
(begin . b))
|
||||
(require scribble-enhanced/with-manual
|
||||
hyper-literate))))
|
||||
(begn body0 . body)))))
|
||||
'())
|
||||
(require lang)
|
||||
(continue lang-modbeg tngl)) ;; TODO: put . tngl and remove the (begin _)
|
||||
)])))]))
|
||||
|
||||
(define-syntax module-begin/plain (make-module-begin #f))
|
||||
(define-syntax module-begin/doc (make-module-begin #t))
|
||||
|
|
|
|||
|
|
@ -7,7 +7,9 @@
|
|||
(for-syntax scheme/base
|
||||
syntax/boundmap
|
||||
syntax/parse
|
||||
racket/syntax))
|
||||
racket/syntax
|
||||
racket/struct
|
||||
syntax/srcloc))
|
||||
|
||||
(begin-for-syntax
|
||||
;; maps chunk identifiers to a counter, so we can distinguish multiple uses
|
||||
|
|
@ -113,6 +115,18 @@
|
|||
#'()
|
||||
#'((require (for-label for-label-mod ... ...))))))]))
|
||||
|
||||
(define-for-syntax (strip-source e)
|
||||
(cond [(syntax? e)
|
||||
(update-source-location
|
||||
(datum->syntax e (strip-source (syntax-e e)) e e)
|
||||
#:source #f)]
|
||||
[(pair? e) (cons (strip-source (car e)) (strip-source (cdr e)))]
|
||||
[(vector? e) (list->vector (strip-source (vector->list e)))]
|
||||
[(prefab-struct-key e)
|
||||
=> (λ (k) (make-prefab-struct k (strip-source (struct->list e))))]
|
||||
;; TODO: hash tables
|
||||
[else e]))
|
||||
|
||||
(define-for-syntax ((make-chunk-display racketblock) stx)
|
||||
(syntax-parse stx
|
||||
;; no need for more error checking, using chunk for the code will do that
|
||||
|
|
@ -153,7 +167,8 @@
|
|||
`(elem (prefixable
|
||||
,@(chunks-toc-prefix)
|
||||
tag))))))
|
||||
(#,racketblock expr ...))))]))
|
||||
(#,racketblock . #,(strip-source #'(expr ...))
|
||||
))))]))
|
||||
|
||||
(define-for-syntax (make-chunk chunk-code chunk-display)
|
||||
(syntax-parser
|
||||
|
|
@ -175,7 +190,9 @@
|
|||
(define/with-syntax stx-chunk-display chunk-display)
|
||||
|
||||
#`(begin
|
||||
(stx-chunk-code name expr ...)
|
||||
(stx-chunk-code name . #,(if preexpanding?
|
||||
#'(expr ...)
|
||||
#'(expr ...) #;(strip-source #'(expr ...))))
|
||||
#,@(if n
|
||||
#'()
|
||||
#'((define-syntax name (make-element-id-transformer
|
||||
|
|
@ -209,7 +226,7 @@
|
|||
(quote-syntax name))]
|
||||
[(local-expr (... ...))
|
||||
(syntax-local-introduce
|
||||
(quote-syntax (expr ...)))])
|
||||
(quote-syntax #,(strip-source #'(expr ...))))])
|
||||
#`(stx-chunk-display
|
||||
local-name
|
||||
newname
|
||||
|
|
@ -217,7 +234,7 @@
|
|||
local-expr (... ...)))])))
|
||||
;; The (list) here could be important, to avoid the code being
|
||||
;; executed multiple times in weird ways, when pre-expanding.
|
||||
#`(list (stx-chunk-display name name stx-n expr ...))))]))
|
||||
#`(list (stx-chunk-display name name stx-n . #,(strip-source #'(expr ...))))))]))
|
||||
|
||||
(define-syntax chunk-code (make-chunk-code #t))
|
||||
(define-syntax CHUNK-code (make-chunk-code #f))
|
||||
|
|
|
|||
|
|
@ -2,3 +2,5 @@
|
|||
|
||||
(provide no-auto-require?)
|
||||
(define no-auto-require? (box #f))
|
||||
(provide preexpanding?)
|
||||
(define preexpanding? (box #f))
|
||||
|
|
@ -52,14 +52,11 @@ The current implementation of hyper-literate needs to inject
|
|||
a @racket[(require _lang)] in the expanded module, in order
|
||||
to have the arrows properly working in DrRacket for
|
||||
"built-in" identifiers which are provided by the
|
||||
@racket[_lang] itself. This extra @racket[require] statement
|
||||
can however conflict with later user-provided
|
||||
@racket[require] statements, which would otherwise shadow
|
||||
the built-ins. The @racket[#:no-require-lang] option
|
||||
disables that behaviour, and has the only drawback that
|
||||
built-ins of the @racket[_lang] language do not have an
|
||||
arrow in DrRacket (but they still should be highlighted with
|
||||
a turquoise background when hovered over with the mouse).
|
||||
@racket[_lang] itself. The @racket[require] statement is
|
||||
injected after the whole ``code'' module has been expanded.
|
||||
It is worth noting that an extra scope is added to the expanded
|
||||
body of the module, in order to make any @racket[require] form
|
||||
within more specific than the @racket[(require _lang)].
|
||||
|
||||
The current implementation of @racketmodname[scribble/lp2],
|
||||
on which @racketmodname[hyper-literate] relies (with a few
|
||||
|
|
@ -78,6 +75,24 @@ possible in this case to disable the feature using
|
|||
@racket[(require (for-label …))] and handle conflicting
|
||||
identifiers in a more fine-grained way.
|
||||
|
||||
@deprecated[#:what @racket[#:no-require-lang] ""]{
|
||||
|
||||
The @racket[#:no-require-lang] is deprecated starting from version 0.1, and
|
||||
is not needed anymore. It is still accepted for backwards compatibility. Note
|
||||
that version 0.1 of this library requires a fairly recent Racket version to
|
||||
work properly (it needs v.6.7.0.4 with the commit
|
||||
@tt{8a7852ebbfeb85a8f860700ba5ae481ed7aa9b41}, or v.6.7.0.5 or later). By
|
||||
default, raco will install v0.0 of hyper-literate on older Racket versions.
|
||||
|
||||
The extra @racket[require] statement injected by
|
||||
@racketmodname[hyper-literate] could in previous versions conflict with
|
||||
user-written @racket[require] statements. These @racket[require] statements
|
||||
can shadow some built-ins, and this case would yield conflicts. The
|
||||
@racket[#:no-require-lang] option disables that behaviour in versions < 0.1,
|
||||
and has the only drawback that built-ins of the @racket[_lang] language do not
|
||||
have an arrow in DrRacket (but they still should be highlighted with -a
|
||||
turquoise background when hovered over with the mouse).}
|
||||
|
||||
@section{What is hyper-literate programming?}
|
||||
|
||||
Hyper-literate programming is to literate programming
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user