From fef2ed1769b2b7b03046a64d80c8edf4eccd2754 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Fri, 16 Dec 2016 16:40:01 +0100 Subject: [PATCH] Fixed potential conflicts with the injected (require lang). --- info.rkt | 2 +- lang/first-line-utils.rkt | 23 +++++ lang/meta-first-line.rkt | 24 ++--- lang/reader.rkt | 25 ++++- private/common.rkt | 154 +++++++++++++++++-------------- private/lp.rkt | 27 +++++- private/no-auto-require.rkt | 4 +- scribblings/hyper-literate.scrbl | 31 +++++-- 8 files changed, 184 insertions(+), 106 deletions(-) create mode 100644 lang/first-line-utils.rkt 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