From b9037c3c06c66c878c038ced2b90e95b91611303 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 23 Jun 2016 21:09:35 +0200 Subject: [PATCH] Fixes lots of issues. Fixes scribble bug #25 (last commit didn't fix it in the end). Fixes arrows in DrRacket. Fixes some identifier conflicts. --- info.rkt | 3 +- lang.rkt | 5 +- lang/meta-first-line.rkt | 31 +++++++++++ lang/reader.rkt | 6 +-- private/common.rkt | 114 +++++++++++++++++++++++++-------------- private/lp.rkt | 10 ++-- test/test2.hl.rkt | 6 ++- 7 files changed, 121 insertions(+), 54 deletions(-) create mode 100644 lang/meta-first-line.rkt diff --git a/info.rkt b/info.rkt index d0b53aff..de7b1622 100644 --- a/info.rkt +++ b/info.rkt @@ -10,7 +10,8 @@ "typed-racket-doc")) (define build-deps '("scribble-lib" "racket-doc" "rackunit-doc")) (define scribblings '(("scribblings/hyper-literate.scrbl" ()) - ("test/test.hl.rkt" ()))) + ("test/test.hl.rkt" () (omit-start)) + ("test/test2.hl.rkt" () (omit-start)))) (define pkg-desc "Description Here") (define version "0.0") (define pkg-authors '(|Georges Dupéron|)) diff --git a/lang.rkt b/lang.rkt index 16c4fb76..bca207bc 100644 --- a/lang.rkt +++ b/lang.rkt @@ -2,7 +2,4 @@ ;; Forked from scribble-lib/scribble/lp/lang/lang2.rkt (require "private/common.rkt") -(provide (except-out (all-from-out "private/common.rkt") - module-begin/plain - module-begin/doc) - (rename-out [module-begin/doc #%module-begin])) +(provide (rename-out [module-begin/doc #%module-begin])) diff --git a/lang/meta-first-line.rkt b/lang/meta-first-line.rkt new file mode 100644 index 00000000..9cd4cf39 --- /dev/null +++ b/lang/meta-first-line.rkt @@ -0,0 +1,31 @@ +#lang racket/base + +(require scribble/reader + racket/port) + +(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)]) + #'(rd1 . rd))) \ No newline at end of file diff --git a/lang/reader.rkt b/lang/reader.rkt index 657149c2..15bc87d9 100644 --- a/lang/reader.rkt +++ b/lang/reader.rkt @@ -3,14 +3,14 @@ hyper-literate/lang -#:read read-inside -#:read-syntax read-syntax-inside +#:read meta-read-inside +#:read-syntax meta-read-syntax-inside #:whole-body-readers? #t ;; 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) -(require scribble/reader +(require "meta-first-line.rkt" (only-in scribble/base/reader scribble-base-reader-info scribble-base-language-info)) diff --git a/private/common.rkt b/private/common.rkt index 1a786e8f..66e7b776 100644 --- a/private/common.rkt +++ b/private/common.rkt @@ -28,7 +28,7 @@ chunks id `(,@(mapping-get chunks id) ,@exprs)))) -(define-for-syntax (tangle orig-stx) +(define-for-syntax (tangle orig-stx req-lng) (define chunk-mentions '()) (unless first-id (raise-syntax-error 'scribble/lp "no chunks")) @@ -37,6 +37,21 @@ (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)]) @@ -63,8 +78,11 @@ (mapping-get chunk-groups m))) chunk-mentions)]) ;(displayln (dynamic-require 'tyyyyyyyyyyyped/racket '#%module-begin)) - (replace-context #'#%module-begin;modbeg-ty - #`(begin body ... (let ([b-id (void)]) b-use) ...)))) + ;; 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 ...)))) (define-for-syntax (strip-comments body) (cond @@ -122,51 +140,69 @@ [_ (loop #'exprs)])]))) -(require racket/stxparam) -(define-syntax-parameter mbeg #'#%module-begin) - -(require (only-in typed/racket)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WORKAROUND +(require (for-syntax racket/syntax + syntax/parse)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(require (only-in typed/racket)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WORKAROUND ; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(require (for-syntax racket/pretty)) (define-for-syntax ((make-module-begin submod?) stx) - (syntax-case stx () - [(_modbeg lang body0 . body) + (syntax-parse stx + [(_modbeg (lang:id (~optional (~and no-require-lang #:no-require-lang))) + body0 . body) (let () - ;; TODO: get the actual symbol, instead of the string returned by - ;; scribble's at-reader. Or use the first line as a whole as the #lang, - ;; to allow othe meta-languages to be chained. - (define lang-sym - (string->symbol (regexp-replace "^ " (syntax-e #'lang) ""))) + (define lang-sym (syntax-e #'lang)) (let ([expanded - (expand `(,#'module scribble-lp-tmp-name hyper-literate/private/lp - (define-syntax-rule (if-preexpanding a b) a) - (define-syntax-rule (when-preexpanding . b) (begin . b)) - (define-syntax-rule (unless-preexpanding . b) (begin)) - ,@(strip-context #'(body0 . body))))]) + (expand `(,#'module + scribble-lp-tmp-name hyper-literate/private/lp + (define-syntax-rule (if-preexpanding a b) a) + (define-syntax-rule (when-preexpanding . b) (begin . b)) + (define-syntax-rule (unless-preexpanding . b) (begin)) + ,@(strip-context #'(body0 . body))))]) (syntax-case expanded () - [(module name lang (mb . stuff)) + [(module name elang (mb . stuff)) (let () (extract-chunks #'stuff) (dynamic-require lang-sym #f) (namespace-require `(for-meta -1 ,lang-sym)) - (replace-context - (namespace-symbol->identifier '#%module-begin) - #`(#%module-begin - #,(tangle #'body0) - #,@(if submod? - (list - (let ([submod - (strip-context - #`(module doc scribble/doclang2 - (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/manual - (only-in hyper-literate/private/lp chunk CHUNK)) - (begin body0 . body)))]) - (syntax-case submod () - [(_ . rest) - (datum->syntax #'here (cons #'module* #'rest))]))) - '()))))])))])) + #;(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 + #,@(maybe-insert-doc-submod submod? lang-sym)))])))])) +(define-for-syntax (maybe-insert-doc-submod submod? lang-sym) + (if submod? + (list + (let ([submod + (strip-context + #`(module doc scribble/doclang2 + (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/manual + (only-in hyper-literate/private/lp + chunk + CHUNK) + (for-label #,lang-sym)) + (begin body0 . body)))]) + (syntax-case submod () + [(_ . rest) + (datum->syntax #'here (cons #'module* #'rest))]))) + '())) (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 3d5318b0..26df6c2b 100644 --- a/private/lp.rkt +++ b/private/lp.rkt @@ -22,7 +22,7 @@ (identifier? #'name) (let* ([n (get-chunk-number (syntax-local-introduce #'name))] [str (symbol->string (syntax-e #'name))] - [tag (format "~a:~a" str (or n 1))]) + [tag (format "chunk:~a:~a" str (or n 1))]) (when n (inc-chunk-number (syntax-local-introduce #'name))) @@ -68,9 +68,9 @@ (make-splice (list (make-toc-element #f - (list (elemtag '(chunk (prefixable tag)) + (list (elemtag '(prefixable tag) (bold (italic (racket name)) " ::="))) - (list (smaller (elemref '(chunk (prefixable tag)) #:underline? #f + (list (smaller (elemref '(prefixable tag) #:underline? #f str rest ...)))) (#,racketblock expr ...))))))])) @@ -82,9 +82,9 @@ (syntax-case stx () [(_ id) (identifier? #'id) - (with-syntax ([tag (format "~a:1" (syntax-e #'id))] + (with-syntax ([tag (format "chunk:~a:1" (syntax-e #'id))] [str (format "~a" (syntax-e #'id))]) - #'(elemref '(chunk (prefixable tag)) #:underline? #f str))])) + #'(elemref '(prefixable tag) #:underline? #f str))])) (provide (all-from-out scheme/base diff --git a/test/test2.hl.rkt b/test/test2.hl.rkt index b0191cf7..d7402f54 100644 --- a/test/test2.hl.rkt +++ b/test/test2.hl.rkt @@ -1,14 +1,16 @@ #lang hyper-literate typed/racket/base @(require (for-label typed/racket/base - typed/rackunit)) + rackunit)) @title{Title} Hello world. @chunk[<*> - (require typed/rackunit) + (begin + ; Wrapped with (begin …) to avoid the implicit require for-label. + (require typed/rackunit)) ;; Would give an error as typed/racket/base is used on the #lang line: ;curry