Compare commits
3 Commits
main
...
stackoverf
| Author | SHA1 | Date | |
|---|---|---|---|
|
bdba7e8f43 | ||
|
|
948f9adef1 | ||
|
|
fef49f611e |
.travis.ymlLICENSE.txtREADME.mdcomment-reader.rkt
comments
hide-comments-typed.rkthide-comments.rktrestore-comments-typed.rktrestore-comments.rktsyntax-properties-typed.rktsyntax-properties.rkt
diff1.rktinfo.rktlang.rktlang
main.rktprivate
restore-comments.rktscribblings
spoiler1.rkttest
comments
annotate-syntax-typed.rktannotate-syntax.rktsame-syntax-typed.rktsame-syntax.rkttest-comments-round-trip.rkt
test-chunks-order.rkttest.hl.rkttest2.hl.rkttyped
25
.travis.yml
25
.travis.yml
|
|
@ -24,20 +24,9 @@ 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.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=6.3
|
||||
- RACKET_VERSION=6.4
|
||||
- RACKET_VERSION=6.5
|
||||
- RACKET_VERSION=HEAD
|
||||
|
||||
matrix:
|
||||
|
|
@ -51,7 +40,7 @@ before_install:
|
|||
- export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us
|
||||
|
||||
install:
|
||||
- raco pkg install -j 2 --deps search-auto
|
||||
- raco pkg install --deps search-auto
|
||||
|
||||
before_script:
|
||||
|
||||
|
|
@ -59,10 +48,8 @@ before_script:
|
|||
# `raco pkg install --deps search-auto` to install any required
|
||||
# packages without it getting stuck on a confirmation prompt.
|
||||
script:
|
||||
- raco test -p hyper-literate
|
||||
- raco setup --check-pkg-deps --no-zo --no-launcher --no-install --no-post-install --no-docs --pkgs hyper-literate
|
||||
- raco pkg install --deps search-auto doc-coverage
|
||||
- raco doc-coverage hyper-literate
|
||||
- raco test -x -p hyper-literate
|
||||
- raco setup --check-pkg-deps --pkgs hyper-literate
|
||||
|
||||
after_success:
|
||||
- raco pkg install --deps search-auto cover cover-coveralls
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
hyper-literate
|
||||
Copyright (c) 2016 Suzanne Soy
|
||||
Copyright (c) 2016 Georges Dupéron
|
||||
|
||||
This package is distributed under the GNU Lesser General Public
|
||||
License (LGPL). This means that you can link hyper-literate into proprietary
|
||||
|
|
|
|||
28
README.md
28
README.md
|
|
@ -1,7 +1,6 @@
|
|||
[](https://travis-ci.org/jsmaniac/hyper-literate)
|
||||
[](https://coveralls.io/github/jsmaniac/hyper-literate)
|
||||
[](http://jsmaniac.github.io/travis-stats/#jsmaniac/hyper-literate)
|
||||
[](http://docs.racket-lang.org/hyper-literate/)
|
||||
[](https://travis-ci.org/jsmaniac/hyper-literate)
|
||||
[](https://coveralls.io/github/jsmaniac/hyper-literate)
|
||||
[](http://jsmaniac.github.io/travis-stats/#jsmaniac/hyper-literate)
|
||||
|
||||
hyper-literate
|
||||
==============
|
||||
|
|
@ -14,28 +13,19 @@ telling other programmers how the program works (instead of just telling the
|
|||
compiler what it does). Telling this story can be done using non-linear,
|
||||
hyperlinked documents.
|
||||
|
||||
For now these utilities only help with manipulating LP chunks (e.g. repeating
|
||||
the same chunk in several places in the output document, but keeping a single
|
||||
For now these utilities only help with manipulating LP chunks (e.g. repating
|
||||
the same chunk in several places in the output document, but keep a single
|
||||
copy in the source code).
|
||||
|
||||
Ultimately, the reading experience should be closer to viewing an interactive
|
||||
presentation, focusing on the parts of the program that are of interest to
|
||||
presentation, focussing on the parts of the program that are of interest to
|
||||
you: expand on-screen the chunks you are curious about, run some tests and see
|
||||
their result, etc.
|
||||
|
||||
* Imagine something like [code
|
||||
bubbles](http://www.andrewbragdon.com/codebubbles_site.asp), but with
|
||||
explanatory text coming along with the source code.
|
||||
explanative text comming along with the source code.
|
||||
|
||||
* Imagine something like [Inform](http://inform7.com/), but focused on
|
||||
* Imagine something like [Inform](http://inform7.com/), but focussed on
|
||||
exploring a program instead of exploring an imaginary world — after all, a
|
||||
program is some kind of imaginary world.
|
||||
|
||||
Installation
|
||||
------------
|
||||
|
||||
Install with:
|
||||
|
||||
```
|
||||
raco pkg install --deps search-auto hyper-literate
|
||||
```
|
||||
program is some kind of imaginary world.
|
||||
|
|
@ -1,99 +0,0 @@
|
|||
;; 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)))))
|
||||
|
|
@ -1,140 +0,0 @@
|
|||
#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₀ …))))])])
|
||||
|
|
@ -1,75 +0,0 @@
|
|||
#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₀ …))))])]))
|
||||
|
|
@ -1,130 +0,0 @@
|
|||
#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]))
|
||||
|
|
@ -1,130 +0,0 @@
|
|||
#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]))
|
||||
|
|
@ -1,81 +0,0 @@
|
|||
#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))
|
||||
|
|
@ -1,37 +0,0 @@
|
|||
#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))
|
||||
387
diff1.rkt
387
diff1.rkt
|
|
@ -1,387 +0,0 @@
|
|||
#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)))]))
|
||||
|
||||
29
info.rkt
29
info.rkt
|
|
@ -7,25 +7,10 @@
|
|||
"scribble-lib"
|
||||
"typed-racket-lib"
|
||||
"typed-racket-more"
|
||||
"typed-racket-doc"
|
||||
"scribble-enhanced"
|
||||
"sexp-diff"
|
||||
"tr-immutable"
|
||||
"typed-map-lib"
|
||||
"debug-scopes"
|
||||
"syntax-color-lib"))
|
||||
(define build-deps '("scribble-lib"
|
||||
"racket-doc"
|
||||
"rackunit-doc"
|
||||
"scribble-doc"
|
||||
"rackunit-doc"))
|
||||
(define scribblings '(("scribblings/hyper-literate.scrbl" () ("Scribble Libraries"))
|
||||
("test/test.hl.rkt" () (omit-start))
|
||||
("test/test2.hl.rkt" () (omit-start))))
|
||||
(define pkg-desc
|
||||
(string-append "Hyper-literate programming is to literate programming exactly"
|
||||
" what hypertext documents are to regular books and texts."
|
||||
" For now, this is based on scribble/lp2, and only contains"
|
||||
" some ε-improvements over it"))
|
||||
(define version "0.2")
|
||||
(define pkg-authors '(|Suzanne Soy|))
|
||||
"typed-racket-doc"))
|
||||
(define build-deps '("scribble-lib" "racket-doc"))
|
||||
(define scribblings '(("scribblings/hyper-literate.scrbl" ())
|
||||
("test/test.hl.rkt" ())))
|
||||
(define pkg-desc "Description Here")
|
||||
(define version "0.0")
|
||||
(define pkg-authors '(|Georges Dupéron|))
|
||||
|
|
|
|||
8
lang.rkt
8
lang.rkt
|
|
@ -1,8 +0,0 @@
|
|||
#lang racket/base
|
||||
;; Forked from scribble-lib/scribble/lp/lang/lang2.rkt
|
||||
(require "private/common.rkt")
|
||||
|
||||
(provide (rename-out [module-begin/doc #%module-begin])
|
||||
;; TODO: this is the #%top-interaction from racket/base, not from the
|
||||
;; user-specified language.
|
||||
#;#%top-interaction)
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
#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))
|
||||
|
|
@ -1,60 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require scribble/reader
|
||||
racket/port
|
||||
racket/syntax
|
||||
syntax/stx
|
||||
syntax/strip-context
|
||||
"first-line-utils.rkt"
|
||||
(only-in "../comment-reader.rkt" make-comment-readtable)
|
||||
"../comments/hide-comments.rkt")
|
||||
|
||||
(provide meta-read-inside
|
||||
meta-read-syntax-inside
|
||||
get-command-char)
|
||||
|
||||
(define (make-at-reader+comments #:syntax? [syntax? #t]
|
||||
#:inside? [inside? #f]
|
||||
#:char [command-char #\@])
|
||||
(make-at-reader
|
||||
#:syntax? syntax?
|
||||
#:inside? inside?
|
||||
#:command-char command-char
|
||||
#:datum-readtable (λ (rt)
|
||||
(make-comment-readtable
|
||||
#:readtable rt
|
||||
#:comment-wrapper '#%comment
|
||||
#:unsyntax #f))))
|
||||
|
||||
(define (get-command-char rd1)
|
||||
(define rd1-datum (syntax->datum (datum->syntax #f rd1)))
|
||||
(if (and (pair? rd1-datum)
|
||||
(keyword? (car rd1-datum))
|
||||
(= 1 (string-length (keyword->string (car rd1-datum)))))
|
||||
(values (string-ref (keyword->string (car rd1-datum)) 0)
|
||||
(if (syntax? rd1)
|
||||
(datum->syntax rd1 (stx-cdr rd1) rd1 rd1)
|
||||
(cdr rd1)))
|
||||
(values #\@ rd1)))
|
||||
|
||||
(define (meta-read-inside in . args)
|
||||
(define rd1 (read-whole-first-line in))
|
||||
(define-values (at-exp-char new-rd1) (get-command-char #'rd1))
|
||||
(define rd (apply (make-at-reader+comments #:syntax? #f
|
||||
#:inside? #t
|
||||
#:char at-exp-char)
|
||||
args))
|
||||
`(,new-rd1 . ,rd))
|
||||
|
||||
(define (meta-read-syntax-inside source-name in . args)
|
||||
(with-syntax ([rd1 (read-syntax-whole-first-line source-name in)])
|
||||
(let-values ([(command-char new-rd1) (get-command-char #'rd1)])
|
||||
(with-syntax* ([new-rd1-stx new-rd1]
|
||||
[rd (apply (make-at-reader+comments #:syntax? #t
|
||||
#:inside? #t
|
||||
#:char command-char)
|
||||
source-name
|
||||
in
|
||||
args)]
|
||||
[rd-hide (hide-#%comment #'rd)])
|
||||
#'(new-rd1-stx . rd-hide)))))
|
||||
|
|
@ -1,87 +0,0 @@
|
|||
#lang s-exp syntax/module-reader
|
||||
;; Forked from scribble-lib/scribble/lp/lang/reader.rkt
|
||||
|
||||
hyper-literate/lang
|
||||
|
||||
#:read meta-read-inside
|
||||
#:read-syntax meta-read-syntax-inside
|
||||
#:whole-body-readers? #t
|
||||
;; don't use scribble-base-info for the #:info arg, since
|
||||
;; scribble/lp files are not directly scribble'able.
|
||||
#:language-info (scribble-base-language-info)
|
||||
#:info (wrapped-scribble-base-reader-info)
|
||||
(require "meta-first-line.rkt"
|
||||
(only-in scribble/base/reader
|
||||
scribble-base-reader-info
|
||||
scribble-base-language-info)
|
||||
"first-line-utils.rkt")
|
||||
|
||||
(define orig-scribble-base-reader-info
|
||||
(scribble-base-reader-info))
|
||||
|
||||
(require syntax-color/scribble-lexer
|
||||
syntax-color/racket-lexer
|
||||
racket/port)
|
||||
|
||||
(define (wrapped-scribble-base-reader-info)
|
||||
(define (read/at-exp in offset x-mode)
|
||||
(define-values (mode2 lexr command-char mode)
|
||||
(apply values x-mode))
|
||||
|
||||
(define-values (r1 r2 r3 r4 r5 max-back-up new-mode)
|
||||
(lexr in offset mode))
|
||||
(define new-x-mode (list 'main lexr command-char new-mode))
|
||||
|
||||
(values r1 r2 r3 r4 r5 max-back-up new-x-mode))
|
||||
|
||||
(define (make-lexr command-char)
|
||||
(make-scribble-inside-lexer #:command-char (or command-char #\@)))
|
||||
|
||||
(define (read/options in offset x-mode)
|
||||
(define-values (mode2 command-char depth)
|
||||
(apply values x-mode))
|
||||
|
||||
(define-values (txt type paren start end status) (racket-lexer/status in))
|
||||
(define new-depth (case status
|
||||
[(open) (add1 depth)]
|
||||
[(close) (sub1 depth)]
|
||||
[else depth]))
|
||||
;; TODO: limit the number of newlines to a single newline.
|
||||
(if (or
|
||||
;; Fallback to scribble mode fast if we get a close-paren too many.
|
||||
;; This could be because the text starts right after the last "config"
|
||||
;; expression (which would start on the first line, then continue).
|
||||
(< new-depth 0)
|
||||
(and (= new-depth 0)
|
||||
(and (eq? type 'white-space)
|
||||
(regexp-match #px"\n" txt))))
|
||||
(values txt type paren start end
|
||||
0 (list 'main (make-lexr command-char) command-char #f))
|
||||
(let ()
|
||||
(define new-command-char
|
||||
(or command-char
|
||||
(if (memq type '(comment sexp-comment white-space))
|
||||
#f
|
||||
(if (eq? type 'hash-colon-keyword)
|
||||
(let ([rd (read (open-input-string txt))])
|
||||
(if (and (keyword? rd)
|
||||
(= (string-length (keyword->string rd)) 1))
|
||||
(string-ref (keyword->string rd) 0)
|
||||
#\@))
|
||||
#\@))))
|
||||
(values txt type paren start end
|
||||
0 (list 'options new-command-char new-depth)))))
|
||||
|
||||
(lambda (key defval default)
|
||||
(case key
|
||||
[(color-lexer)
|
||||
(λ (in offset x-mode)
|
||||
(cond
|
||||
[(eq? x-mode #f)
|
||||
(read/options in offset (list 'options #f 0))]
|
||||
[(eq? (car x-mode) 'options)
|
||||
(read/options in offset x-mode)]
|
||||
[else
|
||||
(read/at-exp in offset x-mode)]))]
|
||||
[else
|
||||
(orig-scribble-base-reader-info key defval default)])))
|
||||
13
main.rkt
13
main.rkt
|
|
@ -2,16 +2,11 @@
|
|||
|
||||
(require (for-syntax racket/base
|
||||
racket/syntax)
|
||||
(except-in scribble/lp2 chunk CHUNK))
|
||||
scribble/lp2)
|
||||
|
||||
(require (only-in hyper-literate/private/lp
|
||||
chunk
|
||||
CHUNK))
|
||||
(provide ck defck repeat-chunk)
|
||||
|
||||
(provide defck
|
||||
repeat-chunk
|
||||
chunk
|
||||
CHUNK)
|
||||
(define-syntax-rule (ck e) e)
|
||||
|
||||
(define-syntax (defck stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -35,4 +30,4 @@
|
|||
(with-syntax ([chk (datum->syntax #'self 'chunk)]
|
||||
[name2 (format-id #'name "~a-repeat" #'name)]
|
||||
[name-rep (format-id #'name "(~a)" stripped-name)])
|
||||
#'(name2 chk name-rep)))]))
|
||||
#'(name2 chk name-rep)))]))
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide chunks-toc-prefix)
|
||||
(define chunks-toc-prefix (make-parameter '()))
|
||||
|
|
@ -1,270 +0,0 @@
|
|||
#lang racket/base
|
||||
;; Forked from scribble-lib/scribble/lp/lang/common.rkt
|
||||
|
||||
(provide (except-out (all-from-out racket/base) #%module-begin)
|
||||
module-begin/plain
|
||||
module-begin/doc)
|
||||
|
||||
(require (for-syntax racket/base syntax/boundmap racket/list
|
||||
syntax/strip-context
|
||||
syntax/srcloc
|
||||
racket/struct
|
||||
syntax/srcloc
|
||||
debug-scopes/named-scopes/exptime))
|
||||
|
||||
(begin-for-syntax
|
||||
(define first-id #f)
|
||||
(define main-id #f)
|
||||
(define (mapping-get mapping id)
|
||||
(free-identifier-mapping-get mapping id (lambda () '())))
|
||||
;; maps a chunk identifier to its collected expressions
|
||||
(define chunks (make-free-identifier-mapping))
|
||||
;; maps a chunk identifier to all identifiers that are used to define it
|
||||
(define chunk-groups (make-free-identifier-mapping))
|
||||
(define (get-chunk id) (mapping-get chunks id))
|
||||
(define (add-to-chunk! id exprs)
|
||||
(unless first-id (set! first-id id))
|
||||
(when (eq? (syntax-e id) '<*>) (set! main-id id))
|
||||
(free-identifier-mapping-put!
|
||||
chunk-groups id
|
||||
(cons id (mapping-get chunk-groups id)))
|
||||
(free-identifier-mapping-put!
|
||||
chunks id
|
||||
`(,@(mapping-get chunks id) ,@exprs))))
|
||||
|
||||
(define-for-syntax (tangle orig-stx)
|
||||
(define chunk-mentions '())
|
||||
(unless first-id
|
||||
(raise-syntax-error 'scribble/lp "no chunks"))
|
||||
(define (restore nstx d) (datum->syntax orig-stx d nstx nstx))
|
||||
(define (shift nstx) (replace-context orig-stx nstx))
|
||||
(define body
|
||||
(let ([main-id (or main-id first-id)])
|
||||
(restore
|
||||
main-id
|
||||
(let loop ([block (get-chunk main-id)])
|
||||
(append-map
|
||||
(lambda (expr)
|
||||
(if (identifier? expr)
|
||||
(let ([subs (get-chunk expr)])
|
||||
(if (pair? subs)
|
||||
(begin (set! chunk-mentions (cons expr chunk-mentions))
|
||||
(loop subs))
|
||||
(list (shift expr))))
|
||||
(let ([subs (syntax->list expr)])
|
||||
(if subs
|
||||
(list (restore expr (loop subs)))
|
||||
(list (shift expr))))))
|
||||
block)))))
|
||||
(with-syntax ([body (strip-comments body)]
|
||||
;; Hopefully the scopes are correct enough on the whole body.
|
||||
[body0 (syntax-case body () [(a . _) #'a] [a #'a])]
|
||||
;; construct arrows manually
|
||||
[((b-use b-id) ...)
|
||||
(append-map (lambda (m)
|
||||
(map (lambda (u)
|
||||
(list (syntax-local-introduce m)
|
||||
(syntax-local-introduce u)))
|
||||
(mapping-get chunk-groups m)))
|
||||
chunk-mentions)])
|
||||
;; TODO: use disappeared-use and disappeared-binding.
|
||||
;; TODO: fix srcloc (already fixed?).
|
||||
;#`(#,(datum->syntax #'body0 'begin) (let ([b-id (void)]) b-use) ... body0 body ...)
|
||||
(syntax-property
|
||||
(syntax-property #`(#,(datum->syntax #'body0 'begin) . body)
|
||||
'disappeared-binding (syntax->list (syntax-local-introduce #'(b-id ...))))
|
||||
'disappeared-use (syntax->list (syntax-local-introduce #'(b-use ...))))))
|
||||
|
||||
(define-for-syntax (strip-comments body)
|
||||
(cond
|
||||
[(syntax? body)
|
||||
(define r (strip-comments (syntax-e body)))
|
||||
(if (eq? r (syntax-e body))
|
||||
body
|
||||
(datum->syntax body r body body))]
|
||||
[(pair? body)
|
||||
(define a (car body))
|
||||
(define ad (syntax-e a))
|
||||
(cond
|
||||
[(and (pair? ad)
|
||||
(memq (syntax-e (car ad))
|
||||
'(code:comment
|
||||
code:contract)))
|
||||
(strip-comments (cdr body))]
|
||||
[(eq? ad 'code:blank)
|
||||
(strip-comments (cdr body))]
|
||||
[(and (or (eq? ad 'code:hilite)
|
||||
(eq? ad 'code:quote))
|
||||
(let* ([d (cdr body)]
|
||||
[dd (if (syntax? d)
|
||||
(syntax-e d)
|
||||
d)])
|
||||
(and (pair? dd)
|
||||
(or (null? (cdr dd))
|
||||
(and (syntax? (cdr dd))
|
||||
(null? (syntax-e (cdr dd))))))))
|
||||
(define d (cdr body))
|
||||
(define r
|
||||
(strip-comments (car (if (syntax? d) (syntax-e d) d))))
|
||||
(if (eq? ad 'code:quote)
|
||||
`(quote ,r)
|
||||
r)]
|
||||
[(and (pair? ad)
|
||||
(eq? (syntax-e (car ad))
|
||||
'code:line))
|
||||
(if (null? (cdr body))
|
||||
(strip-comments (cdr ad))
|
||||
(strip-comments (append (cdr ad) (cdr body))))]
|
||||
[else (cons (strip-comments a)
|
||||
(strip-comments (cdr body)))])]
|
||||
[else body]))
|
||||
|
||||
(define-for-syntax (extract-chunks exprs)
|
||||
(let loop ([exprs exprs])
|
||||
(syntax-case exprs ()
|
||||
[() (void)]
|
||||
[(expr . exprs)
|
||||
(syntax-case #'expr (define-values quote-syntax)
|
||||
[(define-values (lifted) (quote-syntax (a-chunk id body ...)))
|
||||
(eq? (syntax-e #'a-chunk) 'a-chunk)
|
||||
(begin
|
||||
(add-to-chunk! #'id (syntax->list #'(body ...)))
|
||||
(loop #'exprs))]
|
||||
[_
|
||||
(loop #'exprs)])])))
|
||||
|
||||
(require (for-syntax racket/syntax
|
||||
syntax/parse))
|
||||
|
||||
(require (for-syntax racket/pretty
|
||||
"no-auto-require.rkt"))
|
||||
|
||||
(define-for-syntax (strip-source e)
|
||||
(cond [(syntax? e)
|
||||
(update-source-location
|
||||
(datum->syntax e (strip-source (syntax-e e)) e e)
|
||||
#:source #f)]
|
||||
[(pair? e) (cons (strip-source (car e)) (strip-source (cdr e)))]
|
||||
[(vector? e) (list->vector (strip-source (vector->list e)))]
|
||||
[(prefab-struct-key e)
|
||||
=> (λ (k) (make-prefab-struct k (strip-source (struct->list e))))]
|
||||
;; TODO: hash tables
|
||||
[else e]))
|
||||
|
||||
;; Many thanks to Alex Knauth and Matthew Flatt for finding out how to make
|
||||
;; module meta-languages.
|
||||
(define-syntax (continue stx)
|
||||
(syntax-case stx ()
|
||||
[(_self lang-module-begin maybe-chain₊ . body)
|
||||
(let ()
|
||||
(define ch₊ (syntax->list #'maybe-chain₊))
|
||||
(define expanded (local-expand
|
||||
(datum->syntax stx
|
||||
`(,#'lang-module-begin ,@ch₊ . ,#'body)
|
||||
stx
|
||||
stx)
|
||||
'module-begin
|
||||
(list)))
|
||||
(define meta-language-nesting
|
||||
;; Use a module-like scope here, instead of (make-syntax-introducer),
|
||||
;; otherwise DrRacket stops drawing some arrows (why?).
|
||||
(make-module-like-named-scope 'meta-language-nesting))
|
||||
(syntax-case expanded (#%plain-module-begin)
|
||||
[(#%plain-module-begin . expanded-body)
|
||||
#`(begin
|
||||
.
|
||||
#,(meta-language-nesting #'expanded-body))]))]))
|
||||
|
||||
(define-for-syntax ((make-module-begin submod?) stx)
|
||||
(syntax-parse stx
|
||||
;; #:no-require-lang is ignored, but still allowed for compatibility.
|
||||
;; TODO: semantically, the no-require-lang and no-auto-require should be
|
||||
;; before the lang, as they are arguments to hyper-literate itself.
|
||||
[(_modbeg {~or (lang:id
|
||||
{~optional (~and no-require-lang #:no-require-lang)}
|
||||
{~optional (~and no-auto-require #:no-auto-require)})
|
||||
({~optional (~and no-auto-require #:no-auto-require)}
|
||||
(lang:id
|
||||
. chain₊))}
|
||||
body0 . body)
|
||||
(let ()
|
||||
(define lang-sym (syntax-e #'lang))
|
||||
(let ([expanded
|
||||
(expand `(,#'module
|
||||
scribble-lp-tmp-name hyper-literate/private/lp
|
||||
(require hyper-literate/private/chunks-toc-prefix
|
||||
(for-syntax racket/base
|
||||
hyper-literate/private/no-auto-require))
|
||||
(begin-for-syntax (set-box! no-auto-require?
|
||||
,(if (attribute no-auto-require) #t #f))
|
||||
(set-box! preexpanding? #t))
|
||||
(define-syntax-rule (if-preexpanding a b) a)
|
||||
(define-syntax-rule (when-preexpanding . b) (begin . b))
|
||||
(define-syntax-rule (unless-preexpanding . b) (begin))
|
||||
,@(strip-context #'(body0 . body))))])
|
||||
(syntax-case expanded ()
|
||||
[(module name elang (mb . stuff))
|
||||
(let ()
|
||||
(extract-chunks #'stuff)
|
||||
(define/with-syntax tngl
|
||||
(tangle #'body0))
|
||||
(define/with-syntax mb9 (datum->syntax #f '#%module-begin))
|
||||
(define/with-syntax lang-modbeg (datum->syntax #'lang '#%module-begin))
|
||||
; See http://stackoverflow.com/questions/37867859/module-meta-language-in-racket :
|
||||
#;(define expanded-main-mod-stx
|
||||
(local-expand
|
||||
(syntax-local-introduce
|
||||
(datum->syntax #f `(,#'module ignored ,(datum->syntax #f lang-sym #'lang #'lang) (,#'mb9 ,(syntax-local-introduce #'tngl)))))
|
||||
'top-level
|
||||
(list)))
|
||||
;(syntax-case expanded-main-mod-stx ();(module #%plain-module-begin)
|
||||
;[(module _ lng11 (#%plain-module-begin . mod-body11))
|
||||
#`(#%plain-module-begin
|
||||
#,@(if submod?
|
||||
(list
|
||||
(with-syntax*
|
||||
([ctx #'body0 #;(syntax-local-introduce #'body0)]
|
||||
;; TODO: this is a hack, it would be nice to get
|
||||
;; the actual source location of the lang.
|
||||
[bd1 (update-source-location #'body0
|
||||
#:line #f
|
||||
#:column #f
|
||||
#:position 7
|
||||
#:span 14)]
|
||||
[lng (datum->syntax #'ctx 'scribble/doclang2 #'bd1 #'bd1)]
|
||||
[begn (datum->syntax #'ctx 'begin)])
|
||||
(strip-source
|
||||
#`(module* doc lng ;module doc scribble/doclang2
|
||||
#,@(syntax-local-introduce
|
||||
;; TODO: instead use:
|
||||
;; (begin-for-syntax (set! preexpanding #f))
|
||||
;; and make these identifiers exported by
|
||||
;; hyper-literate
|
||||
(strip-context
|
||||
#`((require hyper-literate/private/chunks-toc-prefix
|
||||
(for-syntax racket/base
|
||||
hyper-literate/private/no-auto-require))
|
||||
(begin-for-syntax
|
||||
(set-box! no-auto-require?
|
||||
#,(if (attribute no-auto-require) #t #f))
|
||||
(set-box! preexpanding? #f))
|
||||
(define-syntax-rule (if-preexpanding a b)
|
||||
b)
|
||||
(define-syntax-rule (when-preexpanding . b)
|
||||
(begin))
|
||||
(define-syntax-rule (unless-preexpanding . b)
|
||||
(begin . b))
|
||||
(require scribble-enhanced/with-manual
|
||||
hyper-literate))))
|
||||
(begn body0 . body)))))
|
||||
'())
|
||||
(require lang)
|
||||
(continue lang-modbeg
|
||||
#,(if (attribute chain₊)
|
||||
#'(chain₊)
|
||||
#'())
|
||||
tngl)) ;; TODO: put . tngl and remove the (begin _)
|
||||
)])))]))
|
||||
|
||||
(define-syntax module-begin/plain (make-module-begin #f))
|
||||
(define-syntax module-begin/doc (make-module-begin #t))
|
||||
301
private/lp.rkt
301
private/lp.rkt
|
|
@ -1,301 +0,0 @@
|
|||
#lang scheme/base
|
||||
;; Forked from scribble-lib/scribble/private/lp.rkt
|
||||
|
||||
(require scribble/decode
|
||||
scribble-enhanced/with-manual
|
||||
scribble/struct
|
||||
(for-syntax scheme/base
|
||||
syntax/boundmap
|
||||
syntax/parse
|
||||
racket/syntax
|
||||
racket/struct
|
||||
syntax/srcloc
|
||||
"../restore-comments.rkt"))
|
||||
|
||||
(begin-for-syntax
|
||||
;; maps chunk identifiers to a counter, so we can distinguish multiple uses
|
||||
;; of the same name
|
||||
(define chunk-numbers (make-free-identifier-mapping))
|
||||
(define (get-chunk-number id)
|
||||
(free-identifier-mapping-get chunk-numbers id (lambda () #f)))
|
||||
(define (inc-chunk-number id)
|
||||
(free-identifier-mapping-put!
|
||||
chunk-numbers id
|
||||
(+ 1 (free-identifier-mapping-get chunk-numbers id))))
|
||||
(define (init-chunk-number id)
|
||||
(free-identifier-mapping-put! chunk-numbers id 2))
|
||||
(define repeat-chunk-numbers (make-free-identifier-mapping))
|
||||
(define (init-repeat-chunk-number id)
|
||||
(free-identifier-mapping-put! repeat-chunk-numbers id 1))
|
||||
(define (get-repeat-chunk-number id)
|
||||
(free-identifier-mapping-get repeat-chunk-numbers
|
||||
id
|
||||
(lambda () 1)))
|
||||
(define (get+increment-repeat-chunk-number! id)
|
||||
(let ([current (free-identifier-mapping-get repeat-chunk-numbers
|
||||
id
|
||||
(lambda () 1))])
|
||||
;; note: due to multiple expansions, this does not increase exactly one at
|
||||
;; a time but instead it can skip numbers. Since this is not visible by
|
||||
;; the user, and just used as a token in the URL, it's okay as long as
|
||||
;; compiling the same file twice gives the same numbers (which is
|
||||
;; hopefully the case but hasn't been tested).
|
||||
(free-identifier-mapping-put! repeat-chunk-numbers id (add1 current))
|
||||
current)))
|
||||
|
||||
(require (for-syntax "no-auto-require.rkt")
|
||||
"chunks-toc-prefix.rkt")
|
||||
(define-for-syntax (make-chunk-code unsyntax?)
|
||||
(syntax-parser
|
||||
;; no need for more error checking, using chunk for the code will do that
|
||||
[(_ name:id expr ...)
|
||||
|
||||
;; Lift the code so that it is caught by `extract-chunks` in common.rkt
|
||||
;(syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...)))
|
||||
|
||||
;; Convoluted trick to allow unsyntax in chunks of code. The unsyntax
|
||||
;; escapes the chunk so that code can be injected at compile-time.
|
||||
;; The identifiers inside the escaped portion need to be available both
|
||||
;; for-syntax i.e. (for-meta 1) and (for-meta 0). This is because the
|
||||
;; underlying @racketblock expands the code at run-time, but the
|
||||
;; extract-chunks function in common.rkt looks at the expanded source
|
||||
;; code.
|
||||
;; For now, only #, i.e. unsyntax is supported, within @chunk.
|
||||
;; Later support for UNSYNTAX within @CHUNK may be added.
|
||||
(define expand-unsyntax
|
||||
(if unsyntax?
|
||||
;; New hack:
|
||||
#'((define-syntax (macro-to-expand-unsyntax _)
|
||||
(define a #'here)
|
||||
(define b (syntax-local-identifier-as-binding
|
||||
(syntax-local-introduce #'here)))
|
||||
(define intr (make-syntax-delta-introducer b a))
|
||||
(syntax-local-lift-expression
|
||||
(intr #'(quote-syntax (a-chunk ((... ...) name)
|
||||
((... ...) expr) ...))
|
||||
'flip))
|
||||
#'(void))
|
||||
(macro-to-expand-unsyntax))
|
||||
;; Default (old) behaviour, does not support escaping via #,
|
||||
(begin (syntax-local-lift-expression
|
||||
#'(quote-syntax (a-chunk name expr ...)))
|
||||
#f)))
|
||||
|
||||
(with-syntax
|
||||
;; Extract require forms
|
||||
([((for-label-mod ...) ...)
|
||||
(if (unbox no-auto-require?)
|
||||
#'()
|
||||
(map (lambda (expr)
|
||||
(syntax-case expr (require)
|
||||
[(require mod ...)
|
||||
(let loop ([mods (syntax->list
|
||||
#'(mod ...))])
|
||||
(cond
|
||||
[(null? mods) null]
|
||||
[else
|
||||
(syntax-case (car mods)
|
||||
(for-syntax quote submod)
|
||||
[(submod ".." . _)
|
||||
(loop (cdr mods))]
|
||||
[(submod "." . _)
|
||||
(loop (cdr mods))]
|
||||
[(quote x)
|
||||
(loop (cdr mods))]
|
||||
[(for-syntax x ...)
|
||||
(append (loop (syntax->list
|
||||
#'(x ...)))
|
||||
(loop (cdr mods)))]
|
||||
[x
|
||||
(cons #'x (loop (cdr mods)))])]))]
|
||||
[else null]))
|
||||
(syntax->list #'(expr ...))))])
|
||||
#`(begin
|
||||
#,@(if expand-unsyntax expand-unsyntax #'())
|
||||
#,@(if (null? (syntax-e #'(for-label-mod ... ...)))
|
||||
#'()
|
||||
#'((require (for-label for-label-mod ... ...))))))]))
|
||||
|
||||
(define-for-syntax (strip-source e)
|
||||
(cond [(syntax? e)
|
||||
(update-source-location
|
||||
(datum->syntax e (strip-source (syntax-e e)) e e)
|
||||
#:source #f)]
|
||||
[(pair? e) (cons (strip-source (car e)) (strip-source (cdr e)))]
|
||||
[(vector? e) (list->vector (strip-source (vector->list e)))]
|
||||
[(prefab-struct-key e)
|
||||
=> (λ (k) (make-prefab-struct k (strip-source (struct->list e))))]
|
||||
;; TODO: hash tables
|
||||
[else e]))
|
||||
|
||||
(define-for-syntax (prettify-chunk-name str)
|
||||
(regexp-replace #px"^<(.*)>$" str "«\\1»"))
|
||||
|
||||
(define-for-syntax ((make-chunk-display racketblock unsyntax-id) stx)
|
||||
(syntax-parse stx
|
||||
;; no need for more error checking, using chunk for the code will do that
|
||||
[(_ {~optional {~seq #:button button}}
|
||||
(original-before-expr ...)
|
||||
original-name:id
|
||||
name:id
|
||||
stxn:number
|
||||
expr ...)
|
||||
(define n (syntax-e #'stxn))
|
||||
(define original-name:n (syntax-local-introduce
|
||||
(format-id #'original-name
|
||||
"~a:~a"
|
||||
#'original-name
|
||||
n)))
|
||||
(define n-repeat (get+increment-repeat-chunk-number!
|
||||
original-name:n))
|
||||
(define str (symbol->string (syntax-e #'name)))
|
||||
(define str-display (prettify-chunk-name str))
|
||||
(define/with-syntax tag (format "chunk:~a:~a:~a" str n n-repeat))
|
||||
(define/with-syntax (rest ...)
|
||||
;; if the would-be-next number for this chunk name is "2", then there is
|
||||
;; only one chunk, whose number is "1". Otherwise, if the number is 3 or
|
||||
;; more, it means that the chunk with number "2" exists, so we should
|
||||
;; display the subscript numbers.
|
||||
(if (let ([c (get-chunk-number #'original-name)])
|
||||
(and c (> c 2)))
|
||||
#`((subscript #,(format "~a" n)))
|
||||
#'()))
|
||||
;; Restore comments which have been read by the modified comment-reader
|
||||
;; and stashed away by read-syntax in "../lang/meta-first-line.rkt"
|
||||
(define/with-syntax (_ . expr*+comments)
|
||||
(restore-#%comment #'(original-before-expr ... expr ...)
|
||||
#:replace-with
|
||||
(λ (stx)
|
||||
(syntax-parse stx
|
||||
#:datum-literals (#%comment)
|
||||
[({~and #%comment com} . rest)
|
||||
#:with c-c (datum->syntax #'com 'code:comment #'com #'com)
|
||||
(datum->syntax stx `(,#'c-c (,unsyntax-id . ,#'rest)) stx stx)]
|
||||
[other
|
||||
#'other]))
|
||||
#:scope #'original-name))
|
||||
;; The (list) here could be important, to avoid the code being
|
||||
;; executed multiple times in weird ways, when pre-expanding.
|
||||
#`(list
|
||||
(make-splice
|
||||
(list (make-toc-element
|
||||
#f
|
||||
(list (elemtag '(prefixable tag)
|
||||
(bold (italic (elemref '(prefixable tag)
|
||||
#:underline? #f
|
||||
#,str-display rest ...))
|
||||
" ::="))
|
||||
#,@(if (attribute button) #'{button} #'{}))
|
||||
(list (smaller
|
||||
(make-link-element "plainlink"
|
||||
(decode-content
|
||||
(list #,str-display rest ...))
|
||||
`(elem (prefixable
|
||||
,@(chunks-toc-prefix)
|
||||
tag))))))
|
||||
(#,racketblock
|
||||
. #,(strip-source #'expr*+comments)))))]))
|
||||
|
||||
(define-for-syntax (make-chunk chunk-code chunk-display)
|
||||
(syntax-parser
|
||||
;; no need for more error checking, using chunk for the code will do that
|
||||
[(_ {~optional {~seq #:save-as save-as:id}}
|
||||
{~optional {~and #:display-only display-only}}
|
||||
{~optional {~seq #:button button}}
|
||||
{~and name:id original-before-expr}
|
||||
expr ...)
|
||||
#:with (btn ...) (if (attribute button) #'{#:button button} #'{})
|
||||
(define n (get-chunk-number (syntax-local-introduce #'name)))
|
||||
(define/with-syntax name:n (format-id #'name "~a:~a" #'name (or n 1)))
|
||||
|
||||
(define/with-syntax stripped-name
|
||||
(regexp-replace #px"^<(.*)>$"
|
||||
(symbol->string (syntax-e #'name))
|
||||
"\\1"))
|
||||
|
||||
(when n
|
||||
(inc-chunk-number (syntax-local-introduce #'name)))
|
||||
|
||||
(define/with-syntax stx-n (or n 1))
|
||||
(define/with-syntax stx-chunk-code chunk-code)
|
||||
(define/with-syntax stx-chunk-display chunk-display)
|
||||
|
||||
#`(begin
|
||||
#,@(if (attribute display-only)
|
||||
#'{}
|
||||
#`{(stx-chunk-code name
|
||||
. #,(if preexpanding?
|
||||
#'(expr ...)
|
||||
#'(expr ...)
|
||||
#;(strip-source #'(expr ...))))})
|
||||
#,@(if n
|
||||
#'()
|
||||
#'((define-syntax name (make-element-id-transformer
|
||||
(lambda (stx) #'(chunkref name))))
|
||||
(define-syntax dummy (init-chunk-number #'name))))
|
||||
#,(if (attribute save-as)
|
||||
#`(begin
|
||||
#,#'(define-syntax (do-for-syntax _)
|
||||
(init-repeat-chunk-number (quote-syntax name:n))
|
||||
#'(void))
|
||||
(do-for-syntax)
|
||||
(define-syntax (save-as s)
|
||||
(syntax-case s ()
|
||||
[(_)
|
||||
(let* ([local-name (syntax-local-introduce
|
||||
(quote-syntax name))]
|
||||
[local-name:n (syntax-local-introduce
|
||||
(quote-syntax name:n))]
|
||||
[n-repeat (get-repeat-chunk-number
|
||||
local-name:n)])
|
||||
(with-syntax
|
||||
([name-maybe-paren (if (> n-repeat 1)
|
||||
(format-id local-name
|
||||
"(~a)"
|
||||
stripped-name)
|
||||
local-name)])
|
||||
#'(save-as name-maybe-paren)))]
|
||||
[(_ newname)
|
||||
(with-syntax ([local-name
|
||||
(syntax-local-introduce
|
||||
(quote-syntax name))]
|
||||
[(local-expr (... ...))
|
||||
(syntax-local-introduce
|
||||
(quote-syntax #,(strip-source #'(expr ...))))])
|
||||
#`(stx-chunk-display
|
||||
btn ...
|
||||
(original-before-expr)
|
||||
local-name
|
||||
newname
|
||||
stx-n
|
||||
local-expr (... ...)))])))
|
||||
;; The (list) here could be important, to avoid the code being
|
||||
;; executed multiple times in weird ways, when pre-expanding.
|
||||
#`(list (stx-chunk-display btn ...
|
||||
(original-before-expr)
|
||||
name
|
||||
name
|
||||
stx-n
|
||||
. #,(strip-source #'(expr ...))))))]))
|
||||
|
||||
(define-syntax chunk-code (make-chunk-code #t))
|
||||
(define-syntax CHUNK-code (make-chunk-code #f))
|
||||
(define-syntax chunk-display (make-chunk-display #'racketblock #'unsyntax))
|
||||
(define-syntax CHUNK-display (make-chunk-display #'RACKETBLOCK #'UNSYNTAX))
|
||||
(define-syntax chunk (make-chunk #'chunk-code #'chunk-display))
|
||||
(define-syntax CHUNK (make-chunk #'CHUNK-code #'CHUNK-display))
|
||||
|
||||
(define-syntax (chunkref stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
(identifier? #'id)
|
||||
(with-syntax ([tag (format "chunk:~a:1:1" (syntax-e #'id))]
|
||||
[pretty (prettify-chunk-name (format "~a" (syntax-e #'id)))])
|
||||
#'(elemref '(prefixable tag) #:underline? #f pretty))]))
|
||||
|
||||
|
||||
(provide (all-from-out scheme/base
|
||||
scribble-enhanced/with-manual)
|
||||
chunk
|
||||
CHUNK
|
||||
chunks-toc-prefix)
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide no-auto-require?)
|
||||
(define no-auto-require? (box #f))
|
||||
(provide preexpanding?)
|
||||
(define preexpanding? (box #f))
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#lang racket
|
||||
(require "comments/restore-comments.rkt")
|
||||
(provide restore-#%comment)
|
||||
|
|
@ -1,120 +0,0 @@
|
|||
#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))]
|
||||
|
|
@ -1,275 +1,10 @@
|
|||
#lang scribble/manual
|
||||
@require[racket/require
|
||||
@for-label[hyper-literate
|
||||
racket/base
|
||||
(subtract-in scribble/manual hyper-literate)
|
||||
racket/contract]]
|
||||
@require[@for-label[hyper-literate
|
||||
racket/base]]
|
||||
|
||||
@title{Hyper-literate programming}
|
||||
@author[@author+email["Suzanne Soy" "racket@suzanne.soy"]]
|
||||
@title{hyper-literate}
|
||||
@author{Georges Dupéron}
|
||||
|
||||
@(require scribble/manual
|
||||
scribble/core
|
||||
scribble/decode
|
||||
scribble/racket
|
||||
(only-in scribble/racket value-link-color))
|
||||
@defmodule[hyper-literate]
|
||||
|
||||
@defmodulelang[hyper-literate]
|
||||
|
||||
The @racketmodname[hyper-literate] metalanguage extends the
|
||||
features of @racketmodname[scribble/lp2], with the goal of
|
||||
providing a more modern view on literate programming. It can
|
||||
be parameterized with the language used in the chunks (so
|
||||
that it is possible to directly write
|
||||
@racketmodname[typed/racket] programs with
|
||||
@racketmodname[hyper-literate], for example).
|
||||
|
||||
On the first line, which begins with @tt{@litchar{#lang}
|
||||
@racketmodname[hyper-literate]}, the language recognises the following
|
||||
options:
|
||||
|
||||
@(require scribble/core
|
||||
(only-in scribble/private/manual-vars boxed-style)
|
||||
scribble/private/manual-utils)
|
||||
@(make-table
|
||||
boxed-style
|
||||
(list
|
||||
(list
|
||||
@paragraph[(style #f '())]{
|
||||
@tt{@litchar{#lang} @racketmodname[hyper-literate] @racket[_lang]
|
||||
@racket[_maybe-no-req] @racket[_maybe-no-auto]}})
|
||||
flow-empty-line
|
||||
(list
|
||||
@racketgrammar*[
|
||||
(maybe-no-req (code:line)
|
||||
(code:line #:no-require-lang))
|
||||
(maybe-no-auto (code:line)
|
||||
(code:line #:no-auto-require))])))
|
||||
|
||||
where @racket[_lang] is a module name which can be used as
|
||||
a @litchar{#lang}, for example @racketmodname[typed/racket]
|
||||
or @racketmodname[racket/base].
|
||||
|
||||
The current implementation of hyper-literate needs to inject
|
||||
a @racket[(require _lang)] in the expanded module, in order
|
||||
to have the arrows properly working in DrRacket for
|
||||
"built-in" identifiers which are provided by the
|
||||
@racket[_lang] itself. The @racket[require] statement is
|
||||
injected after the whole ``code'' module has been expanded.
|
||||
It is worth noting that an extra scope is added to the expanded
|
||||
body of the module, in order to make any @racket[require] form
|
||||
within more specific than the @racket[(require _lang)].
|
||||
|
||||
The current implementation of @racketmodname[scribble/lp2],
|
||||
on which @racketmodname[hyper-literate] relies (with a few
|
||||
changes), extracts the @racket[require] statements from
|
||||
chunks of code, and passes them to
|
||||
@racket[(require (for-label …))]. The goal is to have
|
||||
identifiers from required modules automatically highlighted
|
||||
and hyperlinked to their documentation. However, all
|
||||
meta-levels are smashed into the @racket[#f], i.e.
|
||||
@racket[for-label] meta-level. As a consequence, conflicts
|
||||
can arise at the @racket[for-label] meta-level between two
|
||||
modules, even if these two modules were originally required
|
||||
at distinct meta-levels in the source program. It is
|
||||
possible in this case to disable the feature using
|
||||
@racket[#:no-auto-require], and to manually call
|
||||
@racket[(require (for-label …))] and handle conflicting
|
||||
identifiers in a more fine-grained way.
|
||||
|
||||
@deprecated[#:what @racket[#:no-require-lang] ""]{
|
||||
|
||||
The @racket[#:no-require-lang] is deprecated starting from version 0.1, and
|
||||
is not needed anymore. It is still accepted for backwards compatibility. Note
|
||||
that version 0.1 of this library requires a fairly recent Racket version to
|
||||
work properly (it needs v.6.7.0.4 with the commit
|
||||
@tt{8a7852ebbfeb85a8f860700ba5ae481ed7aa9b41}, or v.6.7.0.5 or later). By
|
||||
default, raco will install v0.0 of hyper-literate on older Racket versions.
|
||||
|
||||
The extra @racket[require] statement injected by
|
||||
@racketmodname[hyper-literate] could in previous versions conflict with
|
||||
user-written @racket[require] statements. These @racket[require] statements
|
||||
can shadow some built-ins, and this case would yield conflicts. The
|
||||
@racket[#:no-require-lang] option disables that behaviour in versions < 0.1,
|
||||
and has the only drawback that built-ins of the @racket[_lang] language do not
|
||||
have an arrow in DrRacket (but they still should be highlighted with -a
|
||||
turquoise background when hovered over with the mouse).}
|
||||
|
||||
@section{What is hyper-literate programming?}
|
||||
|
||||
Hyper-literate programming is to literate programming
|
||||
exactly what hypertext documents are to regular books and
|
||||
texts. Literate programming is about telling other
|
||||
programmers how the program works (instead of just telling
|
||||
the compiler what it does). Telling this story can be done
|
||||
using non-linear, hyperlinked documents.
|
||||
|
||||
For now these utilities only help with manipulating literate
|
||||
programming chunks (e.g. repeating the same chunk in several
|
||||
places in the output document, but keeping a single copy in
|
||||
the source code).
|
||||
|
||||
Ultimately, the reading experience should be closer to
|
||||
viewing an interactive presentation, focusing on the parts
|
||||
of the program that are of interest to you: expand on-screen
|
||||
the chunks you are curious about, run some tests and see
|
||||
their result, etc.
|
||||
|
||||
@itemlist[
|
||||
@item{Imagine something like
|
||||
@hyperlink["http://www.andrewbragdon.com/codebubbles_site.asp"]{
|
||||
code bubbles}, but with explanatory text coming along
|
||||
with the source code.}
|
||||
@item{Imagine something like
|
||||
@hyperlink["http://inform7.com/"]{Inform}, but focused on
|
||||
exploring a program instead of exploring an imaginary
|
||||
world — after all, a program is some kind of imaginary
|
||||
world.}]
|
||||
|
||||
@section{Chunks of code}
|
||||
|
||||
@; @racket[chunk] does not work for these, probably due to the use of either:
|
||||
@; @title[#:tag "lp" …]{Literate Programming}
|
||||
@; or:
|
||||
@; @defmodulelang[scribble/lp2 #:use-sources (scribble/lp)]{…}
|
||||
@; in scribble-doc/scribblings/scribble/lp.scrbl
|
||||
@; See scribble bug #51 https://github.com/racket/scribble/issues/51
|
||||
@(define scribble-chunk
|
||||
(element symbol-color
|
||||
(make-link-element value-link-color
|
||||
(decode-content (list "chunk"))
|
||||
'(form ((lib "scribble/lp.rkt") chunk)))))
|
||||
@(define scribble-CHUNK
|
||||
(element symbol-color
|
||||
(make-link-element value-link-color
|
||||
(decode-content (list "CHUNK"))
|
||||
'(form ((lib "scribble/lp.rkt") CHUNK)))))
|
||||
|
||||
@;{
|
||||
@(module scribble-doc-links racket/base
|
||||
(require scribble/manual
|
||||
(for-label scribble/lp2
|
||||
scribble/private/lp))
|
||||
(provide (all-defined-out))
|
||||
(define scribble-chunk @racket[chunk])
|
||||
(define scribble-CHUNK @racket[CHUNK]))
|
||||
@(require 'scribble-doc-links)
|
||||
}
|
||||
|
||||
@defform[(chunk <name> content ...)]{
|
||||
Same as @scribble-chunk from @racketmodname[scribble/lp2],
|
||||
with a few tweaks and bug fixes.}
|
||||
|
||||
@defform[(CHUNK <name> content ...)]{
|
||||
Same as @scribble-CHUNK from @racketmodname[scribble/lp2],
|
||||
with a few tweaks and bug fixes.}
|
||||
|
||||
@section{Memorizing and repeating chunks}
|
||||
|
||||
@defform[(defck <name> content ...)]{
|
||||
Like @racket[chunk] from @racketmodname[scribble/lp2], but
|
||||
remembers the chunk so that it can be re-displayed later
|
||||
using @racket[repeat-chunk].}
|
||||
|
||||
@defform[(repeat-chunk <name>)]{
|
||||
Shows again a @racket[chunk] of code previously remembered
|
||||
with @racket[defck]. If the @racket[<name>] starts and
|
||||
ends with angle brackets, they are replaced by parentheses
|
||||
to hint that this is not the first occurrence of this
|
||||
chunk, so that the name becomes @racket[|(name)|]}
|
||||
|
||||
@section{Order of expansion of the program}
|
||||
|
||||
The file is expanded a first time, in order to identify and
|
||||
aggregate the chunks of code (declared with @racket[chunk]).
|
||||
Then, the top-level module of the file is constructed using
|
||||
these chunks, and a @racket[doc] submodule is added, which
|
||||
contains all the surrounding text. The chunks are typeset
|
||||
where they appear using @racket[racketblock].
|
||||
|
||||
The @racket[doc] submodule is declared using
|
||||
@racket[module*], so that it can use
|
||||
@racket[(require (submod ".."))] to use functions declared
|
||||
in the chunks. For example, it should be possible to
|
||||
dynamically compute the result of a function, and to insert
|
||||
it into the document, so that the value displayed always
|
||||
matches the implementation.
|
||||
|
||||
When the file is expanded for the first time, however, the
|
||||
@racket[(submod "..")] does not exist yet, and cannot be
|
||||
required. This is the case because the first expansion is
|
||||
performed precisely to extract the chunks and inject them in
|
||||
that module.
|
||||
|
||||
To solve this problem, the following macros behave
|
||||
differently depending on whether the code is being expanded
|
||||
for the first time or not (in which case the
|
||||
@racket[(submod "..")] module can be used).
|
||||
|
||||
@defform[(if-preexpanding a b)]{
|
||||
Expands to @racket[a] if the code is being pre-expanded,
|
||||
and expands to @racket[b] if the @racket[(submod "..")]
|
||||
module can be used.}
|
||||
|
||||
@defform[(when-preexpanding . body)]{
|
||||
Expands to @racket[(begin . body)] if the code is being
|
||||
pre-expanded, and expands to @racket[(begin)] otherwise.}
|
||||
|
||||
@defform[(unless-preexpanding . body)]{
|
||||
Expands to @racket[(begin . body)] if the @racket[(submod "..")]
|
||||
module can be used, and expands to @racket[(begin)] otherwise.}
|
||||
|
||||
@section{A note on literate programs as subsections of another document}
|
||||
|
||||
To use @racket[include-section] on hyper-literate programs, a couple of
|
||||
workarounds are required to avoid issues with duplicate tags for
|
||||
identically-named chunks (like @racket[<*>], which is likely to always be
|
||||
present).
|
||||
|
||||
@defparam[chunks-toc-prefix prefix-list (listof string?)]{
|
||||
We give an example for two files which are part of a hypothetical
|
||||
@elem[#:style 'tt "pkg"] package:
|
||||
|
||||
@itemlist[
|
||||
@item{The main scribble file @filepath{main.scrbl} in the
|
||||
@filepath{scribblings} sub-directory includes the hyper-literate file
|
||||
@filepath{program.hl.rkt} located in the package's root directory, one
|
||||
directory level above:
|
||||
|
||||
@codeblock[#:keep-lang-line? #t
|
||||
"#lang scribble/manual\n"
|
||||
"@title{Main document title}\n"
|
||||
"@include-section{../program.hl.rkt}\n"
|
||||
"@; could include other hyper-literat programs here\n"]}
|
||||
@item{To avoid issues with duplicate tag names, it is necessary to use the
|
||||
@racket[#:tag-prefix] option on the hyper literate program's @racket[title].
|
||||
Unfortunately, this breaks links to chunks in the table of contents, because
|
||||
scribble does not automatically add the correct prefix to them. To ensure
|
||||
that the links correctly work in the table of contents, it is necessary to
|
||||
tell hyper-literate what is the chain of document includes. The whole
|
||||
@filepath{program.hl.rkt} file will be:
|
||||
|
||||
@codeblock[#:keep-lang-line? #t
|
||||
"#lang hyper-literate racket/base\n"
|
||||
"@title[#:tag-prefix '(lib \"pkg/program.hl.rkt\")]{Program title}\n"
|
||||
"@(chunks-toc-prefix '(\"(lib pkg/scribblings/main.scrbl)\"\n"
|
||||
" \"(lib pkg/program.hl.rkt)\"))\n"
|
||||
"@chunk[<*>\n"
|
||||
" 'program-code-here]\n"]
|
||||
|
||||
Note that the argument for the @racket[chunks-toc-prefix] parameter is a list
|
||||
of string, and the strings are representations of module paths. The
|
||||
occurrences of @racket[lib] above are not symbols, they are just part of the
|
||||
string. Compare this with the following, which would be incorrect:
|
||||
|
||||
@codeblock[#:keep-lang-line? #t
|
||||
"#lang hyper-literate racket/base\n"
|
||||
"@title[#:tag-prefix '(lib \"pkg/program.hl.rkt\")]{Program title}\n"
|
||||
"@; This is incorrect:\n"
|
||||
"@(chunks-toc-prefix '((lib \"pkg/scribblings/main.scrbl\")\n"
|
||||
" (lib \"pkg/program.hl.rkt\")))\n"
|
||||
"@chunk[<*>\n"
|
||||
" 'program-code-here]\n"]}]}
|
||||
|
||||
@include-section[(submod (lib "hyper-literate/scribblings/diff1-example.hl.rkt")
|
||||
doc)]
|
||||
Package Description Here
|
||||
|
|
|
|||
142
spoiler1.rkt
142
spoiler1.rkt
|
|
@ -1,142 +0,0 @@
|
|||
#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)))]))]))
|
||||
|
|
@ -1,69 +0,0 @@
|
|||
#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)]))
|
||||
|
|
@ -1,52 +0,0 @@
|
|||
#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)]))
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
#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)]))
|
||||
|
|
@ -1,25 +0,0 @@
|
|||
#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)]))
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
#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))
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
#lang hyper-literate racket/base
|
||||
|
||||
@chunk[<values>
|
||||
'A]
|
||||
|
||||
@chunk[<values>
|
||||
'B]
|
||||
|
||||
@CHUNK[<values>
|
||||
'C]
|
||||
|
||||
@CHUNK[<values>
|
||||
'D]
|
||||
|
||||
@chunk[<values>
|
||||
'E]
|
||||
|
||||
@chunk[<values>
|
||||
'F]
|
||||
|
||||
@CHUNK[<values>
|
||||
'G]
|
||||
|
||||
@CHUNK[<values>
|
||||
'H]
|
||||
|
||||
@chunk[<*>
|
||||
(require rackunit)
|
||||
(check-equal? (list <values>)
|
||||
'(A B C D E F G H))]
|
||||
|
|
@ -1,12 +1,9 @@
|
|||
#lang hyper-literate typed/racket/base
|
||||
#lang hyper-literate/typed typed/racket/base
|
||||
|
||||
@(require (for-label typed/racket/base
|
||||
rackunit))
|
||||
@(require (for-label typed/racket/base))
|
||||
|
||||
@title{Title}
|
||||
|
||||
@section{if-preexpanding}
|
||||
|
||||
Hello world.
|
||||
|
||||
@(if-preexpanding
|
||||
|
|
@ -16,8 +13,6 @@ Hello world.
|
|||
@(unless-preexpanding
|
||||
(symbol->string ee))
|
||||
|
||||
@section{Submodules}
|
||||
|
||||
Submodules work:
|
||||
|
||||
@chunk[<submod>
|
||||
|
|
@ -50,47 +45,16 @@ And so does @racket[(require (submod ".." …))]:
|
|||
(require (submod ".."))
|
||||
(require (submod ".." ms2))]
|
||||
|
||||
Test with multiple subforms inside require, and coverage for
|
||||
@racket[for-syntax]:
|
||||
|
||||
@chunk[<req-multi>
|
||||
(require (for-syntax syntax/stx
|
||||
racket/syntax)
|
||||
racket/bool)]
|
||||
|
||||
@section{Avoiding for-label}
|
||||
|
||||
Wrap the @racket[(require (for-syntax racket/base))] in a
|
||||
@racket[(begin …)] so that it gets ignored, otherwise
|
||||
scribble complains some identifiers are loaded twice
|
||||
for-label, since some identifiers have already been introduced
|
||||
at meta-level 0 by @racketmodname[typed/racket].
|
||||
|
||||
@chunk[<require-not-label>
|
||||
(begin (require (for-syntax racket/base))
|
||||
(require typed/rackunit))]
|
||||
|
||||
@CHUNK[<with-unsyntax>
|
||||
(let* ([b 1234]
|
||||
[e (syntax-e #`#,b)])
|
||||
(check-equal? e 1234))]
|
||||
|
||||
@section{Main chunk}
|
||||
|
||||
@chunk[<*>
|
||||
<require-not-label>
|
||||
(begin
|
||||
;; Wrap the require in a `(begin …)` so that it gets ignored,
|
||||
;; otherwise scribble complains some identifiers are loaded twice
|
||||
;; for-label.
|
||||
(require (for-syntax)))
|
||||
(require typed/rackunit)
|
||||
<submod>
|
||||
<req-multi>
|
||||
<submod*>
|
||||
(check-true (false? #f));; Should be hyperlinked to the main docs
|
||||
(begin-for-syntax
|
||||
(define/with-syntax ;; Should be hyperlinked to the main docs
|
||||
x
|
||||
(stx-car ;; Should be hyperlinked to the main docs
|
||||
#'(a . b))))
|
||||
(check-equal? (+ x x) 2)
|
||||
(check-equal? (+ x y) 0)
|
||||
<with-unsyntax>
|
||||
;; Gives an error because typed/racket/base is used on the #lang line:
|
||||
;curry
|
||||
(check-equal? ((make-predicate One) 1) #t)
|
||||
|
|
|
|||
|
|
@ -1,23 +0,0 @@
|
|||
#lang hyper-literate typed/racket/base
|
||||
|
||||
@(require (for-label typed/racket/base
|
||||
rackunit))
|
||||
|
||||
@title{Title}
|
||||
|
||||
Hello world.
|
||||
|
||||
@chunk[<*>
|
||||
(begin
|
||||
; Wrapped with (begin …) to avoid the implicit require for-label.
|
||||
(require typed/rackunit))
|
||||
|
||||
;; Would give an error as typed/racket/base is used on the #lang line:
|
||||
;curry
|
||||
|
||||
(check-equal? ((make-predicate One) 1) #t)
|
||||
|
||||
(define (f [x : 'e123]) x)
|
||||
|
||||
(define ee (ann (f 'e123) 'e123))
|
||||
(provide ee)]
|
||||
174
typed/lang/common.rkt
Normal file
174
typed/lang/common.rkt
Normal file
|
|
@ -0,0 +1,174 @@
|
|||
#lang racket/base
|
||||
;; Forked from scribble-lib/scribble/lp/lang/common.rkt
|
||||
|
||||
(provide (except-out (all-from-out racket/base) #%module-begin)
|
||||
module-begin/plain
|
||||
module-begin/doc)
|
||||
|
||||
(require (for-syntax racket/base syntax/boundmap racket/list
|
||||
syntax/strip-context))
|
||||
|
||||
(begin-for-syntax
|
||||
(define first-id #f)
|
||||
(define main-id #f)
|
||||
(define (mapping-get mapping id)
|
||||
(free-identifier-mapping-get mapping id (lambda () '())))
|
||||
;; maps a chunk identifier to its collected expressions
|
||||
(define chunks (make-free-identifier-mapping))
|
||||
;; maps a chunk identifier to all identifiers that are used to define it
|
||||
(define chunk-groups (make-free-identifier-mapping))
|
||||
(define (get-chunk id) (mapping-get chunks id))
|
||||
(define (add-to-chunk! id exprs)
|
||||
(unless first-id (set! first-id id))
|
||||
(when (eq? (syntax-e id) '<*>) (set! main-id id))
|
||||
(free-identifier-mapping-put!
|
||||
chunk-groups id
|
||||
(cons id (mapping-get chunk-groups id)))
|
||||
(free-identifier-mapping-put!
|
||||
chunks id
|
||||
`(,@(mapping-get chunks id) ,@exprs))))
|
||||
|
||||
(define-for-syntax (tangle orig-stx)
|
||||
(define chunk-mentions '())
|
||||
(unless first-id
|
||||
(raise-syntax-error 'scribble/lp "no chunks"))
|
||||
;(define orig-stx (syntax-case stx () [(_ orig) #'orig]))
|
||||
(define (restore nstx d) (datum->syntax orig-stx d nstx nstx))
|
||||
(define (shift nstx) (replace-context orig-stx nstx))
|
||||
(define body
|
||||
(let ([main-id (or main-id first-id)])
|
||||
(restore
|
||||
main-id
|
||||
(let loop ([block (get-chunk main-id)])
|
||||
(append-map
|
||||
(lambda (expr)
|
||||
(if (identifier? expr)
|
||||
(let ([subs (get-chunk expr)])
|
||||
(if (pair? subs)
|
||||
(begin (set! chunk-mentions (cons expr chunk-mentions))
|
||||
(loop subs))
|
||||
(list (shift expr))))
|
||||
(let ([subs (syntax->list expr)])
|
||||
(if subs
|
||||
(list (restore expr (loop subs)))
|
||||
(list (shift expr))))))
|
||||
block)))))
|
||||
(with-syntax ([(body ...) (strip-comments body)]
|
||||
;; construct arrows manually
|
||||
[((b-use b-id) ...)
|
||||
(append-map (lambda (m)
|
||||
(map (lambda (u)
|
||||
(list (syntax-local-introduce m)
|
||||
(syntax-local-introduce u)))
|
||||
(mapping-get chunk-groups m)))
|
||||
chunk-mentions)])
|
||||
;(displayln (dynamic-require 'tyyyyyyyyyyyped/racket '#%module-begin))
|
||||
(replace-context #'#%module-begin;modbeg-ty
|
||||
#`(begin body ... (let ([b-id (void)]) b-use) ...))))
|
||||
|
||||
(define-for-syntax (strip-comments body)
|
||||
(cond
|
||||
[(syntax? body)
|
||||
(define r (strip-comments (syntax-e body)))
|
||||
(if (eq? r (syntax-e body))
|
||||
body
|
||||
(datum->syntax body r body body))]
|
||||
[(pair? body)
|
||||
(define a (car body))
|
||||
(define ad (syntax-e a))
|
||||
(cond
|
||||
[(and (pair? ad)
|
||||
(memq (syntax-e (car ad))
|
||||
'(code:comment
|
||||
code:contract)))
|
||||
(strip-comments (cdr body))]
|
||||
[(eq? ad 'code:blank)
|
||||
(strip-comments (cdr body))]
|
||||
[(and (or (eq? ad 'code:hilite)
|
||||
(eq? ad 'code:quote))
|
||||
(let* ([d (cdr body)]
|
||||
[dd (if (syntax? d)
|
||||
(syntax-e d)
|
||||
d)])
|
||||
(and (pair? dd)
|
||||
(or (null? (cdr dd))
|
||||
(and (syntax? (cdr dd))
|
||||
(null? (syntax-e (cdr dd))))))))
|
||||
(define d (cdr body))
|
||||
(define r
|
||||
(strip-comments (car (if (syntax? d) (syntax-e d) d))))
|
||||
(if (eq? ad 'code:quote)
|
||||
`(quote ,r)
|
||||
r)]
|
||||
[(and (pair? ad)
|
||||
(eq? (syntax-e (car ad))
|
||||
'code:line))
|
||||
(strip-comments (append (cdr ad) (cdr body)))]
|
||||
[else (cons (strip-comments a)
|
||||
(strip-comments (cdr body)))])]
|
||||
[else body]))
|
||||
|
||||
(define-for-syntax (extract-chunks exprs)
|
||||
(let loop ([exprs exprs])
|
||||
(syntax-case exprs ()
|
||||
[() (void)]
|
||||
[(expr . exprs)
|
||||
(syntax-case #'expr (define-syntax quote-syntax)
|
||||
[(define-values (lifted) (quote-syntax (a-chunk id body ...)))
|
||||
(eq? (syntax-e #'a-chunk) 'a-chunk)
|
||||
(begin
|
||||
(add-to-chunk! #'id (syntax->list #'(body ...)))
|
||||
(loop #'exprs))]
|
||||
[_
|
||||
(loop #'exprs)])])))
|
||||
|
||||
(require racket/stxparam)
|
||||
(define-syntax-parameter mbeg #'#%module-begin)
|
||||
|
||||
(require (only-in typed/racket)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WORKAROUND
|
||||
;(dynamic-require 'typed/racket 0)
|
||||
|
||||
(define-for-syntax ((make-module-begin submod?) stx)
|
||||
(syntax-case stx ()
|
||||
[(_modbeg lang body0 . body)
|
||||
(let ()
|
||||
;; TODO: get the actual symbol, instead of the string returned by
|
||||
;; scribble's at-reader. Or use the first line as a whole as the #lang,
|
||||
;; to allow othe meta-languages to be chained.
|
||||
(define lang-sym
|
||||
(string->symbol (regexp-replace "^ " (syntax-e #'lang) "")))
|
||||
(dynamic-require lang-sym #f)
|
||||
(let ([expanded
|
||||
(expand `(,#'module scribble-lp-tmp-name hyper-literate/typed/private/lp
|
||||
(define-syntax-rule (if-preexpanding a b) a)
|
||||
(define-syntax-rule (when-preexpanding . b) (begin . b))
|
||||
(define-syntax-rule (unless-preexpanding . b) (begin))
|
||||
,@(strip-context #'(body0 . body))))])
|
||||
(syntax-case expanded ()
|
||||
[(module name lang (mb . stuff))
|
||||
(let ()
|
||||
(extract-chunks #'stuff)
|
||||
(dynamic-require lang-sym #f)
|
||||
(namespace-require `(for-meta -1 ,lang-sym))
|
||||
(replace-context
|
||||
(namespace-symbol->identifier '#%module-begin)
|
||||
#`(#%module-begin
|
||||
#,(tangle #'body0)
|
||||
#,@(if submod?
|
||||
(list
|
||||
(let ([submod
|
||||
(strip-context
|
||||
#`(module doc scribble/doclang2
|
||||
(define-syntax-rule (if-preexpanding a b) b)
|
||||
(define-syntax-rule (when-preexpanding . b) (begin))
|
||||
(define-syntax-rule (unless-preexpanding . b) (begin . b))
|
||||
(require scribble/manual
|
||||
(only-in hyper-literate/typed/private/lp chunk CHUNK))
|
||||
(begin body0 . body)))])
|
||||
(syntax-case submod ()
|
||||
[(_ . rest)
|
||||
(datum->syntax #'here (cons #'module* #'rest))])))
|
||||
'()))))])))]))
|
||||
|
||||
(define-syntax module-begin/plain (make-module-begin #f))
|
||||
(define-syntax module-begin/doc (make-module-begin #t))
|
||||
8
typed/lang/lang.rkt
Normal file
8
typed/lang/lang.rkt
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
#lang racket/base
|
||||
;; Forked from scribble-lib/scribble/lp/lang/lang2.rkt
|
||||
(require "common.rkt")
|
||||
|
||||
(provide (except-out (all-from-out "common.rkt")
|
||||
module-begin/plain
|
||||
module-begin/doc)
|
||||
(rename-out [module-begin/doc #%module-begin]))
|
||||
16
typed/lang/reader.rkt
Normal file
16
typed/lang/reader.rkt
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
#lang s-exp syntax/module-reader
|
||||
;; Forked from scribble-lib/scribble/lp/lang/reader.rkt
|
||||
|
||||
hyper-literate/typed/lang/lang
|
||||
|
||||
#:read read-inside
|
||||
#:read-syntax read-syntax-inside
|
||||
#:whole-body-readers? #t
|
||||
;; don't use scribble-base-info for the #:info arg, since
|
||||
;; scribble/lp files are not directly scribble'able.
|
||||
#:language-info (scribble-base-language-info)
|
||||
#:info (scribble-base-reader-info)
|
||||
(require scribble/reader
|
||||
(only-in scribble/base/reader
|
||||
scribble-base-reader-info
|
||||
scribble-base-language-info))
|
||||
92
typed/private/lp.rkt
Normal file
92
typed/private/lp.rkt
Normal file
|
|
@ -0,0 +1,92 @@
|
|||
#lang scheme/base
|
||||
;; Forked from scribble-lib/scribble/private/lp.rkt
|
||||
|
||||
(require (for-syntax scheme/base syntax/boundmap)
|
||||
scribble/scheme scribble/decode scribble/manual scribble/struct)
|
||||
|
||||
(begin-for-syntax
|
||||
;; maps chunk identifiers to a counter, so we can distinguish multiple uses
|
||||
;; of the same name
|
||||
(define chunk-numbers (make-free-identifier-mapping))
|
||||
(define (get-chunk-number id)
|
||||
(free-identifier-mapping-get chunk-numbers id (lambda () #f)))
|
||||
(define (inc-chunk-number id)
|
||||
(free-identifier-mapping-put! chunk-numbers id (+ 1 (free-identifier-mapping-get chunk-numbers id))))
|
||||
(define (init-chunk-number id)
|
||||
(free-identifier-mapping-put! chunk-numbers id 2)))
|
||||
|
||||
(define-for-syntax ((make-chunk racketblock) stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name expr ...)
|
||||
;; no need for more error checking, using chunk for the code will do that
|
||||
(identifier? #'name)
|
||||
(let* ([n (get-chunk-number (syntax-local-introduce #'name))]
|
||||
[str (symbol->string (syntax-e #'name))]
|
||||
[tag (format "~a:~a" str (or n 1))])
|
||||
|
||||
(when n
|
||||
(inc-chunk-number (syntax-local-introduce #'name)))
|
||||
|
||||
(syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...)))
|
||||
|
||||
(with-syntax ([tag tag]
|
||||
[str str]
|
||||
[((for-label-mod ...) ...)
|
||||
(map (lambda (expr)
|
||||
(syntax-case expr (require)
|
||||
[(require mod ...)
|
||||
(let loop ([mods (syntax->list #'(mod ...))])
|
||||
(cond
|
||||
[(null? mods) null]
|
||||
[else
|
||||
(syntax-case (car mods)
|
||||
(for-syntax quote submod)
|
||||
[(submod ".." . _)
|
||||
(loop (cdr mods))]
|
||||
[(submod "." . _)
|
||||
(loop (cdr mods))]
|
||||
[(quote x)
|
||||
(loop (cdr mods))]
|
||||
[(for-syntax x ...)
|
||||
(append (loop (syntax->list #'(x ...)))
|
||||
(loop (cdr mods)))]
|
||||
[x
|
||||
(cons #'x (loop (cdr mods)))])]))]
|
||||
[else null]))
|
||||
(syntax->list #'(expr ...)))]
|
||||
|
||||
[(rest ...) (if n
|
||||
#`((subscript #,(format "~a" n)))
|
||||
#`())])
|
||||
#`(begin
|
||||
(require (for-label for-label-mod ... ...))
|
||||
#,@(if n
|
||||
#'()
|
||||
#'((define-syntax name (make-element-id-transformer
|
||||
(lambda (stx) #'(chunkref name))))
|
||||
(begin-for-syntax (init-chunk-number #'name))))
|
||||
(make-splice
|
||||
(list (make-toc-element
|
||||
#f
|
||||
(list (elemtag '(chunk tag)
|
||||
(bold (italic (racket name)) " ::=")))
|
||||
(list (smaller (elemref '(chunk tag) #:underline? #f
|
||||
str
|
||||
rest ...))))
|
||||
(#,racketblock expr ...))))))]))
|
||||
|
||||
(define-syntax chunk (make-chunk #'racketblock))
|
||||
(define-syntax CHUNK (make-chunk #'RACKETBLOCK))
|
||||
|
||||
(define-syntax (chunkref stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
(identifier? #'id)
|
||||
(with-syntax ([tag (format "~a:1" (syntax-e #'id))]
|
||||
[str (format "~a" (syntax-e #'id))])
|
||||
#'(elemref '(chunk tag) #:underline? #f str))]))
|
||||
|
||||
|
||||
(provide (all-from-out scheme/base
|
||||
scribble/manual)
|
||||
chunk CHUNK)
|
||||
Loading…
Reference in New Issue
Block a user