diff --git a/info.rkt b/info.rkt
index 03b38ccb..562af033 100644
--- a/info.rkt
+++ b/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|))
diff --git a/lang/first-line-utils.rkt b/lang/first-line-utils.rkt
new file mode 100644
index 00000000..da67a4b7
--- /dev/null
+++ b/lang/first-line-utils.rkt
@@ -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)))))
\ No newline at end of file
diff --git a/lang/meta-first-line.rkt b/lang/meta-first-line.rkt
index 9cd4cf39..585a5049 100644
--- a/lang/meta-first-line.rkt
+++ b/lang/meta-first-line.rkt
@@ -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)))
\ No newline at end of file
diff --git a/lang/reader.rkt b/lang/reader.rkt
index 15bc87d9..b4f48fd9 100644
--- a/lang/reader.rkt
+++ b/lang/reader.rkt
@@ -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)])))
diff --git a/private/common.rkt b/private/common.rkt
index 575aa61b..2751e609 100644
--- a/private/common.rkt
+++ b/private/common.rkt
@@ -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,26 +131,54 @@
(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))
- (let ([expanded
+ (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
(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)))
+ ,(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))
diff --git a/private/lp.rkt b/private/lp.rkt
index b0a1b5f8..22dcbc56 100644
--- a/private/lp.rkt
+++ b/private/lp.rkt
@@ -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))
diff --git a/private/no-auto-require.rkt b/private/no-auto-require.rkt
index bea7a0c9..01a22d7a 100644
--- a/private/no-auto-require.rkt
+++ b/private/no-auto-require.rkt
@@ -1,4 +1,6 @@
#lang racket/base
(provide no-auto-require?)
-(define no-auto-require? (box #f))
\ No newline at end of file
+(define no-auto-require? (box #f))
+(provide preexpanding?)
+(define preexpanding? (box #f))
\ No newline at end of file
diff --git a/scribblings/hyper-literate.scrbl b/scribblings/hyper-literate.scrbl
index bcfa4bc7..57329f48 100644
--- a/scribblings/hyper-literate.scrbl
+++ b/scribblings/hyper-literate.scrbl
@@ -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