Renamed main branch

.travis.yml

@@ -24,9 +24,20 @@ env:
     #- 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.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:
@@ -40,7 +51,7 @@ before_install:
 - export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us
 
 install:
- - raco pkg install --deps search-auto
+ - raco pkg install -j 2 --deps search-auto
 
 before_script:
 
@@ -48,8 +59,10 @@ before_script:
 # `raco pkg install --deps search-auto` to install any required
 # packages without it getting stuck on a confirmation prompt.
 script:
- - raco test -x -p hyper-literate
- - raco setup --check-pkg-deps --pkgs hyper-literate
+ - 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

LICENSE.txt

@@ -1,5 +1,5 @@
 hyper-literate
-Copyright (c) 2016 Georges Dupéron
+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

README.md

@@ -1,6 +1,7 @@
-[![Build Status,](https://img.shields.io/travis/jsmaniac/hyper-literate/stackoverflow-q-18877881.svg)](https://travis-ci.org/jsmaniac/hyper-literate)
-[![Coverage Status,](https://img.shields.io/coveralls/jsmaniac/hyper-literate/stackoverflow-q-18877881.svg)](https://coveralls.io/github/jsmaniac/hyper-literate)
-[![Build Stats.](https://img.shields.io/badge/build-stats-blue.svg)](http://jsmaniac.github.io/travis-stats/#jsmaniac/hyper-literate)
+[![Build Status,](https://img.shields.io/travis/jsmaniac/hyper-literate/main.svg)](https://travis-ci.org/jsmaniac/hyper-literate)
+[![Coverage Status,](https://img.shields.io/coveralls/jsmaniac/hyper-literate/main.svg)](https://coveralls.io/github/jsmaniac/hyper-literate)
+[![Build Stats,](https://img.shields.io/badge/build-stats-blue.svg)](http://jsmaniac.github.io/travis-stats/#jsmaniac/hyper-literate)
+[![Online Documentation.](https://img.shields.io/badge/docs-online-blue.svg)](http://docs.racket-lang.org/hyper-literate/)
 
 hyper-literate
 ==============
@@ -13,19 +14,28 @@ 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. repating
-the same chunk in several places in the output document, but keep a single
+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, focussing on the parts of the program that are of interest to
+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
-  explanative text comming along with the source code.
+  explanatory text coming along with the source code.
   
-* Imagine something like [Inform](http://inform7.com/), but focussed on
+* 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.
+  program is some kind of imaginary world.
+
+Installation
+------------
+
+Install with:
+
+```
+raco pkg install --deps search-auto hyper-literate
+```

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)))))

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₀ …))))])])

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₀ …))))])]))

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]))

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]))

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))

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))

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)))]))
+

info.rkt

@@ -7,10 +7,25 @@
                "scribble-lib"
                "typed-racket-lib"
                "typed-racket-more"
-               "typed-racket-doc"))
-(define build-deps '("scribble-lib" "racket-doc"))
-(define scribblings '(("scribblings/hyper-literate.scrbl" ())
-                      ("test/test.hl.rkt" ())))
-(define pkg-desc "Description Here")
-(define version "0.0")
-(define pkg-authors '(|Georges Dupéron|))
+               "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|))

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)

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))

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)))))

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)])))

main.rkt

@@ -2,11 +2,16 @@
 
 (require (for-syntax racket/base
                      racket/syntax)
-         scribble/lp2)
+         (except-in scribble/lp2 chunk CHUNK))
 
-(provide ck defck repeat-chunk)
+(require (only-in hyper-literate/private/lp
+                  chunk
+                  CHUNK))
 
-(define-syntax-rule (ck e) e)
+(provide defck
+         repeat-chunk
+         chunk
+         CHUNK)
 
 (define-syntax (defck stx)
   (syntax-case stx ()
@@ -30,4 +35,4 @@
        (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)))]))
+         #'(name2 chk name-rep)))]))

private/chunks-toc-prefix.rkt

@@ -0,0 +1,4 @@
+#lang racket/base
+
+(provide chunks-toc-prefix)
+(define chunks-toc-prefix (make-parameter '()))

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))

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)

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))

restore-comments.rkt

