Renamed main branch

.travis.yml

@@ -24,10 +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.6
+    #- 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:
@@ -41,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:
 

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,5 +1,5 @@
-[![Build Status,](https://img.shields.io/travis/jsmaniac/hyper-literate/master.svg)](https://travis-ci.org/jsmaniac/hyper-literate)
-[![Coverage Status,](https://img.shields.io/coveralls/jsmaniac/hyper-literate/master.svg)](https://coveralls.io/github/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/)
 

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

@@ -8,14 +8,24 @@
                "typed-racket-lib"
                "typed-racket-more"
                "typed-racket-doc"
-               "scribble-enhanced"))
+               "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"))
-(define scribblings '(("scribblings/hyper-literate.scrbl" ())
+                     "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 "Description Here")
-(define version "0.0")
-(define pkg-authors '(|Georges Dupéron|))
+(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

@@ -5,4 +5,4 @@
 (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)
+         #;#%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

@@ -1,31 +1,60 @@
 #lang racket/base
 
 (require scribble/reader
-         racket/port)
+         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)
+         meta-read-syntax-inside
+         get-command-char)
 
-(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 (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 (narrow-to-one-line port)
-  (make-limited-input-port port (read-line-length port)))
+(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)
-  (displayln args)
-  (apply read-inside 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)
-  (define in1 (narrow-to-one-line in))
-  (with-syntax ([rd1 (let loop ([res '()])
-                       (define res+ (read-syntax source-name in1))
-                       (if (eof-object? res+)
-                           (reverse res)
-                           (loop (cons res+ res))))]
-                [rd (apply read-syntax-inside source-name in args)])
-    #'(rd1 . rd)))
+  (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

@@ -9,8 +9,79 @@ hyper-literate/lang
 ;; don't use scribble-base-info for the #:info arg, since
 ;; scribble/lp files are not directly scribble'able.
 #:language-info (scribble-base-language-info)
-#:info (scribble-base-reader-info)
+#:info (wrapped-scribble-base-reader-info)
 (require "meta-first-line.rkt"
          (only-in scribble/base/reader
                   scribble-base-reader-info
-                  scribble-base-language-info))
+                  scribble-base-language-info)
+         "first-line-utils.rkt")
+
+(define orig-scribble-base-reader-info
+  (scribble-base-reader-info))
+
+(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)])))

private/common.rkt

@@ -7,7 +7,10 @@
 
 (require (for-syntax racket/base syntax/boundmap racket/list
                      syntax/strip-context
-                     syntax/srcloc))
+                     syntax/srcloc
+                     racket/struct
+                     syntax/srcloc
+                     debug-scopes/named-scopes/exptime))
 
 (begin-for-syntax
   (define first-id #f)
@@ -29,30 +32,14 @@
      chunks id
      `(,@(mapping-get chunks id) ,@exprs))))
 
-(define-for-syntax (tangle orig-stx req-lng)
+(define-for-syntax (tangle orig-stx)
   (define chunk-mentions '())
   (unless first-id
     (raise-syntax-error 'scribble/lp "no chunks"))
-  ;(define orig-stx (syntax-case stx () [(_ orig) #'orig]))
   (define (restore nstx d) (datum->syntax orig-stx d nstx nstx))
   (define (shift nstx) (replace-context orig-stx nstx))
   (define body
     (let ([main-id (or main-id first-id)])
-      ;; HACK to get arrows drawn for built-ins imported by the module language.
-      ;; TODO: it fails with type-expander.lp2.rkt, because it re-requires λ
-      ;;       (the new-λ) from 'main.
-      (when req-lng
-        (free-identifier-mapping-put!
-         chunk-groups main-id
-         (cons main-id (mapping-get chunk-groups main-id)))
-        (free-identifier-mapping-put!
-         chunks main-id
-         `(,#`(require #,(datum->syntax main-id
-                                        req-lng
-                                        req-lng
-                                        req-lng))
-           ,@(mapping-get chunks main-id))))
-      ;;;;;;;;;;;;;;
       (restore
        main-id
        (let loop ([block (get-chunk main-id)])
@@ -69,7 +56,9 @@
                       (list (restore expr (loop subs)))
                       (list (shift expr))))))
           block)))))
-  (with-syntax ([(body ...) (strip-comments body)]
+  (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)
@@ -78,12 +67,13 @@
                                             (syntax-local-introduce u)))
                                     (mapping-get chunk-groups m)))
                              chunk-mentions)])
