commit 8f6eb89dda6c1d8072d34a41fbe058b4b17c16fc Author: Suzanne Soy <no-reply@suzanne.soy> Date: Thu, 12 Feb 2026 19:48:49 +0000 Discarded history for now, this commit is the same as 24fd9ca7ca9b96e3072d37306dc79edf24ba4ef1 but without the history. Will restore history shortly once hosting issues are sorted. Send me an e-mail at racket.suzanne.soy at my domain if you need the history urgently. Diffstat:
| A | .gitignore | | | 6 | ++++++ |
| A | .travis.yml | | | 69 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | LICENSE.txt | | | 11 | +++++++++++ |
| A | README.md | | | 41 | +++++++++++++++++++++++++++++++++++++++++ |
| A | comment-reader.rkt | | | 99 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | comments/hide-comments-typed.rkt | | | 141 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | comments/hide-comments.rkt | | | 76 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | comments/restore-comments-typed.rkt | | | 131 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | comments/restore-comments.rkt | | | 131 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | comments/syntax-properties-typed.rkt | | | 82 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | comments/syntax-properties.rkt | | | 38 | ++++++++++++++++++++++++++++++++++++++ |
| A | diff1.rkt | | | 387 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | info.rkt | | | 31 | +++++++++++++++++++++++++++++++ |
| A | lang.rkt | | | 8 | ++++++++ |
| A | lang/first-line-utils.rkt | | | 56 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | lang/meta-first-line.rkt | | | 61 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | lang/reader.rkt | | | 87 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | main.rkt | | | 38 | ++++++++++++++++++++++++++++++++++++++ |
| A | private/chunks-toc-prefix.rkt | | | 5 | +++++ |
| A | private/common.rkt | | | 270 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | private/lp.rkt | | | 302 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | private/no-auto-require.rkt | | | 7 | +++++++ |
| A | restore-comments.rkt | | | 4 | ++++ |
| A | scribblings/diff1-example.hl.rkt | | | 121 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | scribblings/hyper-literate.scrbl | | | 276 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | spoiler1.rkt | | | 143 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | test/comments/annotate-syntax-typed.rkt | | | 70 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | test/comments/annotate-syntax.rkt | | | 53 | +++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | test/comments/same-syntax-typed.rkt | | | 34 | ++++++++++++++++++++++++++++++++++ |
| A | test/comments/same-syntax.rkt | | | 26 | ++++++++++++++++++++++++++ |
| A | test/comments/test-comments-round-trip.rkt | | | 56 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | test/test-chunks-order.rkt | | | 30 | ++++++++++++++++++++++++++++++ |
| A | test/test-doc.rkt | | | 3 | +++ |
| A | test/test.hl.rkt | | | 100 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | test/test2.hl.rkt | | | 23 | +++++++++++++++++++++++ |
35 files changed, 3016 insertions(+), 0 deletions(-)
diff --git a/.gitignore b/.gitignore @@ -0,0 +1,6 @@ +*~ +\#* +.\#* +.DS_Store +compiled/ +/doc/ diff --git a/.travis.yml b/.travis.yml @@ -0,0 +1,69 @@ +language: c + +# Based from: https://github.com/greghendershott/travis-racket + +# Optional: Remove to use Travis CI's older infrastructure. +sudo: false + +env: + global: + # Supply a global RACKET_DIR environment variable. This is where + # Racket will be installed. A good idea is to use ~/racket because + # that doesn't require sudo to install and is therefore compatible + # with Travis CI's newer container infrastructure. + - RACKET_DIR=~/racket + matrix: + # Supply at least one RACKET_VERSION environment variable. This is + # used by the install-racket.sh script (run at before_install, + # below) to select the version of Racket to download and install. + # + # Supply more than one RACKET_VERSION (as in the example below) to + # create a Travis-CI build matrix to test against multiple Racket + # versions. + #- RACKET_VERSION=6.0 + #- RACKET_VERSION=6.1 + #- RACKET_VERSION=6.1.1 + #- RACKET_VERSION=6.2 + #- RACKET_VERSION=6.3 + #- RACKET_VERSION=6.4 + #- RACKET_VERSION=6.5 + #- RACKET_VERSION=6.6 + #- RACKET_VERSION=6.7 + - RACKET_VERSION=6.8 + - RACKET_VERSION=6.9 + - RACKET_VERSION=6.10 + - RACKET_VERSION=6.10.1 + - RACKET_VERSION=6.11 + - RACKET_VERSION=6.12 + - RACKET_VERSION=7.0 + - RACKET_VERSION=7.1 + - RACKET_VERSION=7.2 + - RACKET_VERSION=HEAD + +matrix: + allow_failures: +# - env: RACKET_VERSION=HEAD + fast_finish: true + +before_install: +- git clone https://github.com/greghendershott/travis-racket.git ~/travis-racket +- cat ~/travis-racket/install-racket.sh | bash # pipe to bash not sh! +- export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us + +install: + - raco pkg install -j 2 --deps search-auto + +before_script: + +# Here supply steps such as raco make, raco test, etc. You can run +# `raco pkg install --deps search-auto` to install any required +# packages without it getting stuck on a confirmation prompt. +script: + - raco test -p hyper-literate + - raco setup --check-pkg-deps --no-zo --no-launcher --no-install --no-post-install --no-docs --pkgs hyper-literate + - raco pkg install --deps search-auto doc-coverage + - raco doc-coverage hyper-literate + +after_success: + - raco pkg install --deps search-auto cover cover-coveralls + - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage . diff --git a/LICENSE.txt b/LICENSE.txt @@ -0,0 +1,11 @@ +hyper-literate +Copyright (c) 2016 Suzanne Soy + +This package is distributed under the GNU Lesser General Public +License (LGPL). This means that you can link hyper-literate into proprietary +applications, provided you follow the rules stated in the LGPL. You +can also modify this package; if you distribute a modified version, +you must distribute it under the terms of the LGPL, which in +particular means that you must release the source code for the +modified software. See http://www.gnu.org/copyleft/lesser.html +for more information. diff --git a/README.md b/README.md @@ -0,0 +1,41 @@ +[](https://travis-ci.org/jsmaniac/hyper-literate) +[](https://coveralls.io/github/jsmaniac/hyper-literate) +[](http://jsmaniac.github.io/travis-stats/#jsmaniac/hyper-literate) +[](http://docs.racket-lang.org/hyper-literate/) + +hyper-literate +============== + +Some tools which help build hyper-literate programs. + +Hyper-literate programming is to literate programming exactly what hypertext +documents are to regular books and texts. Literate programming is about +telling other programmers how the program works (instead of just telling the +compiler what it does). Telling this story can be done using non-linear, +hyperlinked documents. + +For now these utilities only help with manipulating LP chunks (e.g. repeating +the same chunk in several places in the output document, but keeping a single +copy in the source code). + +Ultimately, the reading experience should be closer to viewing an interactive +presentation, focusing on the parts of the program that are of interest to +you: expand on-screen the chunks you are curious about, run some tests and see +their result, etc. + +* Imagine something like [code + bubbles](http://www.andrewbragdon.com/codebubbles_site.asp), but with + explanatory text coming along with the source code. + +* Imagine something like [Inform](http://inform7.com/), but focused on + exploring a program instead of exploring an imaginary world — after all, a + program is some kind of imaginary world. + +Installation +------------ + +Install with: + +``` +raco pkg install --deps search-auto hyper-literate +``` diff --git a/comment-reader.rkt b/comment-reader.rkt @@ -0,0 +1,99 @@ +;; Copied and modified from https://github.com/racket/scribble/blob/ +;; 31ad440b75b189a2b0838aab011544d44d6b580/ +;; scribble-lib/scribble/comment-reader.rkt +;; +;; Maybe this should use instead the 'scribble property? See +;; https://docs.racket-lang.org/scribble/ +;; reader-internals.html#%28part._.Syntax_.Properties%29 +(module comment-reader scheme/base + (require (only-in racket/port peeking-input-port)) + + (provide (rename-out [*read read] + [*read-syntax read-syntax]) + make-comment-readtable) + + (define unsyntaxer (make-parameter 'unsyntax)) + + (define (*read [inp (current-input-port)]) + (parameterize ([unsyntaxer (read-unsyntaxer inp)] + [current-readtable (make-comment-readtable)]) + (read/recursive inp))) + + (define (*read-syntax src [port (current-input-port)]) + (parameterize ([unsyntaxer (read-unsyntaxer port)] + [current-readtable (make-comment-readtable)]) + (read-syntax/recursive src port))) + + (define (read-unsyntaxer port) + (let ([p (peeking-input-port port)]) + (if (eq? (read p) '#:escape-id) + (begin (read port) (read port)) + 'unsyntax))) + + (define (make-comment-readtable #:readtable [rt (current-readtable)] + #:comment-wrapper [comment-wrapper 'code:comment] + #:unsyntax [unsyntax? #t]) + (make-readtable rt + #\; 'terminating-macro + (case-lambda + [(char port) + (do-comment port + (lambda () (read/recursive port #\@)) + #:comment-wrapper comment-wrapper + #:unsyntax unsyntax?)] + [(char port src line col pos) + (let ([v (do-comment port + (lambda () (read-syntax/recursive src port #\@)) + #:comment-wrapper comment-wrapper + #:unsyntax unsyntax?)]) + (let-values ([(eline ecol epos) (port-next-location port)]) + (datum->syntax + #f + v + (list src line col pos (and pos epos (- epos pos))))))]))) + + (define (do-comment port + recur + #:comment-wrapper [comment-wrapper 'code:comment] + #:unsyntax [unsyntax? #t]) + (define comment-text + `(t + ,@(append-strings + (let loop () + (let ([c (read-char port)]) + (cond + [(or (eof-object? c) + (char=? c #\newline)) + null] + [(char=? c #\@) + (cons (recur) (loop))] + [else + (cons (string c) + (loop))])))))) + (define comment-unsyntax + (if unsyntax? + `(,(unsyntaxer) ,comment-text) + comment-text)) + `(,comment-wrapper ,comment-text)) + + (define (append-strings l) + (let loop ([l l][s null]) + (cond + [(null? l) (if (null? s) + null + (preserve-space (apply string-append (reverse s))))] + [(string? (car l)) + (loop (cdr l) (cons (car l) s))] + [else + (append (loop null s) + (cons + (car l) + (loop (cdr l) null)))]))) + + (define (preserve-space s) + (let ([m (regexp-match-positions #rx" +" s)]) + (if m + (append (preserve-space (substring s 0 (caar m))) + (list `(hspace ,(- (cdar m) (caar m)))) + (preserve-space (substring s (cdar m)))) + (list s))))) diff --git a/comments/hide-comments-typed.rkt b/comments/hide-comments-typed.rkt @@ -0,0 +1,140 @@ +#lang typed/racket + +(require (rename-in syntax/parse [...+ …+]) + syntax/stx + racket/match + racket/set + racket/list + racket/function + racket/vector + racket/contract + sexp-diff + racket/pretty + rackunit + (only-in racket/base [... …]) + (for-syntax (rename-in racket/base [... …])) + tr-immutable/typed-syntax + "syntax-properties-typed.rkt") + +(provide hide-#%comment) + +;; ([#%comment c1] a [#%comment c2] . ([#%comment c3] b [#%comment c4])) +;; => (aᶜ² . (bᶜ⁴)⁻ᶜ³)⁻ᶜ¹ +;; (c1 a c2 . (c3 . (c4 b c5))) +;; => (aᶜ² . (bᶜ⁵)⁻ᶜ³⁻⁻ᶜ⁴)⁻ᶜ¹ +;; (c1 a c2 . (c3 . (c4 c5))) +;; => (aᶜ² . ()⁻ᶜ³⁻⁻ᶜ⁴ᶜ⁵)⁻ᶜ¹ +;; (c1 a (c2) b) +;; => (a ()⁻ᶜ² b)⁻ᶜ¹ +;; (c1 a (c2 . b) c) +;; => (a b⁻ᶜ² c)⁻ᶜ¹ +;; (c1 a (c2 . (c3 c4)) c) +;; => (a ()⁻ᶜ²⁻⁻ᶜ³ᶜ⁴ c)⁻ᶜ¹ +(: hide-#%comment (→ ISyntax/Non-Stx ISyntax/Non-Stx)) +(define (hide-#%comment stx) + (cond + [(pair? (syntax-e stx)) + (hide-in-pair (syntax-e stx))] + [else + ;; TODO: recurse down vectors etc. + stx])) + +(define-type ISyntax/Non-List* + (Rec L (U ISyntax/Non + Null + (Pairof ISyntax/Non L)))) + +(define pair (ann cons (∀ (A B) (→ A B (Pairof A B))))) + +(: hide-in-pair (→ ISyntax/Non-List* + ISyntax/Non-Stx)) +(define (hide-in-pair e*) + (let loop ([rest : ISyntax/Non-List* e*] + [groups : (Pairof (Listof Comment) + (Listof (Pairof ISyntax/Non (Listof Comment)))) + '(())]) + (if (pair? rest) + (if (comment? (car rest)) + (loop (cdr rest) + (pair (pair (ann (car rest) Comment) (car groups)) + (cdr groups))) + (loop (cdr rest) + (pair (ann '() (Listof Comment)) + (pair (pair (car rest) (reverse (car groups))) + (cdr groups))))) + (values rest groups))) + (error "TODOrtfdsvc")) + +(define-type Comment (Syntaxof (Pairof (Syntaxof '#%comment) Any))) +(define comment? (make-predicate Comment)) + + +#;(if ((make-predicate (Rec R (Pairof (Syntaxof (Pairof (Syntaxof '#%comment) Any)) + (U Boolean + Char + Number + Keyword + Null + String + Symbol + BoxTop + VectorTop + R)))) + e*) + (error "TODOwa" e*) + (error "TODOwa" e*)) + +#| +(: listof? (∀ (A) (→ Any (→ Any Boolean : A) Boolean : (Listof A)))) +(define (listof? l p?) + (pair? l + p? + (ann (λ (a) + (list*? a p?)) + (→ Any Boolean : )) +|# + +#;(match (syntax-e stx) + [(not (? pair?)) + ;; TODO: recurse down vectors etc. + stx] + [(list* e* ... rest) + (error "TODO") + #;(syntax-parse e* + #:datum-literals (#%comment) + [({~and c₀ [#%comment . _]} … + {~seq {~and eᵢ {~not [#%comment . _]}} + {~and cᵢⱼ [#%comment . _]} …} + …+) + (define new-e* (map with-comments-after + (map hide-#%comment + (syntax->list #'(eᵢ …))) + (map syntax->list + (syntax->list #'((cᵢⱼ …) …))))) + (define new-rest (if (null? rest) + rest + (hide-#%comment rest))) + (with-first-comments + (datum->syntax stx (append new-e* new-rest) stx stx) + (cons #f (syntax->list #'(c₀ …))))] + [({~and c₀ [#%comment . _]} …) + (define new-rest (if (null? rest) + rest + (hide-#%comment rest))) + (with-first-comments + (with-comments-after + (datum->syntax stx new-rest stx stx) + (if (syntax? new-rest) + (syntax-property new-rest 'comments-after) + '())) + (cons (if (syntax? new-rest) + (cons (datum->syntax new-rest + 'saved-props+srcloc + new-rest + new-rest) + (or (syntax-property new-rest 'first-comments) + ;; TODO: I'm dubious about this, better typecheck + ;; everything… + (cons #f null))) + #f) + (syntax->list #'(c₀ …))))])]) +\ No newline at end of file diff --git a/comments/hide-comments.rkt b/comments/hide-comments.rkt @@ -0,0 +1,75 @@ +#lang racket + +(require (rename-in syntax/parse [...+ …+]) + syntax/stx + racket/match + racket/set + racket/list + racket/function + racket/vector + racket/contract + sexp-diff + racket/pretty + rackunit + (only-in racket/base [... …]) + (for-syntax (rename-in racket/base [... …])) + "syntax-properties.rkt") + +(provide hide-#%comment) + +;; ([#%comment c1] a [#%comment c2] . ([#%comment c3] b [#%comment c4])) +;; => (aᶜ² . (bᶜ⁴)⁻ᶜ³)⁻ᶜ¹ +;; (c1 a c2 . (c3 . (c4 b c5))) +;; => (aᶜ² . (bᶜ⁵)⁻ᶜ³⁻⁻ᶜ⁴)⁻ᶜ¹ +;; (c1 a c2 . (c3 . (c4 c5))) +;; => (aᶜ² . ()⁻ᶜ³⁻⁻ᶜ⁴ᶜ⁵)⁻ᶜ¹ +;; (c1 a (c2) b) +;; => (a ()⁻ᶜ² b)⁻ᶜ¹ +;; (c1 a (c2 . b) c) +;; => (a b⁻ᶜ² c)⁻ᶜ¹ +;; (c1 a (c2 . (c3 c4)) c) +;; => (a ()⁻ᶜ²⁻⁻ᶜ³ᶜ⁴ c)⁻ᶜ¹ +(define (hide-#%comment stx) + (match (syntax-e stx) + [(not (? pair?)) + ;; TODO: recurse down vectors etc. + stx] + [(list* e* ... rest) + (syntax-parse e* + #:datum-literals (#%comment) + [({~and c₀ [#%comment . _]} … + {~seq {~and eᵢ {~not [#%comment . _]}} + {~and cᵢⱼ [#%comment . _]} …} + …+) + (define new-e* (map with-comments-after + (map hide-#%comment + (syntax->list #'(eᵢ …))) + (map syntax->list + (syntax->list #'((cᵢⱼ …) …))))) + (define new-rest (if (null? rest) + rest + (hide-#%comment rest))) + (with-first-comments + (datum->syntax stx (append new-e* new-rest) stx stx) + (cons #f (syntax->list #'(c₀ …))))] + [({~and c₀ [#%comment . _]} …) + (define new-rest (if (null? rest) + rest + (hide-#%comment rest))) + (with-first-comments + (with-comments-after + (datum->syntax stx new-rest stx stx) + (if (syntax? new-rest) + (syntax-property new-rest 'comments-after) + '())) + (cons (if (syntax? new-rest) + (cons (datum->syntax new-rest + 'saved-props+srcloc + new-rest + new-rest) + (or (syntax-property new-rest 'first-comments) + ;; TODO: I'm dubious about this, better typecheck + ;; everything… + (cons #f null))) + #f) + (syntax->list #'(c₀ …))))])])) +\ No newline at end of file diff --git a/comments/restore-comments-typed.rkt b/comments/restore-comments-typed.rkt @@ -0,0 +1,130 @@ +#lang racket + +(require (rename-in syntax/parse [...+ …+]) + syntax/stx + racket/match + racket/set + racket/list + racket/function + racket/vector + racket/contract + sexp-diff + racket/pretty + rackunit + (only-in racket/base [... …]) + (for-syntax (rename-in racket/base [... …])) + "syntax-properties.rkt") + +(provide restore-#%comment) + +(define/contract (restore-#%comment stx + #:replace-with (replace-with #f) + #:scope [scope (datum->syntax #f 'zero)]) + (->* (syntax?) + (#:replace-with [or/c #f syntax? (-> syntax? syntax?)] + #:scope identifier?) + syntax?) + (define (erase-props stx) + (define stx* (if (syntax-property stx 'first-comments) + (syntax-property stx 'first-comments #f) + stx)) + (if (syntax-property stx* 'comments-after) + (syntax-property stx* 'comments-after #f) + stx*)) + (define (recur stx) + (restore-#%comment stx #:replace-with replace-with #:scope scope)) + (define (replace-in commentᵢ) + (syntax-parse commentᵢ + #:datum-literals (#%comment) + [({~and c #%comment} . rest) + (if (syntax? replace-with) + (datum->syntax commentᵢ + `(,(datum->syntax #'c replace-with #'c #'c) + . ,((make-syntax-delta-introducer + scope + (datum->syntax #f 'zero)) + #'rest + 'add)) + commentᵢ + commentᵢ) + (replace-with + (datum->syntax commentᵢ + `(,#'c + . ,((make-syntax-delta-introducer + scope + (datum->syntax #f 'zero)) + #'rest + 'add)) + commentᵢ + commentᵢ)))] + [_ + commentᵢ])) + (define (replace-in-after comments) + (if replace-with + (if (eq? comments #f) + comments + (stx-map replace-in comments)) + comments)) + (define (replace-in-first first-comments) + (define (replace-in-first1 first-comments) + (if (eq? first-comments #f) + first-comments + (cons (cons (caar first-comments) + (replace-in-first1 (cdar first-comments))) + (stx-map replace-in (cdr first-comments))))) + (if replace-with + (if (eq? first-comments #f) + first-comments + (cons (replace-in-first1 (car first-comments)) + (stx-map replace-in (cdr first-comments)))) + first-comments)) + (match (syntax-e stx) + [(list* e* ... rest) + ;; TODO: when extracting the comments properties, check that they have + ;; the right shape (listof syntax?) or (*list/c syntax? (list/c R)) + ;; Or append-map when stx is a stx-list (not in a tail position for the + ;; comments-after) + (define new-e* + (append-map (λ (eᵢ) + (cons (recur eᵢ) + (or (replace-in-after (extract-comments-after eᵢ)) + '()))) + e*)) + (define new-rest + (if (syntax? rest) + (recur rest) + ;; TODO: handle vectors etc. here? + rest)) + (define first-comments + (or (replace-in-first (extract-first-comments stx)) + #f)) + (define (nest first-comments to-nest) + (cond + [(eq? first-comments #f) + to-nest] + [(eq? (car first-comments) #f) + (append (cdr first-comments) to-nest)] + [else + (nest1 first-comments to-nest)])) + (define (nest1 first-comments to-nest) + (if (eq? first-comments #f) + to-nest + (append (cdr first-comments) + (datum->syntax (caar first-comments) + (nest (cdar first-comments) to-nest))))) + (define new-stx + (nest first-comments (append new-e* new-rest))) + (erase-props (datum->syntax stx new-stx stx stx))] + ;; TODO: recurse down vectors etc. + [(? vector? v) + ;; TODO: what if there is a first-comment property on the vector itself? + (erase-props + (datum->syntax stx + (vector-map (λ (vᵢ) + (recur vᵢ)) + v) + stx + stx))] + [other + 'TODO… + other])) +\ No newline at end of file diff --git a/comments/restore-comments.rkt b/comments/restore-comments.rkt @@ -0,0 +1,130 @@ +#lang racket + +(require (rename-in syntax/parse [...+ …+]) + syntax/stx + racket/match + racket/set + racket/list + racket/function + racket/vector + racket/contract + sexp-diff + racket/pretty + rackunit + (only-in racket/base [... …]) + (for-syntax (rename-in racket/base [... …])) + "syntax-properties.rkt") + +(provide restore-#%comment) + +(define/contract (restore-#%comment stx + #:replace-with (replace-with #f) + #:scope [scope (datum->syntax #f 'zero)]) + (->* (syntax?) + (#:replace-with [or/c #f syntax? (-> syntax? syntax?)] + #:scope identifier?) + syntax?) + (define (erase-props stx) + (define stx* (if (syntax-property stx 'first-comments) + (syntax-property stx 'first-comments #f) + stx)) + (if (syntax-property stx* 'comments-after) + (syntax-property stx* 'comments-after #f) + stx*)) + (define (recur stx) + (restore-#%comment stx #:replace-with replace-with #:scope scope)) + (define (replace-in commentᵢ) + (syntax-parse commentᵢ + #:datum-literals (#%comment) + [({~and c #%comment} . rest) + (if (syntax? replace-with) + (datum->syntax commentᵢ + `(,(datum->syntax #'c replace-with #'c #'c) + . ,((make-syntax-delta-introducer + scope + (datum->syntax #f 'zero)) + #'rest + 'add)) + commentᵢ + commentᵢ) + (replace-with + (datum->syntax commentᵢ + `(,#'c + . ,((make-syntax-delta-introducer + scope + (datum->syntax #f 'zero)) + #'rest + 'add)) + commentᵢ + commentᵢ)))] + [_ + commentᵢ])) + (define (replace-in-after comments) + (if replace-with + (if (eq? comments #f) + comments + (stx-map replace-in comments)) + comments)) + (define (replace-in-first first-comments) + (define (replace-in-first1 first-comments) + (if (eq? first-comments #f) + first-comments + (cons (cons (caar first-comments) + (replace-in-first1 (cdar first-comments))) + (stx-map replace-in (cdr first-comments))))) + (if replace-with + (if (eq? first-comments #f) + first-comments + (cons (replace-in-first1 (car first-comments)) + (stx-map replace-in (cdr first-comments)))) + first-comments)) + (match (syntax-e stx) + [(list* e* ... rest) + ;; TODO: when extracting the comments properties, check that they have + ;; the right shape (listof syntax?) or (*list/c syntax? (list/c R)) + ;; Or append-map when stx is a stx-list (not in a tail position for the + ;; comments-after) + (define new-e* + (append-map (λ (eᵢ) + (cons (recur eᵢ) + (or (replace-in-after (extract-comments-after eᵢ)) + '()))) + e*)) + (define new-rest + (if (syntax? rest) + (recur rest) + ;; TODO: handle vectors etc. here? + rest)) + (define first-comments + (or (replace-in-first (extract-first-comments stx)) + #f)) + (define (nest first-comments to-nest) + (cond + [(eq? first-comments #f) + to-nest] + [(eq? (car first-comments) #f) + (append (cdr first-comments) to-nest)] + [else + (nest1 first-comments to-nest)])) + (define (nest1 first-comments to-nest) + (if (eq? first-comments #f) + to-nest + (append (cdr first-comments) + (datum->syntax (caar first-comments) + (nest (cdar first-comments) to-nest))))) + (define new-stx + (nest first-comments (append new-e* new-rest))) + (erase-props (datum->syntax stx new-stx stx stx))] + ;; TODO: recurse down vectors etc. + [(? vector? v) + ;; TODO: what if there is a first-comment property on the vector itself? + (erase-props + (datum->syntax stx + (vector-map (λ (vᵢ) + (recur vᵢ)) + v) + stx + stx))] + [other + 'TODO… + other])) +\ No newline at end of file diff --git a/comments/syntax-properties-typed.rkt b/comments/syntax-properties-typed.rkt @@ -0,0 +1,81 @@ +#lang typed/racket + +(provide First-Comments + Comments-After + with-first-comments + with-comments-after + extract-first-comments + extract-comments-after) + +(require tr-immutable/typed-syntax + typed-map) + +(define-type First-Comments + (Rec R (Pairof (U #f (Pairof (Syntaxof 'saved-props+srcloc) + R)) + (Listof ISyntax)))) + +(define-type Comments-After + (Listof ISyntax)) + +(: first-comments? (→ Any Boolean : (Pairof (U #f (Pairof (Syntaxof 'saved-props+srcloc) + First-Comments)) + (Listof ISyntax)))) +(define (first-comments? v) + (define p? (inst pairof? + (U #f (Pairof (Syntaxof 'saved-props+srcloc) + First-Comments)) + (Listof ISyntax))) + (p? v first-comments1? first-comments2?)) + +(: first-comments1? (→ Any Boolean : (U #f (Pairof (Syntaxof 'saved-props+srcloc) + First-Comments)))) +(define (first-comments1? v) + (or (false? v) + (first-comments11? v))) + +(: first-comments11? (→ Any Boolean : (Pairof (Syntaxof 'saved-props+srcloc) + First-Comments))) +(define (first-comments11? v) + (define p? (inst pairof? + (Syntaxof 'saved-props+srcloc) + First-Comments)) + (p? v + (make-predicate (Syntaxof 'saved-props+srcloc)) + first-comments?)) + +(: first-comments2? (→ Any Boolean : (Listof ISyntax))) +(define (first-comments2? v) + (and (list? v) + (andmap isyntax? v))) + +(: with-first-comments (∀ (A) (→ ISyntax + (U #f First-Comments) + ISyntax))) +(define (with-first-comments e c) + + (if (or (not c) (and (= (length c) 1) (not (first c)))) + e + (syntax-property e 'first-comments c))) + +(: with-comments-after (∀ (A) (→ (Syntaxof A) + (U #f Comments-After) + (Syntaxof A)))) +(define (with-comments-after e c) + (if (or (not c) (null? c)) + e + (syntax-property e 'comments-after c))) + +(: extract-first-comments (-> (Syntaxof Any) (U #f First-Comments))) +(define (extract-first-comments stx) + (define c (syntax-property stx 'first-comments)) + (if (first-comments? c) + c + #f)) + +(: extract-comments-after (-> (Syntaxof Any) (U #f Comments-After))) +(define (extract-comments-after stx) + (define c (syntax-property stx 'comments-after)) + (and (list? c) + (andmap isyntax? c) + c)) +\ No newline at end of file diff --git a/comments/syntax-properties.rkt b/comments/syntax-properties.rkt @@ -0,0 +1,37 @@ +#lang racket + +(provide first-comments/c + comments-after/c + with-first-comments + with-comments-after + extract-first-comments + extract-comments-after) + +(define first-comments/c + (flat-rec-contract R (cons/c (or/c #f (cons/c (syntax/c 'saved-props+srcloc) + R)) #| nested |# + (listof syntax?) #| comments |#))) +(define comments-after/c + (listof syntax?)) + +(define/contract (with-first-comments e c) + (-> syntax? + (or/c #f first-comments/c) + syntax?) + (if (or (not c) (and (= (length c) 1) (not (first c)))) + e + (syntax-property e 'first-comments c))) + +(define/contract (with-comments-after e c) + (-> syntax? (or/c #f comments-after/c) syntax?) + (if (or (not c) (null? c)) + e + (syntax-property e 'comments-after c))) + +(define/contract (extract-first-comments stx) + (-> syntax? (or/c #f first-comments/c)) + (syntax-property stx 'first-comments)) + + (define/contract (extract-comments-after stx) + (-> syntax? (or/c #f comments-after/c)) + (syntax-property stx 'comments-after)) +\ No newline at end of file diff --git a/diff1.rkt b/diff1.rkt @@ -0,0 +1,387 @@ +#lang at-exp racket/base + +(provide hlite) + +(require hyper-literate + (for-syntax syntax/parse + (rename-in racket/base [... …]) + racket/match + syntax/srcloc) + scribble/core + scribble/html-properties + scribble/latex-properties + scribble/base) + +;; For debugging. +(define-for-syntax (show-stx e) + (define (r e) + (cond + ([syntax? e] + (display "#'") + (r (syntax-e e))) + [(pair? e) + (display "(") + (let loop ([e e]) + (if (pair? e) + (begin (r (car e)) + (display " ") + (loop (cdr e))) + (if (null? e) + (display ")") + (begin + (display ". ") + (r e) + (display ")")))))] + [else + (print (syntax->datum (datum->syntax #f e)))])) + (r e) + (newline) + (newline)) + + +(define the-css-addition + #" +.HyperLiterateNormal { + filter: initial; + background: none; +} + +.HyperLiterateDim { + filter: brightness(150%) contrast(30%) opacity(0.7); + background: none; /* rgba(82, 103, 255, 0.36); */ +} + +.HyperLiterateAdd{ + filter: initial; + background: rgb(202, 226, 202); +} + +.HyperLiterateRemove { + filter: initial; + background: rgb(225, 182, 182); +}") + +(define the-latex-addition + #" +%\\usepackage{framed}% \begin{snugshade}\end{snugshade} +\\definecolor{HyperLiterateDimColor}{RGB}{210,210,210} +\\definecolor{HyperLiterateAddColor}{RGB}{202,226,202} +\\definecolor{HyperLiterateRemoveColor}{RGB}{225,182,182} + +\\def\\HyperLiterateNormal#1{#1} +\\def\\HyperLiterateDim#1{\\colorbox{HyperLiterateDimColor}{% + \\vphantom{\\RktPn{(}\\RktValDef{Xj}}#1}} +\\def\\HyperLiterateAdd#1{\\colorbox{HyperLiterateAddColor}{% + \\vphantom{\\RktPn{(}\\RktValDef{Xj}}#1}} +\\def\\HyperLiterateRemove#1{\\colorbox{HyperLiterateRemoveColor}{% + \\vphantom{\\RktPn{(}\\RktValDef{Xj}}#1}} +") + +(define (init) + (elem + #:style (style #f + (list (css-addition the-css-addition) + (tex-addition the-latex-addition))))) + +(begin-for-syntax + (define (stx-null? e) + (or (null? e) + (and (syntax? e) + (null? (syntax-e e))))) + (define (stx-pair? e) + (or (pair? e) + (and (syntax? e) + (pair? (syntax-e e)))))) + +(define-syntax (hlite stx) + (syntax-case stx () + [(self name guide1 . body) + (and (identifier? #'self) + (identifier? #'name)) + (let () + (define (simplify-guide g) + (cond + [(and (identifier? g) (free-identifier=? g #'/)) '/] + [(and (identifier? g) (free-identifier=? g #'=)) '=] + [(and (identifier? g) (free-identifier=? g #'-)) '-] + [(and (identifier? g) (free-identifier=? g #'+)) '+] + [(and (identifier? g) (free-identifier=? g #'-/)) '-/] + [(and (identifier? g) (free-identifier=? g #'-=)) '-=] + [(and (identifier? g) (free-identifier=? g #'-+)) '-+] + [(identifier? g) '_] + [(syntax? g) (simplify-guide (syntax-e g))] + [(pair? g) (cons (simplify-guide (car g)) + (simplify-guide (cdr g)))] + [(null? g) '()])) + (define (mode→style m) + (case m + [(/) "HyperLiterateDim"] + [(=) "HyperLiterateNormal"] + [(-) "HyperLiterateRemove"] + [(+) "HyperLiterateAdd"] + [(-/) "HyperLiterateDim"] + [(-=) "HyperLiterateNormal"] + [(-+) "HyperLiterateAdd"])) + (define simplified-guide (simplify-guide #'guide1)) + (define (syntax-e? v) + (if (syntax? v) (syntax-e v) v)) + (define new-body + (let loop ([mode '=] + [guide simplified-guide] + [body #'body]) + (match guide + [(cons (and new-mode (or '/ '= '- '+ '-/ '-= '-+)) rest-guide) + (loop new-mode rest-guide body)] + [(list car-guide rest-guide) + #:when (and (pair? (syntax-e? body)) + (memq (syntax-e? (car (syntax-e? body))) + '[quote quasiquote + unquote unquote-splicing + quasisyntax syntax + unsyntax unsyntax-splicing]) + (pair? (syntax-e? (cdr (syntax-e? body)))) + (null? (syntax-e? + (cdr (syntax-e? (cdr (syntax-e? body)))))) + (let ([sp (syntax-span (car (syntax-e? body)))]) + (or (= sp 1) + (= sp 2)))) + (unless (symbol? car-guide) + (raise-syntax-error 'hlite + (format + "expected pattern ~a, found identifier" + car-guide) + (datum->syntax #f (car (syntax-e? body))))) + (define result + `(,(car (syntax-e? body)) + ,(loop mode + rest-guide + (car (syntax-e? (cdr (syntax-e? body))))))) + (if (syntax? body) + (datum->syntax body result body body) + body)] + [(cons car-guide rest-guide) + (unless (pair? (syntax-e? body)) + (raise-syntax-error 'hlite + (format + "expected pair ~a, found non-pair" + guide) + (datum->syntax #f body))) + (define loop2-result + (let loop2 ([first-iteration? #t] + [guide guide] + [body (if (syntax? body) (syntax-e body) body)] + [acc '()]) + (cond + [(and (pair? guide) + (memq (car guide) '(/ = - + -/ -= -+))) + (if first-iteration? + (loop (car guide) (cdr guide) body) + ;; produce: + ;; ({code:hilite {code:line accumulated ...}} . rest) + (let ([r-acc (reverse acc)] + [after (loop (car guide) (cdr guide) body)]) + (define (do after) + (datum->syntax + (car r-acc) + `(code:hilite (code:line ,@r-acc . ,after) + ,(mode→style mode)) + (build-source-location-list + (update-source-location (car r-acc) + #:span 0)))) + (if (stx-pair? body) + ;; TODO: refactor the two branches, they are very + ;; similar. + (cons (do '()) + after) + ;; Special case to handle (a . b) when b and a + ;; do not have the same highlighting. + ;; This assigns to the dot the highlighting for + ;; b, although it would be possible to assign + ;; andother highliughting (just change the + ;; mode→style below) + (let* ([loc1 (build-source-location-list + (update-source-location + (car acc) + #:span 0))] + [loc2 (build-source-location-list + (update-source-location + after + #:column (- (syntax-column after) + 3) ;; spc + dot + spc + #:span 0))]) + `(,(do `(,(datum->syntax + #f + `(code:hilite + ,(datum->syntax + #f `(code:line . ,after) loc2) + ,(mode→style (car guide))) + loc1))))))))] + [(and (pair? guide) (pair? body)) + ;; accumulate the first element of body + (loop2 #f + (cdr guide) + (cdr body) + (cons (loop mode (car guide) (car body)) acc))] + ;; If body is not a pair, then we will treat it as an + ;; "improper tail" element, unless it is null? + [(null? body) + (unless (null? guide) + (raise-syntax-error + 'hlite + ;; TODO: thread the syntax version of body, so that + ;; we can highlight the error. + "Expected non-null body, but found null" + stx)) + ;; produce: + ;; ({code:hilite {code:line accumulated ...}}) + (let* ([r-acc (reverse acc)]) + `(,(datum->syntax (car r-acc) + `(code:hilite (code:line . ,r-acc) + ,(mode→style mode)) + (build-source-location-list + (update-source-location (car r-acc) + #:span 0)))) + )] + [else + ;; produce: + ;; ({code:hilite + ;; {code:line accumulated ... . improper-tail}}) + (let* ([new-body (loop mode guide body)] + [r-acc+tail (append (reverse acc) new-body)]) + `(,(datum->syntax + (car r-acc+tail) + `(code:hilite (code:line . ,r-acc+tail) + ,(mode→style mode)) + (build-source-location-list + (update-source-location (car r-acc+tail) + #:span 0)))) + ) + ]))) + (if (syntax? body) + (datum->syntax body loop2-result body body) + loop2-result)] + [(? symbol?) + (datum->syntax body `(code:hilite (code:line ,body) + ,(mode→style mode)) + (build-source-location-list + (update-source-location body #:span 0)))] + ['() + (unless (stx-null? body) + (raise-syntax-error + 'hlite + ;; TODO: thread the syntax version of body, so that + ;; we can highlight the error. + (format "Expected null body, but found non-null ~a" + (syntax->datum body)) + stx)) + body]))) + (define new-executable-code + (let loop ([mode '=] + [guide simplified-guide] + [body #'body]) + (match guide + [(cons (and new-mode (or '/ '= '- '+ '-/ '-= '-+)) rest-guide) + (loop new-mode rest-guide body)] + [(cons car-guide rest-guide) + (define (do-append-last-acc last-acc acc) + ;; When nothing is later added to acc, we can + ;; simply put r as the last element of the + ;; reversed acc. This allows r to be an + ;; improper list. + ;; do-append-last-acc is called when elements follow + ;; the current value of last-acc. + (unless (syntax->list (datum->syntax #f last-acc)) + (raise-syntax-error + 'hlite + (format + (string-append + "the removal of elements caused a list with a" + "dotted tail to be spliced in a non-final position: ~a") + (syntax->datum (datum->syntax #f last-acc))) + stx)) + (append (reverse (syntax->list (datum->syntax #f last-acc))) + acc)) + (define loop2-result + (let loop2 ([first-iteration? #t] + [guide guide] + [body (if (syntax? body) (syntax-e body) body)] + [acc '()] + [last-acc '()]) + (cond + [(and (pair? guide) + (memq (car guide) '(/ = - + -/ -= -+))) + (if (or first-iteration? + (eq? (car guide) mode)) + (loop (car guide) (cdr guide) body) + (let ([r (loop (car guide) (cdr guide) body)]) + (if (stx-null? r) + ;; produce: (accumulated ... . last-acc) + (append (reverse acc) last-acc) + ;; produce: (accumulated ... last-acc ... . rest) + (let ([r-acc (reverse (do-append-last-acc + last-acc + acc))]) + (append r-acc r)))))] + [(and (pair? guide) (pair? body)) + ;; accumulate the first element of body, if mode is not '- + ;; which means that the element should be removed. + (cond + [(and (memq mode '(- -/ -= -+)) + (or (pair? (car body)) + (and (syntax? (car body)) + (pair? (syntax-e (car body)))))) + (let ([r (loop mode (car guide) (car body))]) + (loop2 #f + (cdr guide) + (cdr body) + (do-append-last-acc last-acc acc) + r))] + [(memq mode '(- -/ -= -+)) + (loop2 #f + (cdr guide) + (cdr body) + acc + last-acc)] + [else + (loop2 #f + (cdr guide) + (cdr body) + (do-append-last-acc last-acc acc) + (list (loop mode (car guide) (car body))))])] + ;; If body is not a pair, then we will treat it as an + ;; "improper tail" element, unless it is null? + [(null? body) + ;; produce: + ;; ((accumulated ...)) + (let* ([r-acc (append (reverse acc) last-acc)]) + r-acc)] + [else + ;; produce: + ;; (accumulated ... . improper-tail) + (let* ([new-body (loop mode guide body)] + [r-acc+tail (append + (reverse + (do-append-last-acc last-acc acc)) + new-body)]) + r-acc+tail)]))) + (if (syntax? body) + (datum->syntax body loop2-result body body) + loop2-result)] + [(? symbol?) + body] + ['() + body]))) + ;(displayln new-body) + ;(show-stx new-body) + #`(begin + (init) + #,(datum->syntax + stx + `(,(datum->syntax #'here 'chunk #'self) + #:display-only + ,#'name + . ,(syntax-e new-body)) + stx) + (chunk #:save-as dummy name + . #,new-executable-code)))])) + diff --git a/info.rkt b/info.rkt @@ -0,0 +1,31 @@ +#lang info +(define collection "hyper-literate") +(define deps '("base" + "rackunit-lib" + "at-exp-lib" + "scheme-lib" + "scribble-lib" + "typed-racket-lib" + "typed-racket-more" + "typed-racket-doc" + "scribble-enhanced" + "sexp-diff" + "tr-immutable" + "typed-map-lib" + "debug-scopes" + "syntax-color-lib")) +(define build-deps '("scribble-lib" + "racket-doc" + "rackunit-doc" + "scribble-doc" + "rackunit-doc")) +(define scribblings '(("scribblings/hyper-literate.scrbl" () ("Scribble Libraries")) + ("test/test.hl.rkt" () (omit-start)) + ("test/test2.hl.rkt" () (omit-start)))) +(define pkg-desc + (string-append "Hyper-literate programming is to literate programming exactly" + " what hypertext documents are to regular books and texts." + " For now, this is based on scribble/lp2, and only contains" + " some ε-improvements over it")) +(define version "0.2") +(define pkg-authors '(|Suzanne Soy|)) diff --git a/lang.rkt b/lang.rkt @@ -0,0 +1,8 @@ +#lang racket/base +;; Forked from scribble-lib/scribble/lp/lang/lang2.rkt +(require "private/common.rkt") + +(provide (rename-out [module-begin/doc #%module-begin]) + ;; TODO: this is the #%top-interaction from racket/base, not from the + ;; user-specified language. + #;#%top-interaction) diff --git a/lang/first-line-utils.rkt b/lang/first-line-utils.rkt @@ -0,0 +1,55 @@ +#lang racket/base + +(require racket/port) + +(provide read-whole-first-line + read-syntax-whole-first-line + narrow-to-one-line + read-line-length) + +(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-*-whole-first-line rec-read in) + (define in1 (peeking-input-port (narrow-to-one-line in))) + + (define start-pos (file-position in1)) + + (let loop ([last-good-pos start-pos]) + (define res+ + ;; Try to read (may fail if the last object to read spills onto the next + ;; lines. We read from the peeking-input-port, so that we can retry the + ;; last read on the full, non-narrowed port. + (with-handlers ([exn:fail:read? (λ (_) 'read-error)]) + (list (rec-read in1)))) + (cond + [(eq? res+ 'read-error) + ;; Last read was unsuccessful, only consume the bytes from the original + ;; input port up to the last successful read. Then, re-try one last read + ;; on the whole file (i.e. the last read object may span several lines). + (read-bytes (- last-good-pos start-pos) in) + (list (rec-read in))] + [(eof-object? (car res+)) + ;; Last successful read, actually consume the bytes from the original + ;; input port. Technically, last-good-pos and (file-position pk) should + ;; be the same, since the last read returned #<eof> (and therefore did + ;; not advance the read pointer. + (read-bytes (- (file-position in1) start-pos) in) + '()] + [else + ;; One successful read. Prepend it, and continue reading some more. + (cons (car res+) + (loop (file-position in1)))]))) + +(define (read-whole-first-line in) + (read-*-whole-first-line (λ (in1) (read in1)) in)) + +(define (read-syntax-whole-first-line source-name in) + (read-*-whole-first-line (λ (in1) (read-syntax source-name in1)) in)) +\ No newline at end of file diff --git a/lang/meta-first-line.rkt b/lang/meta-first-line.rkt @@ -0,0 +1,60 @@ +#lang racket/base + +(require scribble/reader + racket/port + racket/syntax + syntax/stx + syntax/strip-context + "first-line-utils.rkt" + (only-in "../comment-reader.rkt" make-comment-readtable) + "../comments/hide-comments.rkt") + +(provide meta-read-inside + meta-read-syntax-inside + get-command-char) + +(define (make-at-reader+comments #:syntax? [syntax? #t] + #:inside? [inside? #f] + #:char [command-char #\@]) + (make-at-reader + #:syntax? syntax? + #:inside? inside? + #:command-char command-char + #:datum-readtable (λ (rt) + (make-comment-readtable + #:readtable rt + #:comment-wrapper '#%comment + #:unsyntax #f)))) + +(define (get-command-char rd1) + (define rd1-datum (syntax->datum (datum->syntax #f rd1))) + (if (and (pair? rd1-datum) + (keyword? (car rd1-datum)) + (= 1 (string-length (keyword->string (car rd1-datum))))) + (values (string-ref (keyword->string (car rd1-datum)) 0) + (if (syntax? rd1) + (datum->syntax rd1 (stx-cdr rd1) rd1 rd1) + (cdr rd1))) + (values #\@ rd1))) + +(define (meta-read-inside in . args) + (define rd1 (read-whole-first-line in)) + (define-values (at-exp-char new-rd1) (get-command-char #'rd1)) + (define rd (apply (make-at-reader+comments #:syntax? #f + #:inside? #t + #:char at-exp-char) + args)) + `(,new-rd1 . ,rd)) + +(define (meta-read-syntax-inside source-name in . args) + (with-syntax ([rd1 (read-syntax-whole-first-line source-name in)]) + (let-values ([(command-char new-rd1) (get-command-char #'rd1)]) + (with-syntax* ([new-rd1-stx new-rd1] + [rd (apply (make-at-reader+comments #:syntax? #t + #:inside? #t + #:char command-char) + source-name + in + args)] + [rd-hide (hide-#%comment #'rd)]) + #'(new-rd1-stx . rd-hide))))) +\ No newline at end of file diff --git a/lang/reader.rkt b/lang/reader.rkt @@ -0,0 +1,87 @@ +#lang s-exp syntax/module-reader +;; Forked from scribble-lib/scribble/lp/lang/reader.rkt + +hyper-literate/lang + +#: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 (wrapped-scribble-base-reader-info) +(require "meta-first-line.rkt" + (only-in scribble/base/reader + scribble-base-reader-info + scribble-base-language-info) + "first-line-utils.rkt") + +(define orig-scribble-base-reader-info + (scribble-base-reader-info)) + +(require syntax-color/scribble-lexer + syntax-color/racket-lexer + racket/port) + +(define (wrapped-scribble-base-reader-info) + (define (read/at-exp in offset x-mode) + (define-values (mode2 lexr command-char mode) + (apply values x-mode)) + + (define-values (r1 r2 r3 r4 r5 max-back-up new-mode) + (lexr in offset mode)) + (define new-x-mode (list 'main lexr command-char new-mode)) + + (values r1 r2 r3 r4 r5 max-back-up new-x-mode)) + + (define (make-lexr command-char) + (make-scribble-inside-lexer #:command-char (or command-char #\@))) + + (define (read/options in offset x-mode) + (define-values (mode2 command-char depth) + (apply values x-mode)) + + (define-values (txt type paren start end status) (racket-lexer/status in)) + (define new-depth (case status + [(open) (add1 depth)] + [(close) (sub1 depth)] + [else depth])) + ;; TODO: limit the number of newlines to a single newline. + (if (or + ;; Fallback to scribble mode fast if we get a close-paren too many. + ;; This could be because the text starts right after the last "config" + ;; expression (which would start on the first line, then continue). + (< new-depth 0) + (and (= new-depth 0) + (and (eq? type 'white-space) + (regexp-match #px"\n" txt)))) + (values txt type paren start end + 0 (list 'main (make-lexr command-char) command-char #f)) + (let () + (define new-command-char + (or command-char + (if (memq type '(comment sexp-comment white-space)) + #f + (if (eq? type 'hash-colon-keyword) + (let ([rd (read (open-input-string txt))]) + (if (and (keyword? rd) + (= (string-length (keyword->string rd)) 1)) + (string-ref (keyword->string rd) 0) + #\@)) + #\@)))) + (values txt type paren start end + 0 (list 'options new-command-char new-depth))))) + + (lambda (key defval default) + (case key + [(color-lexer) + (λ (in offset x-mode) + (cond + [(eq? x-mode #f) + (read/options in offset (list 'options #f 0))] + [(eq? (car x-mode) 'options) + (read/options in offset x-mode)] + [else + (read/at-exp in offset x-mode)]))] + [else + (orig-scribble-base-reader-info key defval default)]))) diff --git a/main.rkt b/main.rkt @@ -0,0 +1,38 @@ +#lang racket/base + +(require (for-syntax racket/base + racket/syntax) + (except-in scribble/lp2 chunk CHUNK)) + +(require (only-in hyper-literate/private/lp + chunk + CHUNK)) + +(provide defck + repeat-chunk + chunk + CHUNK) + +(define-syntax (defck stx) + (syntax-case stx () + [(self . rest) + (with-syntax ([(name . content) #'rest] + [chk (datum->syntax #'self 'chunk)]) + (with-syntax ([name2 (format-id #'name "~a-repeat" #'name)]) + #`(begin + #,(syntax/loc stx (chk . rest)) + ;(define name2 #'content) + (define-syntax (name2 stx2) + (syntax-case stx2 () + [(_ prefix (... ...)) #'(prefix (... ...) . content)])))))])) + +(define-syntax (repeat-chunk stx) + (syntax-case stx () + [(self name) + (let ([stripped-name (regexp-replace #px"^<(.*)>$" + (symbol->string (syntax-e #'name)) + "\\1")]) + (with-syntax ([chk (datum->syntax #'self 'chunk)] + [name2 (format-id #'name "~a-repeat" #'name)] + [name-rep (format-id #'name "(~a)" stripped-name)]) + #'(name2 chk name-rep)))])) diff --git a/private/chunks-toc-prefix.rkt b/private/chunks-toc-prefix.rkt @@ -0,0 +1,4 @@ +#lang racket/base + +(provide chunks-toc-prefix) +(define chunks-toc-prefix (make-parameter '())) +\ No newline at end of file diff --git a/private/common.rkt b/private/common.rkt @@ -0,0 +1,270 @@ +#lang racket/base +;; Forked from scribble-lib/scribble/lp/lang/common.rkt + +(provide (except-out (all-from-out racket/base) #%module-begin) + module-begin/plain + module-begin/doc) + +(require (for-syntax racket/base syntax/boundmap racket/list + syntax/strip-context + syntax/srcloc + racket/struct + syntax/srcloc + debug-scopes/named-scopes/exptime)) + +(begin-for-syntax + (define first-id #f) + (define main-id #f) + (define (mapping-get mapping id) + (free-identifier-mapping-get mapping id (lambda () '()))) + ;; maps a chunk identifier to its collected expressions + (define chunks (make-free-identifier-mapping)) + ;; maps a chunk identifier to all identifiers that are used to define it + (define chunk-groups (make-free-identifier-mapping)) + (define (get-chunk id) (mapping-get chunks id)) + (define (add-to-chunk! id exprs) + (unless first-id (set! first-id id)) + (when (eq? (syntax-e id) '<*>) (set! main-id id)) + (free-identifier-mapping-put! + chunk-groups id + (cons id (mapping-get chunk-groups id))) + (free-identifier-mapping-put! + chunks id + `(,@(mapping-get chunks id) ,@exprs)))) + +(define-for-syntax (tangle orig-stx) + (define chunk-mentions '()) + (unless first-id + (raise-syntax-error 'scribble/lp "no chunks")) + (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)]) + (restore + main-id + (let loop ([block (get-chunk main-id)]) + (append-map + (lambda (expr) + (if (identifier? expr) + (let ([subs (get-chunk expr)]) + (if (pair? subs) + (begin (set! chunk-mentions (cons expr chunk-mentions)) + (loop subs)) + (list (shift expr)))) + (let ([subs (syntax->list expr)]) + (if subs + (list (restore expr (loop subs))) + (list (shift expr)))))) + block))))) + (with-syntax ([body (strip-comments body)] + ;; Hopefully the scopes are correct enough on the whole body. + [body0 (syntax-case body () [(a . _) #'a] [a #'a])] + ;; construct arrows manually + [((b-use b-id) ...) + (append-map (lambda (m) + (map (lambda (u) + (list (syntax-local-introduce m) + (syntax-local-introduce u))) + (mapping-get chunk-groups m))) + chunk-mentions)]) + ;; TODO: use disappeared-use and disappeared-binding. + ;; TODO: fix srcloc (already fixed?). + ;#`(#,(datum->syntax #'body0 'begin) (let ([b-id (void)]) b-use) ... body0 body ...) + (syntax-property + (syntax-property #`(#,(datum->syntax #'body0 'begin) . body) + 'disappeared-binding (syntax->list (syntax-local-introduce #'(b-id ...)))) + 'disappeared-use (syntax->list (syntax-local-introduce #'(b-use ...)))))) + +(define-for-syntax (strip-comments body) + (cond + [(syntax? body) + (define r (strip-comments (syntax-e body))) + (if (eq? r (syntax-e body)) + body + (datum->syntax body r body body))] + [(pair? body) + (define a (car body)) + (define ad (syntax-e a)) + (cond + [(and (pair? ad) + (memq (syntax-e (car ad)) + '(code:comment + code:contract))) + (strip-comments (cdr body))] + [(eq? ad 'code:blank) + (strip-comments (cdr body))] + [(and (or (eq? ad 'code:hilite) + (eq? ad 'code:quote)) + (let* ([d (cdr body)] + [dd (if (syntax? d) + (syntax-e d) + d)]) + (and (pair? dd) + (or (null? (cdr dd)) + (and (syntax? (cdr dd)) + (null? (syntax-e (cdr dd)))))))) + (define d (cdr body)) + (define r + (strip-comments (car (if (syntax? d) (syntax-e d) d)))) + (if (eq? ad 'code:quote) + `(quote ,r) + r)] + [(and (pair? ad) + (eq? (syntax-e (car ad)) + 'code:line)) + (if (null? (cdr body)) + (strip-comments (cdr ad)) + (strip-comments (append (cdr ad) (cdr body))))] + [else (cons (strip-comments a) + (strip-comments (cdr body)))])] + [else body])) + +(define-for-syntax (extract-chunks exprs) + (let loop ([exprs exprs]) + (syntax-case exprs () + [() (void)] + [(expr . exprs) + (syntax-case #'expr (define-values quote-syntax) + [(define-values (lifted) (quote-syntax (a-chunk id body ...))) + (eq? (syntax-e #'a-chunk) 'a-chunk) + (begin + (add-to-chunk! #'id (syntax->list #'(body ...))) + (loop #'exprs))] + [_ + (loop #'exprs)])]))) + +(require (for-syntax racket/syntax + syntax/parse)) + +(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 maybe-chain₊ . body) + (let () + (define ch₊ (syntax->list #'maybe-chain₊)) + (define expanded (local-expand + (datum->syntax stx + `(,#'lang-module-begin ,@ch₊ . ,#'body) + stx + stx) + 'module-begin + (list))) + (define meta-language-nesting + ;; Use a module-like scope here, instead of (make-syntax-introducer), + ;; otherwise DrRacket stops drawing some arrows (why?). + (make-module-like-named-scope 'meta-language-nesting)) + (syntax-case expanded (#%plain-module-begin) + [(#%plain-module-begin . expanded-body) + #`(begin + . + #,(meta-language-nesting #'expanded-body))]))])) + +(define-for-syntax ((make-module-begin submod?) stx) + (syntax-parse stx + ;; #:no-require-lang is ignored, but still allowed for compatibility. + ;; TODO: semantically, the no-require-lang and no-auto-require should be + ;; before the lang, as they are arguments to hyper-literate itself. + [(_modbeg {~or (lang:id + {~optional (~and no-require-lang #:no-require-lang)} + {~optional (~and no-auto-require #:no-auto-require)}) + ({~optional (~and no-auto-require #:no-auto-require)} + (lang:id + . chain₊))} + body0 . body) + (let () + (define lang-sym (syntax-e #'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)) + (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)) + ,@(strip-context #'(body0 . body))))]) + (syntax-case expanded () + [(module name elang (mb . stuff)) + (let () + (extract-chunks #'stuff) + (define/with-syntax 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* + ([ctx #'body0 #;(syntax-local-introduce #'body0)] + ;; TODO: this is a hack, it would be nice to get + ;; the actual source location of the lang. + [bd1 (update-source-location #'body0 + #:line #f + #:column #f + #:position 7 + #:span 14)] + [lng (datum->syntax #'ctx 'scribble/doclang2 #'bd1 #'bd1)] + [begn (datum->syntax #'ctx 'begin)]) + (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 + #,(if (attribute chain₊) + #'(chain₊) + #'()) + 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 @@ -0,0 +1,301 @@ +#lang scheme/base +;; Forked from scribble-lib/scribble/private/lp.rkt + +(require scribble/decode + scribble-enhanced/with-manual + scribble/struct + (for-syntax scheme/base + syntax/boundmap + syntax/parse + racket/syntax + racket/struct + syntax/srcloc + "../restore-comments.rkt")) + +(begin-for-syntax + ;; maps chunk identifiers to a counter, so we can distinguish multiple uses + ;; of the same name + (define chunk-numbers (make-free-identifier-mapping)) + (define (get-chunk-number id) + (free-identifier-mapping-get chunk-numbers id (lambda () #f))) + (define (inc-chunk-number id) + (free-identifier-mapping-put! + chunk-numbers id + (+ 1 (free-identifier-mapping-get chunk-numbers id)))) + (define (init-chunk-number id) + (free-identifier-mapping-put! chunk-numbers id 2)) + (define repeat-chunk-numbers (make-free-identifier-mapping)) + (define (init-repeat-chunk-number id) + (free-identifier-mapping-put! repeat-chunk-numbers id 1)) + (define (get-repeat-chunk-number id) + (free-identifier-mapping-get repeat-chunk-numbers + id + (lambda () 1))) + (define (get+increment-repeat-chunk-number! id) + (let ([current (free-identifier-mapping-get repeat-chunk-numbers + id + (lambda () 1))]) + ;; note: due to multiple expansions, this does not increase exactly one at + ;; a time but instead it can skip numbers. Since this is not visible by + ;; the user, and just used as a token in the URL, it's okay as long as + ;; compiling the same file twice gives the same numbers (which is + ;; hopefully the case but hasn't been tested). + (free-identifier-mapping-put! repeat-chunk-numbers id (add1 current)) + current))) + +(require (for-syntax "no-auto-require.rkt") + "chunks-toc-prefix.rkt") +(define-for-syntax (make-chunk-code unsyntax?) + (syntax-parser + ;; no need for more error checking, using chunk for the code will do that + [(_ name:id expr ...) + + ;; Lift the code so that it is caught by `extract-chunks` in common.rkt + ;(syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...))) + + ;; Convoluted trick to allow unsyntax in chunks of code. The unsyntax + ;; escapes the chunk so that code can be injected at compile-time. + ;; The identifiers inside the escaped portion need to be available both + ;; for-syntax i.e. (for-meta 1) and (for-meta 0). This is because the + ;; underlying @racketblock expands the code at run-time, but the + ;; extract-chunks function in common.rkt looks at the expanded source + ;; code. + ;; For now, only #, i.e. unsyntax is supported, within @chunk. + ;; Later support for UNSYNTAX within @CHUNK may be added. + (define expand-unsyntax + (if unsyntax? + ;; New hack: + #'((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)) + #'(void)) + (macro-to-expand-unsyntax)) + ;; Default (old) behaviour, does not support escaping via #, + (begin (syntax-local-lift-expression + #'(quote-syntax (a-chunk name expr ...))) + #f))) + + (with-syntax + ;; Extract require forms + ([((for-label-mod ...) ...) + (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 ...))))]) + #`(begin + #,@(if expand-unsyntax expand-unsyntax #'()) + #,@(if (null? (syntax-e #'(for-label-mod ... ...))) + #'() + #'((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 (prettify-chunk-name str) + (regexp-replace #px"^<(.*)>$" str "«\\1»")) + +(define-for-syntax ((make-chunk-display racketblock unsyntax-id) stx) + (syntax-parse stx + ;; no need for more error checking, using chunk for the code will do that + [(_ {~optional {~seq #:button button}} + (original-before-expr ...) + original-name:id + name:id + stxn:number + expr ...) + (define n (syntax-e #'stxn)) + (define original-name:n (syntax-local-introduce + (format-id #'original-name + "~a:~a" + #'original-name + n))) + (define n-repeat (get+increment-repeat-chunk-number! + original-name:n)) + (define str (symbol->string (syntax-e #'name))) + (define str-display (prettify-chunk-name str)) + (define/with-syntax tag (format "chunk:~a:~a:~a" str n n-repeat)) + (define/with-syntax (rest ...) + ;; if the would-be-next number for this chunk name is "2", then there is + ;; only one chunk, whose number is "1". Otherwise, if the number is 3 or + ;; more, it means that the chunk with number "2" exists, so we should + ;; display the subscript numbers. + (if (let ([c (get-chunk-number #'original-name)]) + (and c (> c 2))) + #`((subscript #,(format "~a" n))) + #'())) + ;; Restore comments which have been read by the modified comment-reader + ;; and stashed away by read-syntax in "../lang/meta-first-line.rkt" + (define/with-syntax (_ . expr*+comments) + (restore-#%comment #'(original-before-expr ... expr ...) + #:replace-with + (λ (stx) + (syntax-parse stx + #:datum-literals (#%comment) + [({~and #%comment com} . rest) + #:with c-c (datum->syntax #'com 'code:comment #'com #'com) + (datum->syntax stx `(,#'c-c (,unsyntax-id . ,#'rest)) stx stx)] + [other + #'other])) + #:scope #'original-name)) + ;; The (list) here could be important, to avoid the code being + ;; executed multiple times in weird ways, when pre-expanding. + #`(list + (make-splice + (list (make-toc-element + #f + (list (elemtag '(prefixable tag) + (bold (italic (elemref '(prefixable tag) + #:underline? #f + #,str-display rest ...)) + " ::=")) + #,@(if (attribute button) #'{button} #'{})) + (list (smaller + (make-link-element "plainlink" + (decode-content + (list #,str-display rest ...)) + `(elem (prefixable + ,@(chunks-toc-prefix) + tag)))))) + (#,racketblock + . #,(strip-source #'expr*+comments)))))])) + +(define-for-syntax (make-chunk chunk-code chunk-display) + (syntax-parser + ;; no need for more error checking, using chunk for the code will do that + [(_ {~optional {~seq #:save-as save-as:id}} + {~optional {~and #:display-only display-only}} + {~optional {~seq #:button button}} + {~and name:id original-before-expr} + expr ...) + #:with (btn ...) (if (attribute button) #'{#:button button} #'{}) + (define n (get-chunk-number (syntax-local-introduce #'name))) + (define/with-syntax name:n (format-id #'name "~a:~a" #'name (or n 1))) + + (define/with-syntax stripped-name + (regexp-replace #px"^<(.*)>$" + (symbol->string (syntax-e #'name)) + "\\1")) + + (when n + (inc-chunk-number (syntax-local-introduce #'name))) + + (define/with-syntax stx-n (or n 1)) + (define/with-syntax stx-chunk-code chunk-code) + (define/with-syntax stx-chunk-display chunk-display) + + #`(begin + #,@(if (attribute display-only) + #'{} + #`{(stx-chunk-code name + . #,(if preexpanding? + #'(expr ...) + #'(expr ...) + #;(strip-source #'(expr ...))))}) + #,@(if n + #'() + #'((define-syntax name (make-element-id-transformer + (lambda (stx) #'(chunkref name)))) + (define-syntax dummy (init-chunk-number #'name)))) + #,(if (attribute save-as) + #`(begin + #,#'(define-syntax (do-for-syntax _) + (init-repeat-chunk-number (quote-syntax name:n)) + #'(void)) + (do-for-syntax) + (define-syntax (save-as s) + (syntax-case s () + [(_) + (let* ([local-name (syntax-local-introduce + (quote-syntax name))] + [local-name:n (syntax-local-introduce + (quote-syntax name:n))] + [n-repeat (get-repeat-chunk-number + local-name:n)]) + (with-syntax + ([name-maybe-paren (if (> n-repeat 1) + (format-id local-name + "(~a)" + stripped-name) + local-name)]) + #'(save-as name-maybe-paren)))] + [(_ newname) + (with-syntax ([local-name + (syntax-local-introduce + (quote-syntax name))] + [(local-expr (... ...)) + (syntax-local-introduce + (quote-syntax #,(strip-source #'(expr ...))))]) + #`(stx-chunk-display + btn ... + (original-before-expr) + local-name + newname + stx-n + 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 btn ... + (original-before-expr) + name + name + stx-n + . #,(strip-source #'(expr ...))))))])) + +(define-syntax chunk-code (make-chunk-code #t)) +(define-syntax CHUNK-code (make-chunk-code #f)) +(define-syntax chunk-display (make-chunk-display #'racketblock #'unsyntax)) +(define-syntax CHUNK-display (make-chunk-display #'RACKETBLOCK #'UNSYNTAX)) +(define-syntax chunk (make-chunk #'chunk-code #'chunk-display)) +(define-syntax CHUNK (make-chunk #'CHUNK-code #'CHUNK-display)) + +(define-syntax (chunkref stx) + (syntax-case stx () + [(_ id) + (identifier? #'id) + (with-syntax ([tag (format "chunk:~a:1:1" (syntax-e #'id))] + [pretty (prettify-chunk-name (format "~a" (syntax-e #'id)))]) + #'(elemref '(prefixable tag) #:underline? #f pretty))])) + + +(provide (all-from-out scheme/base + scribble-enhanced/with-manual) + chunk + CHUNK + chunks-toc-prefix) +\ No newline at end of file diff --git a/private/no-auto-require.rkt b/private/no-auto-require.rkt @@ -0,0 +1,6 @@ +#lang racket/base + +(provide no-auto-require?) +(define no-auto-require? (box #f)) +(provide preexpanding?) +(define preexpanding? (box #f)) +\ No newline at end of file diff --git a/restore-comments.rkt b/restore-comments.rkt @@ -0,0 +1,3 @@ +#lang racket +(require "comments/restore-comments.rkt") +(provide restore-#%comment) +\ No newline at end of file diff --git a/scribblings/diff1-example.hl.rkt b/scribblings/diff1-example.hl.rkt @@ -0,0 +1,120 @@ +#lang hyper-literate #:♦ racket/base +♦;(dotlambda/unhygienic . racket/base) + +♦title{Highlighting added, removed and existing parts in literate programs} + +♦defmodule[hyper-literate/diff1] + +Highly experimental. Contains bugs, API may change in the future. + +♦defform[(hlite name pat . body)]{ + + Like ♦racket[chunk], but highlights parts of the ♦racket[body] according to + the pattern ♦racket[pat]. + + The ♦racket[pat] should cover the whole ♦racket[body], which can contain + multiple expressions. The ♦racket[pat] can use the following symbols: + + ♦itemlist[ + ♦item{♦racket[=] to indicate that the following elements are ``normal'' and + should not be highlighted in any special way.} + ♦item{♦racket[/] to indicate that the following elements were already + existing in previous occurrences of the code (the part is dimmed)} + ♦item{♦racket[+] to indicate that the following elements are new (highlighted + in green)} + ♦item{♦racket[-] to indicate that the following elements are removed + (highlighted in red). Removed elements are also removed from the actual + executable source code. If a removed element contains one or more normal, new + or dimmed elements, these children are spliced in place of the removed + element.} + ♦item{Other symbols are placeholders for the elements}] + + In the following example, the ♦racket[1] is highlighted as removed (and will + not be present in the executable code), the ♦racket[π] is highlighted as + added, and the rest of the code is dimmed: + + ♦codeblock|{ + #lang hyper-literate #:♦ racket/base + ♦hlite[<my-code> {/ (def args (_ - _ + _ / . _))} + (define (foo v) + (+ 1 π . v))]}| + + It produces the result shown below:} + +♦require[hyper-literate/diff1] + +♦hlite[<my-code> {/ (def args (_ - _ + _ / . _))} + (define (foo v) + (+ 1 π . v))] + +♦section{Example} + +You can look at the source code of this document to see how this example is +done. + +♦require[hyper-literate/diff1] + +We define the function foo as follows: + +♦chunk[<foo> + (define (foo v) + (+ 1 v))] + +However, due to implementation details, we need to add ♦racket[π] to this +value: + +♦hlite[|<foo'>| {/ (def args (_ _ + _ / . _))} + (define (foo v) + (+ 1 π . v))] + +In order to optimise the sum of ♦racket[1] and ♦racket[π], we extract the +computation to a global helper constant: + + +♦hlite[|<foo''>| {+ _ _ / (def args '(+ a - b + c d . e) (_ - _ _ + _ / _)) = _} + (define π 3.1414592653589793) + (define one-pus-π (+ 1 π)) + (define (foo v) + '(a b c d . e) + (+ 1 π one-pus-π v))0] + +♦hlite[|<www>| (/ (quote (+ a - b + c d . e)) + (quote (+ a - b + c d . e)) + (= quote (+ a - b + c d . e)) + (quote (quote (+ a - b + c d . e)))) + '(a b c d . e) + (quote (a b c d . e)) + (quote (a b c d . e)) + ''(a b c d . e)] + +The whole program is therefore: + +♦hlite[|<aaa>| {- a + b = c / d} + 1 2 3 4] + +♦hlite[<bbb> {- (+ a - b = c)} + (x y z)] + +♦hlite[<ccc> {(z - (+ a - b / . c))} + (0 (x y . z))] + +♦hlite[<ddd> {(z - ((+ a a - b b / . c)))} + (0 ((x x y yy . z)))] + +♦hlite[<eee> {(z - ((+ a a - b b / . c)))} + (0 ((x x y yy + . z)))] + +♦chunk[<*> + (require rackunit) + |<foo''>| + (check-= (foo 42) (+ 42 1 3.1414592653589793) 0.1) + (check-equal? (list <www>) + '((a c d . e) + (a c d . e) + (a c d . e) + (quote (a c d . e)))) + (check-equal? '(<aaa>) '(2 3 4)) + (check-equal? '(0 <bbb> 1) '(0 x z 1)) + (check-equal? '<ccc> '(0 x . z)) + (check-equal? '<ddd> '(0 x x . z))] +\ No newline at end of file diff --git a/scribblings/hyper-literate.scrbl b/scribblings/hyper-literate.scrbl @@ -0,0 +1,275 @@ +#lang scribble/manual +@require[racket/require + @for-label[hyper-literate + racket/base + (subtract-in scribble/manual hyper-literate) + racket/contract]] + +@title{Hyper-literate programming} +@author[@author+email["Suzanne Soy" "racket@suzanne.soy"]] + +@(require scribble/manual + scribble/core + scribble/decode + scribble/racket + (only-in scribble/racket value-link-color)) + +@defmodulelang[hyper-literate] + +The @racketmodname[hyper-literate] metalanguage extends the +features of @racketmodname[scribble/lp2], with the goal of +providing a more modern view on literate programming. It can +be parameterized with the language used in the chunks (so +that it is possible to directly write +@racketmodname[typed/racket] programs with +@racketmodname[hyper-literate], for example). + +On the first line, which begins with @tt{@litchar{#lang} + @racketmodname[hyper-literate]}, the language recognises the following +options: + +@(require scribble/core + (only-in scribble/private/manual-vars boxed-style) + scribble/private/manual-utils) +@(make-table + boxed-style + (list + (list + @paragraph[(style #f '())]{ + @tt{@litchar{#lang} @racketmodname[hyper-literate] @racket[_lang] + @racket[_maybe-no-req] @racket[_maybe-no-auto]}}) + flow-empty-line + (list + @racketgrammar*[ + (maybe-no-req (code:line) + (code:line #:no-require-lang)) + (maybe-no-auto (code:line) + (code:line #:no-auto-require))]))) + +where @racket[_lang] is a module name which can be used as +a @litchar{#lang}, for example @racketmodname[typed/racket] +or @racketmodname[racket/base]. + +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. 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 +changes), extracts the @racket[require] statements from +chunks of code, and passes them to +@racket[(require (for-label …))]. The goal is to have +identifiers from required modules automatically highlighted +and hyperlinked to their documentation. However, all +meta-levels are smashed into the @racket[#f], i.e. +@racket[for-label] meta-level. As a consequence, conflicts +can arise at the @racket[for-label] meta-level between two +modules, even if these two modules were originally required +at distinct meta-levels in the source program. It is +possible in this case to disable the feature using +@racket[#:no-auto-require], and to manually call +@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 +exactly what hypertext documents are to regular books and +texts. Literate programming is about telling other +programmers how the program works (instead of just telling +the compiler what it does). Telling this story can be done +using non-linear, hyperlinked documents. + +For now these utilities only help with manipulating literate +programming chunks (e.g. repeating the same chunk in several +places in the output document, but keeping a single copy in +the source code). + +Ultimately, the reading experience should be closer to +viewing an interactive presentation, focusing on the parts +of the program that are of interest to you: expand on-screen +the chunks you are curious about, run some tests and see +their result, etc. + +@itemlist[ + @item{Imagine something like + @hyperlink["http://www.andrewbragdon.com/codebubbles_site.asp"]{ + code bubbles}, but with explanatory text coming along + with the source code.} + @item{Imagine something like + @hyperlink["http://inform7.com/"]{Inform}, but focused on + exploring a program instead of exploring an imaginary + world — after all, a program is some kind of imaginary + world.}] + +@section{Chunks of code} + +@; @racket[chunk] does not work for these, probably due to the use of either: +@; @title[#:tag "lp" …]{Literate Programming} +@; or: +@; @defmodulelang[scribble/lp2 #:use-sources (scribble/lp)]{…} +@; in scribble-doc/scribblings/scribble/lp.scrbl +@; See scribble bug #51 https://github.com/racket/scribble/issues/51 +@(define scribble-chunk + (element symbol-color + (make-link-element value-link-color + (decode-content (list "chunk")) + '(form ((lib "scribble/lp.rkt") chunk))))) +@(define scribble-CHUNK + (element symbol-color + (make-link-element value-link-color + (decode-content (list "CHUNK")) + '(form ((lib "scribble/lp.rkt") CHUNK))))) + +@;{ + @(module scribble-doc-links racket/base + (require scribble/manual + (for-label scribble/lp2 + scribble/private/lp)) + (provide (all-defined-out)) + (define scribble-chunk @racket[chunk]) + (define scribble-CHUNK @racket[CHUNK])) + @(require 'scribble-doc-links) +} + +@defform[(chunk <name> content ...)]{ + Same as @scribble-chunk from @racketmodname[scribble/lp2], + with a few tweaks and bug fixes.} + +@defform[(CHUNK <name> content ...)]{ + Same as @scribble-CHUNK from @racketmodname[scribble/lp2], + with a few tweaks and bug fixes.} + +@section{Memorizing and repeating chunks} + +@defform[(defck <name> content ...)]{ + Like @racket[chunk] from @racketmodname[scribble/lp2], but + remembers the chunk so that it can be re-displayed later + using @racket[repeat-chunk].} + +@defform[(repeat-chunk <name>)]{ + Shows again a @racket[chunk] of code previously remembered + with @racket[defck]. If the @racket[<name>] starts and + ends with angle brackets, they are replaced by parentheses + to hint that this is not the first occurrence of this + chunk, so that the name becomes @racket[|(name)|]} + +@section{Order of expansion of the program} + +The file is expanded a first time, in order to identify and +aggregate the chunks of code (declared with @racket[chunk]). +Then, the top-level module of the file is constructed using +these chunks, and a @racket[doc] submodule is added, which +contains all the surrounding text. The chunks are typeset +where they appear using @racket[racketblock]. + +The @racket[doc] submodule is declared using +@racket[module*], so that it can use +@racket[(require (submod ".."))] to use functions declared +in the chunks. For example, it should be possible to +dynamically compute the result of a function, and to insert +it into the document, so that the value displayed always +matches the implementation. + +When the file is expanded for the first time, however, the +@racket[(submod "..")] does not exist yet, and cannot be +required. This is the case because the first expansion is +performed precisely to extract the chunks and inject them in +that module. + +To solve this problem, the following macros behave +differently depending on whether the code is being expanded +for the first time or not (in which case the +@racket[(submod "..")] module can be used). + +@defform[(if-preexpanding a b)]{ + Expands to @racket[a] if the code is being pre-expanded, + and expands to @racket[b] if the @racket[(submod "..")] + module can be used.} + +@defform[(when-preexpanding . body)]{ + Expands to @racket[(begin . body)] if the code is being + pre-expanded, and expands to @racket[(begin)] otherwise.} + +@defform[(unless-preexpanding . body)]{ + Expands to @racket[(begin . body)] if the @racket[(submod "..")] + module can be used, and expands to @racket[(begin)] otherwise.} + +@section{A note on literate programs as subsections of another document} + +To use @racket[include-section] on hyper-literate programs, a couple of +workarounds are required to avoid issues with duplicate tags for +identically-named chunks (like @racket[<*>], which is likely to always be +present). + +@defparam[chunks-toc-prefix prefix-list (listof string?)]{ + We give an example for two files which are part of a hypothetical + @elem[#:style 'tt "pkg"] package: + + @itemlist[ + @item{The main scribble file @filepath{main.scrbl} in the + @filepath{scribblings} sub-directory includes the hyper-literate file + @filepath{program.hl.rkt} located in the package's root directory, one + directory level above: + + @codeblock[#:keep-lang-line? #t + "#lang scribble/manual\n" + "@title{Main document title}\n" + "@include-section{../program.hl.rkt}\n" + "@; could include other hyper-literat programs here\n"]} + @item{To avoid issues with duplicate tag names, it is necessary to use the + @racket[#:tag-prefix] option on the hyper literate program's @racket[title]. + Unfortunately, this breaks links to chunks in the table of contents, because + scribble does not automatically add the correct prefix to them. To ensure + that the links correctly work in the table of contents, it is necessary to + tell hyper-literate what is the chain of document includes. The whole + @filepath{program.hl.rkt} file will be: + + @codeblock[#:keep-lang-line? #t + "#lang hyper-literate racket/base\n" + "@title[#:tag-prefix '(lib \"pkg/program.hl.rkt\")]{Program title}\n" + "@(chunks-toc-prefix '(\"(lib pkg/scribblings/main.scrbl)\"\n" + " \"(lib pkg/program.hl.rkt)\"))\n" + "@chunk[<*>\n" + " 'program-code-here]\n"] + + Note that the argument for the @racket[chunks-toc-prefix] parameter is a list + of string, and the strings are representations of module paths. The + occurrences of @racket[lib] above are not symbols, they are just part of the + string. Compare this with the following, which would be incorrect: + + @codeblock[#:keep-lang-line? #t + "#lang hyper-literate racket/base\n" + "@title[#:tag-prefix '(lib \"pkg/program.hl.rkt\")]{Program title}\n" + "@; This is incorrect:\n" + "@(chunks-toc-prefix '((lib \"pkg/scribblings/main.scrbl\")\n" + " (lib \"pkg/program.hl.rkt\")))\n" + "@chunk[<*>\n" + " 'program-code-here]\n"]}]} + +@include-section[(submod (lib "hyper-literate/scribblings/diff1-example.hl.rkt") + doc)] +\ No newline at end of file diff --git a/spoiler1.rkt b/spoiler1.rkt @@ -0,0 +1,142 @@ +#lang racket + +(provide spoiler-wrapper-collapsed + spoiler-default + spoiler-alt + spoiler-button-default-to-alt + spoiler-button-alt-to-default + spoiler1 + spler) + +(require scribble/manual + scribble/core + scribble/decode + scribble/html-properties + hyper-literate + (for-syntax syntax/parse) + scriblib/render-cond) + +(define spoiler-css + #" +.spoiler-wrapper-expanded .spoiler-default, +.spoiler-wrapper-expanded .spoiler-button-default-to-alt { + display:none; +} +.spoiler-wrapper-collapsed .spoiler-alt, +.spoiler-wrapper-collapsed .spoiler-button-alt-to-default { + display:none; +} + +.spoiler-button-default-to-alt, +.spoiler-button-alt-to-default { + color: #2a657e; +} +") + +(define spoiler-js + (string->bytes/utf-8 + #<<EOJS +function toggleSpoiler(e, doExpand) { + var expanded = function(className) { + return className.match(/\bspoiler-wrapper-expanded\b/); + }; + var collapsed = function(className) { + return className.match(/\bspoiler-wrapper-collapsed\b/); + }; + var found = function(className) { + return expanded(className) || collapsed(className); + }; + var wrapper = e; + while (e != document && e != null && ! found(e.className)) { + e = e.parentNode; + } + e.className = e + .className + .replace(/ */g, " ") + .replace(/\bspoiler-wrapper-expanded\b/, '') + .replace(/\bspoiler-wrapper-collapsed\b/, ''); + if (doExpand) { + e.className = e.className + " spoiler-wrapper-expanded"; + } else { + e.className = e.className + " spoiler-wrapper-collapsed"; + } + if (e.preventDefault) { e.preventDefault(); } + return false; +} +EOJS + )) + +(define-syntax-rule (def-style name) + (define name + (style (symbol->string 'name) + (list (css-addition spoiler-css) + (js-addition spoiler-js) + (alt-tag "div"))))) + +(def-style spoiler-wrapper-collapsed) +(def-style spoiler-default) +(def-style spoiler-alt) + +(define (spoiler-button-default-to-alt txt) + (hyperlink + #:style (style "spoiler-button-default-to-alt" + (list (css-addition spoiler-css) + (js-addition spoiler-js) + (attributes + '([onclick . "return toggleSpoiler(this, true);"])))) + "#" + txt)) + +(define (spoiler-button-alt-to-default txt) + (hyperlink + #:style (style "spoiler-button-alt-to-default" + (list (css-addition spoiler-css) + (js-addition spoiler-js) + (attributes + '([onclick . "return toggleSpoiler(this, false);"])))) + "#" + txt)) + +(define (spoiler1 default button-default→alt button-alt→default alternate) + (nested-flow spoiler-wrapper-collapsed + (list + (paragraph (style #f '()) + (spoiler-button-default-to-alt button-default→alt)) + (nested-flow spoiler-default + (decode-flow default)) + (paragraph (style #f '()) + (spoiler-button-alt-to-default button-alt→default)) + (nested-flow spoiler-alt + (decode-flow alternate))))) + +(define-syntax spler + (syntax-parser + [(_ name default ... #:expanded expanded ...) + #'(begin + (chunk #:save-as ck1 + #:display-only + #:button + (cond-element + [html (list " " (smaller + (spoiler-button-default-to-alt "expand")))] + [else (list)]) + name + default ...) + + (chunk #:save-as ck2 + #:button + (cond-element + [html (list " " (smaller + (spoiler-button-alt-to-default "collapse")))] + [else (list)]) + name + expanded ...) + + (cond-block + [html (nested-flow spoiler-wrapper-collapsed + (list (nested-flow spoiler-default + (decode-flow (ck1))) + (nested-flow spoiler-alt + (decode-flow (ck2)))))] + [else (nested-flow (style #f '()) + (decode-flow (ck2)))]))])) +\ No newline at end of file diff --git a/test/comments/annotate-syntax-typed.rkt b/test/comments/annotate-syntax-typed.rkt @@ -0,0 +1,69 @@ +#lang typed/racket + +(require typed-map + tr-immutable/typed-syntax) + +(provide annotate-syntax) + +(: annotate-syntax (->* (ISyntax/Non) + (#:srcloc+scopes? Boolean) + Sexp/Non)) +(define (annotate-syntax e #:srcloc+scopes? [srcloc+scopes? #f]) + (annotate-syntax1 e srcloc+scopes?)) + +(: annotate-syntax1 (→ (U ISyntax/Non ISyntax/Non-E) + Boolean + Sexp/Non)) +(define (annotate-syntax1 e srcloc+scopes?) + (cond + [(syntax? e) + (append + (list 'syntax + (append-map (λ ([kᵢ : Symbol]) + (if (and (or (eq? kᵢ 'first-comments) + (eq? kᵢ 'comments-after)) + (not (syntax-property e kᵢ))) + (list) + (list kᵢ (any->isexp/non (syntax-property e kᵢ))))) + (syntax-property-symbol-keys e))) + (if srcloc+scopes? + (list (any->isexp/non (syntax-source e)) + (any->isexp/non (syntax-line e)) + (any->isexp/non (syntax-column e)) + (any->isexp/non (syntax-position e)) + (any->isexp/non (syntax-span e)) + (any->isexp/non (syntax-source-module e)) + (any->isexp/non (hash-ref (syntax-debug-info e) + 'context))) + (list)) + (list (annotate-syntax1 (syntax-e e) srcloc+scopes?)))] + [(null? e) + 'null] + [(list? e) + (list 'list + (map (λ (eᵢ) (annotate-syntax1 eᵢ srcloc+scopes?)) + e))] + [(pair? e) + (list 'cons + (annotate-syntax1 (car e) srcloc+scopes?) + (annotate-syntax1 (cdr e) srcloc+scopes?))] + [(vector? e) + (list 'vector + (immutable? e) + (map (λ (eᵢ) (annotate-syntax1 eᵢ srcloc+scopes?)) + (vector->list e)))] + [(box? e) + (list 'box + (immutable? e) + (annotate-syntax1 (unbox e) srcloc+scopes?))] + [(or (symbol? e) + (string? e) + (boolean? e) + (char? e) + (number? e) + (keyword? e)) + e] + [(NonSyntax? e) + (list 'NonSyntax (NonSexp (NonSyntax-v e)))] + [(NonSexp? e) + (list 'NonSexp e)])) +\ No newline at end of file diff --git a/test/comments/annotate-syntax.rkt b/test/comments/annotate-syntax.rkt @@ -0,0 +1,52 @@ +#lang racket + +(provide annotate-syntax) + +(define (annotate-syntax e #:srcloc+scopes? [srcloc+scopes? #f]) + (cond + [(syntax? e) + (append + (list 'syntax + (append-map (λ (kᵢ) + (if (and (or (eq? kᵢ 'first-comments) + (eq? kᵢ 'comments-after)) + (not (syntax-property e kᵢ))) + (list) + (list kᵢ (syntax-property e kᵢ)))) + (syntax-property-symbol-keys e))) + (if srcloc+scopes? + (list (syntax-source e) + (syntax-line e) + (syntax-column e) + (syntax-position e) + (syntax-span e) + (syntax-source-module e) + (hash-ref (syntax-debug-info e) 'context)) + (list)) + (list (annotate-syntax (syntax-e e) #:srcloc+scopes? srcloc+scopes?)))] + [(null? e) + 'null] + [(list? e) + (list 'list + (map (λ (eᵢ) (annotate-syntax eᵢ #:srcloc+scopes? srcloc+scopes?)) + e))] + [(pair? e) + (list 'cons + (annotate-syntax (car e) #:srcloc+scopes? srcloc+scopes?) + (annotate-syntax (cdr e) #:srcloc+scopes? srcloc+scopes?))] + [(vector? e) + (list 'vector + (immutable? e) + (map (λ (eᵢ) (annotate-syntax eᵢ #:srcloc+scopes? srcloc+scopes?)) + (vector->list e)))] + [(symbol? e) + e] + [(string? e) + e] + [else + (raise-argument-error + 'annotate-syntax + (string-append "a syntax object containing recursively on of the" + " following: pair, null, vector, symbol, string") + 0 + e)])) +\ No newline at end of file diff --git a/test/comments/same-syntax-typed.rkt b/test/comments/same-syntax-typed.rkt @@ -0,0 +1,33 @@ +#lang typed/racket + +(require "annotate-syntax-typed.rkt" + tr-immutable/typed-syntax + rackunit) + +(require typed/racket/unsafe) +(unsafe-require/typed sexp-diff + [sexp-diff (case→ + (→ Sexp Sexp Sexp) + (→ Sexp/Non Sexp/Non Sexp/Non) + (→ (Sexpof Any) (Sexpof Any) (Sexpof Any)))]) + +(provide check-same-syntax) + +(: same-syntax! (→ ISyntax/Non ISyntax/Non Boolean)) +(define (same-syntax! a b) + (define answer (equal? (annotate-syntax a #:srcloc+scopes? #f) + (annotate-syntax b #:srcloc+scopes? #f))) + (unless answer + (pretty-write + (sexp-diff (annotate-syntax a) + (annotate-syntax b))) + (displayln a) + (displayln b)) + answer) + +(define-syntax (check-same-syntax stx) + (syntax-case stx () + [(_ a b) + (datum->syntax #'here + `(check-true (same-syntax! ,#'a ,#'b)) + stx)])) +\ No newline at end of file diff --git a/test/comments/same-syntax.rkt b/test/comments/same-syntax.rkt @@ -0,0 +1,25 @@ +#lang racket + +(require "annotate-syntax.rkt" + sexp-diff + rackunit) + +(provide check-same-syntax) + +(define (same-syntax! a b) + (define answer (equal? (annotate-syntax a #:srcloc+scopes? #f) + (annotate-syntax b #:srcloc+scopes? #f))) + (unless answer + (pretty-write + (sexp-diff (annotate-syntax a) + (annotate-syntax b))) + (displayln a) + (displayln b)) + answer) + +(define-syntax (check-same-syntax stx) + (syntax-case stx () + [(_ a b) + (datum->syntax #'here + `(check-true (same-syntax! ,#'a ,#'b)) + stx)])) +\ No newline at end of file diff --git a/test/comments/test-comments-round-trip.rkt b/test/comments/test-comments-round-trip.rkt @@ -0,0 +1,55 @@ +#lang racket + +(require rackunit + "../../comments/hide-comments.rkt" + "../../comments/restore-comments.rkt" + "same-syntax.rkt") + +(define round-trip (compose restore-#%comment hide-#%comment)) + +(define-syntax (check-round-trip stx) + (syntax-case stx () + [(_ a) + (datum->syntax #'here + `(begin + (check-same-syntax (round-trip ,#'a) ,#'a) + (check-equal? (syntax->datum (round-trip ,#'a)) + (syntax->datum ,#'a))) + stx)])) + +;; ============================================================================= + +(let ([stx #'(a b c)]) + (check-same-syntax stx (hide-#%comment stx))) + +(check-round-trip #'(a (#%comment "b") c)) + +(check-round-trip #'((#%comment "0") (#%comment "1") + a + (#%comment "b") + (#%comment "bb") + c + (#%comment "d") + (#%comment "dd"))) +(check-round-trip #'([#%comment c1] + a + [#%comment c2] + . ([#%comment c3] b [#%comment c4]))) +(check-round-trip #'([#%comment c1] + a + [#%comment c2] + . ([#%comment c3] + . ([#%comment c4] b [#%comment c5])))) +(check-round-trip #'([#%comment c1] + a + [#%comment c2] + . ([#%comment c3] + . ([#%comment c4] [#%comment c5])))) +(check-round-trip #'([#%comment c1] + a + ([#%comment c2]) + b)) +(check-round-trip #'([#%comment c1] + a + ([#%comment c2] . b) + c)) +\ No newline at end of file diff --git a/test/test-chunks-order.rkt b/test/test-chunks-order.rkt @@ -0,0 +1,30 @@ +#lang hyper-literate racket/base + +@chunk[<values> + 'A] + +@chunk[<values> + 'B] + +@CHUNK[<values> + 'C] + +@CHUNK[<values> + 'D] + +@chunk[<values> + 'E] + +@chunk[<values> + 'F] + +@CHUNK[<values> + 'G] + +@CHUNK[<values> + 'H] + +@chunk[<*> + (require rackunit) + (check-equal? (list <values>) + '(A B C D E F G H))] diff --git a/test/test-doc.rkt b/test/test-doc.rkt @@ -0,0 +1,3 @@ +#lang racket/base + +(require (submod "test.hl.rkt" doc)) diff --git a/test/test.hl.rkt b/test/test.hl.rkt @@ -0,0 +1,100 @@ +#lang hyper-literate typed/racket/base + +@(require (for-label typed/racket/base + rackunit)) + +@title{Title} + +@section{if-preexpanding} + +Hello world. + +@(if-preexpanding + (void) + (require (submod ".."))) + +@(unless-preexpanding + (symbol->string ee)) + +@section{Submodules} + +Submodules work: + +@chunk[<submod> + (module ms typed/racket/base + (define x 1) + (provide x)) + + (module ms2 typed/racket/base + (define y -1) + (provide y))] + +And can be required: + +@chunk[<submod> + (require 'ms) + (require (submod "." ms2))] + +Submodules with @racket[module*] work too: + +@chunk[<submod*> + (module* ms* racket/base + (require typed/rackunit) + <req-dotdot> + (check-equal? ee 'e123) + (check-equal? y -1))] + +And so does @racket[(require (submod ".." …))]: + +@chunk[<req-dotdot> + (require (submod "..")) + (require (submod ".." ms2))] + +Test with multiple subforms inside require, and coverage for +@racket[for-syntax]: + +@chunk[<req-multi> + (require (for-syntax syntax/stx + racket/syntax) + racket/bool)] + +@section{Avoiding for-label} + +Wrap the @racket[(require (for-syntax racket/base))] in a +@racket[(begin …)] so that it gets ignored, otherwise +scribble complains some identifiers are loaded twice +for-label, since some identifiers have already been introduced +at meta-level 0 by @racketmodname[typed/racket]. + +@chunk[<require-not-label> + (begin (require (for-syntax racket/base)) + (require typed/rackunit))] + +@CHUNK[<with-unsyntax> + (let* ([b 1234] + [e (syntax-e #`#,b)]) + (check-equal? e 1234))] + +@section{Main chunk} + +@chunk[<*> + <require-not-label> + <submod> + <req-multi> + <submod*> + (check-true (false? #f));; Should be hyperlinked to the main docs + (begin-for-syntax + (define/with-syntax ;; Should be hyperlinked to the main docs + x + (stx-car ;; Should be hyperlinked to the main docs + #'(a . b)))) + (check-equal? (+ x x) 2) + (check-equal? (+ x y) 0) + <with-unsyntax> + ;; Gives an error because typed/racket/base is used on the #lang line: + ;curry + (check-equal? ((make-predicate One) 1) #t) + (check-equal? (ann 'sym Symbol) 'sym) + (define (f [x : 'e123]) x) + (define ee (ann (f 'e123) 'e123)) + (provide ee)] diff --git a/test/test2.hl.rkt b/test/test2.hl.rkt @@ -0,0 +1,23 @@ +#lang hyper-literate typed/racket/base + +@(require (for-label typed/racket/base + rackunit)) + +@title{Title} + +Hello world. + +@chunk[<*> + (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 + + (check-equal? ((make-predicate One) 1) #t) + + (define (f [x : 'e123]) x) + + (define ee (ann (f 'e123) 'e123)) + (provide ee)]