@@ -0,0 +1,3 @@
+#lang racket
+(require "comments/restore-comments.rkt")
+(provide restore-#%comment)

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))]

scribblings/hyper-literate.scrbl

@@ -1,10 +1,275 @@
 #lang scribble/manual
-@require[@for-label[hyper-literate
-                    racket/base]]
+@require[racket/require
+         @for-label[hyper-literate
+                    racket/base
+                    (subtract-in scribble/manual hyper-literate)
+                    racket/contract]]
 
-@title{hyper-literate}
-@author{Georges Dupéron}
+@title{Hyper-literate programming}
+@author[@author+email["Suzanne Soy" "racket@suzanne.soy"]]
 
-@defmodule[hyper-literate]
+@(require scribble/manual
+          scribble/core
+          scribble/decode
+          scribble/racket
+          (only-in scribble/racket value-link-color))
 
-Package Description Here
+@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)]

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)))]))]))

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)]))

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)]))

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)]))

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)]))

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))

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))]

test/test.hl.rkt

@@ -1,9 +1,12 @@
-#lang hyper-literate/typed typed/racket/base
+#lang hyper-literate typed/racket/base
 
-@(require (for-label typed/racket/base))
+@(require (for-label typed/racket/base
+                     rackunit))
 
 @title{Title}
 