-    ;(displayln (dynamic-require 'tyyyyyyyyyyyped/racket '#%module-begin))
     ;; TODO: use disappeared-use and disappeared-binding.
     ;; TODO: fix srcloc (already fixed?).
-    #`(begin (let ([b-id (void)]) b-use) ... body ...)
-    #;(replace-context #'#%module-begin;modbeg-ty
-                       #`(begin (let ([b-id (void)]) b-use) ... body ...))))
+    ;#`(#,(datum->syntax #'body0 'begin) (let ([b-id (void)]) b-use) ... body0 body ...)
+    (syntax-property
+     (syntax-property #`(#,(datum->syntax #'body0 'begin) . 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
@@ -122,7 +112,9 @@
        [(and (pair? ad)
              (eq? (syntax-e (car ad))
                   'code:line))
-        (strip-comments (append (cdr ad) (cdr body)))]
+        (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]))
@@ -144,26 +136,68 @@
 (require (for-syntax racket/syntax
                      syntax/parse))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(require (only-in typed/racket)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WORKAROUND ;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (require (for-syntax racket/pretty
                      "no-auto-require.rkt"))
+
+(define-for-syntax (strip-source e)
+  (cond [(syntax? e)
+         (update-source-location
+          (datum->syntax e (strip-source (syntax-e e)) e e)
+          #:source #f)]
+        [(pair? e) (cons (strip-source (car e)) (strip-source (cdr e)))]
+        [(vector? e) (list->vector (strip-source (vector->list e)))]
+        [(prefab-struct-key e)
+         => (λ (k) (make-prefab-struct k (strip-source (struct->list e))))]
+        ;; TODO: hash tables
+        [else e]))
+
+;; Many thanks to Alex Knauth and Matthew Flatt for finding out how to make
+;; module meta-languages.
+(define-syntax (continue stx)
+  (syntax-case stx ()
+    [(_self lang-module-begin 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
-    [(_modbeg (lang:id (~optional (~and no-require-lang #:no-require-lang))
-                       (~optional (~and no-auto-require #:no-auto-require)))
+    ;; #: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 
+       (let ([expanded
               (expand `(,#'module
                         scribble-lp-tmp-name hyper-literate/private/lp
                         (require hyper-literate/private/chunks-toc-prefix
                                  (for-syntax racket/base
                                              hyper-literate/private/no-auto-require))
                         (begin-for-syntax (set-box! no-auto-require?
-                                                    ,(if (attribute no-auto-require) #t #f)))
+                                                    ,(if (attribute no-auto-require) #t #f))
+                                          (set-box! preexpanding? #t))
                         (define-syntax-rule (if-preexpanding a b) a)
                         (define-syntax-rule (when-preexpanding . b) (begin . b))
                         (define-syntax-rule (unless-preexpanding . b) (begin))
@@ -172,25 +206,20 @@
            [(module name elang (mb . stuff))
             (let ()
               (extract-chunks #'stuff)
-              (dynamic-require lang-sym #f)
-              (namespace-require `(for-meta -1 ,lang-sym))
-              #;(begin
-                  (define/with-syntax tngl (tangle #'body0))
-                  (define/with-syntax (tngl0 . tngl*) #'tngl)
-                  (define/with-syntax (ex-mod ex-nam ex-lng (ex-#%m . ex-rest))
-                    (expand-syntax
-                     #`(#,#'module hyper-literate-temp-expand #,lang-sym
-                                   #,(replace-context #'here #'tngl))))
-                  #`(ex-#%m #,(datum->syntax (syntax-local-introduce #'ex-rest)
-                                             '(#%require lang-sym))
-                            . ex-rest))
               (define/with-syntax tngl
-                (tangle #'body0 (if (attribute no-require-lang) #f #'lang)))
-              ;(replace-context
-              ;(namespace-symbol->identifier '#%module-begin)
-              ;#`(#,(syntax/loc #'lang #%module-begin) …)
-              #`(#,(namespace-symbol->identifier '#%module-begin)
-                 tngl
+                (tangle #'body0))
+              (define/with-syntax mb9 (datum->syntax #f '#%module-begin))
+              (define/with-syntax lang-modbeg (datum->syntax #'lang '#%module-begin))
+              ; See http://stackoverflow.com/questions/37867859/module-meta-language-in-racket :
+              #;(define expanded-main-mod-stx
+                  (local-expand
+                   (syntax-local-introduce
+                    (datum->syntax #f `(,#'module ignored ,(datum->syntax #f lang-sym #'lang #'lang) (,#'mb9 ,(syntax-local-introduce #'tngl)))))
+                   'top-level
+                   (list)))
+              ;(syntax-case expanded-main-mod-stx ();(module #%plain-module-begin)
+              ;[(module _ lng11 (#%plain-module-begin . mod-body11))
+              #`(#%plain-module-begin
                  #,@(if submod?
                         (list
                          (with-syntax*
@@ -204,32 +233,38 @@
                                                            #:span 14)]
                               [lng (datum->syntax #'ctx 'scribble/doclang2 #'bd1 #'bd1)]
                               [begn (datum->syntax #'ctx 'begin)])
-                           #`(module* doc lng ;module doc scribble/doclang2
-                               #,@(syntax-local-introduce
-                                   ;; TODO: instead use:
-                                   ;; (begin-for-syntax (set! preexpanding #f))
-                                   ;; and make these identifiers exported by
-                                   ;; hyper-literate
-                                   (strip-context
-                                    #`((require hyper-literate/private/chunks-toc-prefix
-                                                (for-syntax racket/base
-                                                            hyper-literate/private/no-auto-require))
-                                       (begin-for-syntax (set-box! no-auto-require?
-                                                                   #,(if (attribute no-auto-require) #t #f)))
-                                       (define-syntax-rule (if-preexpanding a b)
-                                         b)
-                                       (define-syntax-rule (when-preexpanding . b)
-                                         (begin))
-                                       (define-syntax-rule (unless-preexpanding . b)
-                                         (begin . b))
-                                       (require scribble-enhanced/with-manual
-                                                hyper-literate))))
-                               (begn body0 . body))
-                           ;(strip-context
-                           #;#`(modl doc lng ;module doc scribble/doclang2
-                                     
-                                     (begn body0 . body))))
-                        '())))])))]))
+                           (strip-source
+                            #`(module* doc lng ;module doc scribble/doclang2
+                                #,@(syntax-local-introduce
+                                    ;; TODO: instead use:
+                                    ;; (begin-for-syntax (set! preexpanding #f))
+                                    ;; and make these identifiers exported by
+                                    ;; hyper-literate
+                                    (strip-context
+                                     #`((require hyper-literate/private/chunks-toc-prefix
+                                                 (for-syntax racket/base
+                                                             hyper-literate/private/no-auto-require))
+                                        (begin-for-syntax
+                                          (set-box! no-auto-require?
+                                                    #,(if (attribute no-auto-require) #t #f))
+                                          (set-box! preexpanding? #f))
+                                        (define-syntax-rule (if-preexpanding a b)
+                                          b)
+                                        (define-syntax-rule (when-preexpanding . b)
+                                          (begin))
+                                        (define-syntax-rule (unless-preexpanding . b)
+                                          (begin . b))
+                                        (require scribble-enhanced/with-manual
+                                                 hyper-literate))))
+                                (begn body0 . body)))))
+                        '())
+                 (require lang)
+                 (continue lang-modbeg
+                           #,(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

@@ -7,7 +7,10 @@
          (for-syntax scheme/base
                      syntax/boundmap
                      syntax/parse
-                     racket/syntax))
+                     racket/syntax
+                     racket/struct
+                     syntax/srcloc
+                     "../restore-comments.rkt"))
 
 (begin-for-syntax
   ;; maps chunk identifiers to a counter, so we can distinguish multiple uses
@@ -113,10 +116,30 @@
                   #'()
                   #'((require (for-label for-label-mod ... ...))))))]))
 
-(define-for-syntax ((make-chunk-display racketblock) stx)
+(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
-    [(_ original-name:id name:id stxn:number expr ...)
+    [(_ {~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
@@ -126,6 +149,7 @@
      (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
@@ -136,6 +160,20 @@
              (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
@@ -145,20 +183,28 @@
                 (list (elemtag '(prefixable tag)
                                (bold (italic (elemref '(prefixable tag)
                                                       #:underline? #f
-                                                      #,str rest ...))
-                                     " ::=")))
+                                                      #,str-display rest ...))
+                                     " ::="))
+                      #,@(if (attribute button) #'{button} #'{}))
                 (list (smaller
                        (make-link-element "plainlink"
-                                          (decode-content (list #,str rest ...))
+                                          (decode-content
+                                           (list #,str-display rest ...))
                                           `(elem (prefixable
                                                   ,@(chunks-toc-prefix)
                                                   tag))))))
-               (#,racketblock expr ...))))]))
+               (#,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)) name:id expr ...)
+    [(_ {~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)))
      
@@ -175,12 +221,18 @@
      (define/with-syntax stx-chunk-display chunk-display)
      
      #`(begin
-         (stx-chunk-code name expr ...)
+         #,@(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))))
-                   (begin-for-syntax (init-chunk-number #'name))))
+                   (define-syntax dummy (init-chunk-number #'name))))
          #,(if (attribute save-as)
                #`(begin
                    #,#'(define-syntax (do-for-syntax _)
@@ -209,20 +261,27 @@
                                         (quote-syntax name))]
                                       [(local-expr (... ...))
                                        (syntax-local-introduce
-                                        (quote-syntax (expr ...)))])
+                                        (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 name name stx-n expr ...))))]))
+               #`(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))
-(define-syntax CHUNK-display (make-chunk-display #'RACKETBLOCK))
+(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))
 
@@ -231,8 +290,8 @@
     [(_ id)
      (identifier? #'id)
      (with-syntax ([tag (format "chunk:~a:1:1" (syntax-e #'id))]
-                   [str (format "~a" (syntax-e #'id))])
-       #'(elemref '(prefixable tag) #:underline? #f str))]))
+                   [pretty (prettify-chunk-name (format "~a" (syntax-e #'id)))])
+       #'(elemref '(prefixable tag) #:underline? #f pretty))]))
 
 
 (provide (all-from-out scheme/base

private/no-auto-require.rkt

@@ -1,4 +1,6 @@
 #lang racket/base
 
 (provide no-auto-require?)
-(define no-auto-require? (box #f))
+(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

@@ -5,8 +5,8 @@
                     (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"]]
 
 @(require scribble/manual
           scribble/core
@@ -41,8 +41,10 @@ options:
    flow-empty-line
    (list
     @racketgrammar*[
- [maybe-no-req #:no-require-lang]
- [maybe-no-auto #:no-auto-require]])))
+ (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]
@@ -52,14 +54,11 @@ The current implementation of hyper-literate needs to inject
 a @racket[(require _lang)] in the expanded module, in order
 to have the arrows properly working in DrRacket for
 "built-in" identifiers which are provided by the 
-@racket[_lang] itself. This extra @racket[require] statement
-can however conflict with later user-provided 
-@racket[require] statements, which would otherwise shadow
-the built-ins. The @racket[#:no-require-lang] option
-disables that behaviour, and has the only drawback that
-built-ins of the @racket[_lang] language do not have an
-arrow in DrRacket (but they still should be highlighted with
-a turquoise background when hovered over with the mouse).
+@racket[_lang] itself. The @racket[require] statement is
+injected after the whole ``code'' module has been expanded.
+It is worth noting that an extra scope is added to the expanded
+body of the module, in order to make any @racket[require] form
+within more specific than the @racket[(require _lang)].
 
 The current implementation of @racketmodname[scribble/lp2],
 on which @racketmodname[hyper-literate] relies (with a few
@@ -78,6 +77,24 @@ possible in this case to disable the feature using
 @racket[(require (for-label …))] and handle conflicting
 identifiers in a more fine-grained way.
 
+@deprecated[#:what @racket[#:no-require-lang] ""]{
+                                                  
+ The @racket[#:no-require-lang] is deprecated starting from version 0.1, and
+ is not needed anymore. It is still accepted for backwards compatibility. Note
+ that version 0.1 of this library requires a fairly recent Racket version to
+ work properly (it needs v.6.7.0.4 with the commit
+ @tt{8a7852ebbfeb85a8f860700ba5ae481ed7aa9b41}, or v.6.7.0.5 or later). By
+ default, raco will install v0.0 of hyper-literate on older Racket versions.
+
+ The extra @racket[require] statement injected by
+ @racketmodname[hyper-literate] could in previous versions conflict with
+ user-written @racket[require] statements. These @racket[require] statements
+ can shadow some built-ins, and this case would yield conflicts. The
+ @racket[#:no-require-lang] option disables that behaviour in versions < 0.1,
+ and has the only drawback that built-ins of the @racket[_lang] language do not
+ have an arrow in DrRacket (but they still should be highlighted with -a
+ turquoise background when hovered over with the mouse).}
+
 @section{What is hyper-literate programming?}
 
 Hyper-literate programming is to literate programming
@@ -252,4 +269,7 @@ present).
  "@(chunks-toc-prefix '((lib \"pkg/scribblings/main.scrbl\")\n"
  "                      (lib \"pkg/program.hl.rkt\")))\n"
  "@chunk[<*>\n"
- "       'program-code-here]\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))