+@section{if-preexpanding}
+
 Hello world.
 
 @(if-preexpanding
@@ -13,6 +16,8 @@ Hello world.
 @(unless-preexpanding
   (symbol->string ee))
 
+@section{Submodules}
+
 Submodules work:
 
 @chunk[<submod>
@@ -45,16 +50,47 @@ And so does @racket[(require (submod ".." …))]:
        (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[<*>
-       (begin
-         ;; Wrap the require in a `(begin …)` so that it gets ignored,
-         ;; otherwise scribble complains some identifiers are loaded twice
-         ;; for-label.
-         (require (for-syntax)))
-       (require typed/rackunit)
+       <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)

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)]

typed/lang/common.rkt

@@ -1,174 +0,0 @@
-#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))
-
-(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 orig-stx (syntax-case stx () [(_ orig) #'orig]))
-  (define (restore nstx d) (datum->syntax orig-stx d nstx nstx))
-  (define (shift nstx) (replace-context orig-stx nstx))
-  (define body
-    (let ([main-id (or main-id first-id)])
-      (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)]
-                ;; 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)])
-    ;(displayln (dynamic-require 'tyyyyyyyyyyyped/racket '#%module-begin))
-    (replace-context #'#%module-begin;modbeg-ty
-                     #`(begin body ... (let ([b-id (void)]) 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))
-        (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-syntax 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 racket/stxparam)
-(define-syntax-parameter mbeg #'#%module-begin)
-
-(require (only-in typed/racket)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WORKAROUND
-;(dynamic-require 'typed/racket 0)
-
-(define-for-syntax ((make-module-begin submod?) stx)
-  (syntax-case stx ()
-    [(_modbeg lang body0 . body)
-     (let ()
-       ;; TODO: get the actual symbol, instead of the string returned by
-       ;; scribble's at-reader. Or use the first line as a whole as the #lang,
-       ;; to allow othe meta-languages to be chained.
-       (define lang-sym
-         (string->symbol (regexp-replace "^ " (syntax-e #'lang) "")))
-       (dynamic-require lang-sym #f)
-       (let ([expanded 
-              (expand `(,#'module scribble-lp-tmp-name hyper-literate/typed/private/lp
-                                  (define-syntax-rule (if-preexpanding a b) a)
-                                  (define-syntax-rule (when-preexpanding . b) (begin . b))
-                                  (define-syntax-rule (unless-preexpanding . b) (begin))
-                                  ,@(strip-context #'(body0 . body))))])
-         (syntax-case expanded ()
-           [(module name lang (mb . stuff))
-            (let ()
-              (extract-chunks #'stuff)
-              (dynamic-require lang-sym #f)
-              (namespace-require `(for-meta -1 ,lang-sym))
-              (replace-context
-               (namespace-symbol->identifier '#%module-begin)
-               #`(#%module-begin
-                  #,(tangle #'body0)
-                  #,@(if submod?
-                         (list
-                          (let ([submod
-                                 (strip-context
-                                  #`(module doc scribble/doclang2
-                                      (define-syntax-rule (if-preexpanding a b) b)
-                                      (define-syntax-rule (when-preexpanding . b) (begin))
-                                      (define-syntax-rule (unless-preexpanding . b) (begin . b))
-                                      (require scribble/manual
-                                               (only-in hyper-literate/typed/private/lp chunk CHUNK))
-                                      (begin body0 . body)))])
-                            (syntax-case submod ()
-                              [(_ . rest)
-                               (datum->syntax #'here (cons #'module* #'rest))])))
-                         '()))))])))]))
-
-(define-syntax module-begin/plain (make-module-begin #f))
-(define-syntax module-begin/doc (make-module-begin #t))

typed/lang/lang.rkt

@@ -1,8 +0,0 @@
-#lang racket/base
-;; Forked from scribble-lib/scribble/lp/lang/lang2.rkt
-(require "common.rkt")
-
-(provide (except-out (all-from-out "common.rkt")
-                     module-begin/plain
-                     module-begin/doc)
-         (rename-out [module-begin/doc #%module-begin]))

typed/lang/reader.rkt

@@ -1,16 +0,0 @@
-#lang s-exp syntax/module-reader
-;; Forked from scribble-lib/scribble/lp/lang/reader.rkt
-
-hyper-literate/typed/lang/lang
-
-#:read read-inside
-#:read-syntax read-syntax-inside
-#:whole-body-readers? #t
-;; don't use scribble-base-info for the #:info arg, since
-;; scribble/lp files are not directly scribble'able.
-#:language-info (scribble-base-language-info)
-#:info (scribble-base-reader-info)
-(require scribble/reader
-         (only-in scribble/base/reader
-                  scribble-base-reader-info
-                  scribble-base-language-info))

typed/private/lp.rkt

@@ -1,92 +0,0 @@
-#lang scheme/base
-;; Forked from scribble-lib/scribble/private/lp.rkt
-
-(require (for-syntax scheme/base syntax/boundmap)
-         scribble/scheme scribble/decode scribble/manual scribble/struct)
-
-(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-for-syntax ((make-chunk racketblock) stx)
-  (syntax-case stx ()
-    [(_ name expr ...)
-     ;; no need for more error checking, using chunk for the code will do that
-     (identifier? #'name)
-     (let* ([n (get-chunk-number (syntax-local-introduce #'name))]
-            [str (symbol->string (syntax-e #'name))]
-            [tag (format "~a:~a" str (or n 1))])
-     
-       (when n
-         (inc-chunk-number (syntax-local-introduce #'name)))
-       
-       (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...)))
-       
-       (with-syntax ([tag tag]
-                     [str str]
-                     [((for-label-mod ...) ...)
-                      (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 ...)))]
-                     
-                     [(rest ...) (if n
-                                           #`((subscript #,(format "~a" n)))
-                                           #`())])
-         #`(begin
-             (require (for-label for-label-mod ... ...))
-             #,@(if n
-                    #'()
-                    #'((define-syntax name (make-element-id-transformer
-                                            (lambda (stx) #'(chunkref name))))
-                       (begin-for-syntax (init-chunk-number #'name))))
-             (make-splice
-              (list (make-toc-element
-                     #f
-                     (list (elemtag '(chunk tag)
-                                    (bold (italic (racket name)) " ::=")))
-                     (list (smaller (elemref '(chunk tag) #:underline? #f
-                                             str
-                                             rest ...))))
-                    (#,racketblock expr ...))))))]))
-
-(define-syntax chunk (make-chunk #'racketblock))
-(define-syntax CHUNK (make-chunk #'RACKETBLOCK))
-
-(define-syntax (chunkref stx)
-  (syntax-case stx ()
-    [(_ id)
-     (identifier? #'id)
-     (with-syntax ([tag (format "~a:1" (syntax-e #'id))]
-                   [str (format "~a" (syntax-e #'id))])
-       #'(elemref '(chunk tag) #:underline? #f str))]))
-
-
-(provide (all-from-out scheme/base
-                       scribble/manual)
-         chunk CHUNK)