Compare commits
No commits in common. "main" and "before-6.7.0.4" have entirely different histories.
main
...
before-6.7
20
.travis.yml
20
.travis.yml
|
|
@ -24,20 +24,10 @@ 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=6.6
|
||||
- RACKET_VERSION=HEAD
|
||||
|
||||
matrix:
|
||||
|
|
@ -51,7 +41,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:
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
[](https://travis-ci.org/jsmaniac/hyper-literate)
|
||||
[](https://coveralls.io/github/jsmaniac/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)
|
||||
[](http://docs.racket-lang.org/hyper-literate/)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))]))
|
||||
|
||||
22
info.rkt
22
info.rkt
|
|
@ -8,24 +8,14 @@
|
|||
"typed-racket-lib"
|
||||
"typed-racket-more"
|
||||
"typed-racket-doc"
|
||||
"scribble-enhanced"
|
||||
"sexp-diff"
|
||||
"tr-immutable"
|
||||
"typed-map-lib"
|
||||
"debug-scopes"
|
||||
"syntax-color-lib"))
|
||||
"scribble-enhanced"))
|
||||
(define build-deps '("scribble-lib"
|
||||
"racket-doc"
|
||||
"rackunit-doc"
|
||||
"scribble-doc"
|
||||
"rackunit-doc"))
|
||||
(define scribblings '(("scribblings/hyper-literate.scrbl" () ("Scribble Libraries"))
|
||||
"scribble-doc"))
|
||||
(define scribblings '(("scribblings/hyper-literate.scrbl" ())
|
||||
("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|))
|
||||
(define pkg-desc "Description Here")
|
||||
(define version "0.0")
|
||||
(define pkg-authors '(|Georges Dupéron|))
|
||||
|
|
|
|||
2
lang.rkt
2
lang.rkt
|
|
@ -5,4 +5,4 @@
|
|||
(provide (rename-out [module-begin/doc #%module-begin])
|
||||
;; TODO: this is the #%top-interaction from racket/base, not from the
|
||||
;; user-specified language.
|
||||
#;#%top-interaction)
|
||||
#%top-interaction)
|
||||
|
|
|
|||
|
|
@ -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 +1,31 @@
|
|||
#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")
|
||||
racket/port)
|
||||
|
||||
(provide meta-read-inside
|
||||
meta-read-syntax-inside
|
||||
get-command-char)
|
||||
meta-read-syntax-inside)
|
||||
|
||||
(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 (read-line-length port)
|
||||
(let* ([peeking (peeking-input-port port)]
|
||||
[start (file-position peeking)]
|
||||
[_ (read-line peeking)]
|
||||
[end (file-position peeking)])
|
||||
(- end start)))
|
||||
|
||||
(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 (narrow-to-one-line port)
|
||||
(make-limited-input-port port (read-line-length port)))
|
||||
|
||||
(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))
|
||||
(displayln args)
|
||||
(apply read-inside args))
|
||||
|
||||
(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)))))
|
||||
(define in1 (narrow-to-one-line in))
|
||||
(with-syntax ([rd1 (let loop ([res '()])
|
||||
(define res+ (read-syntax source-name in1))
|
||||
(if (eof-object? res+)
|
||||
(reverse res)
|
||||
(loop (cons res+ res))))]
|
||||
[rd (apply read-syntax-inside source-name in args)])
|
||||
#'(rd1 . rd)))
|
||||
|
|
@ -9,79 +9,8 @@ hyper-literate/lang
|
|||
;; don't use scribble-base-info for the #:info arg, since
|
||||
;; scribble/lp files are not directly scribble'able.
|
||||
#:language-info (scribble-base-language-info)
|
||||
#:info (wrapped-scribble-base-reader-info)
|
||||
#:info (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)])))
|
||||
scribble-base-language-info))
|
||||
|
|
|
|||
|
|
@ -7,10 +7,7 @@
|
|||
|
||||
(require (for-syntax racket/base syntax/boundmap racket/list
|
||||
syntax/strip-context
|
||||
syntax/srcloc
|
||||
racket/struct
|
||||
syntax/srcloc
|
||||
debug-scopes/named-scopes/exptime))
|
||||
syntax/srcloc))
|
||||
|
||||
(begin-for-syntax
|
||||
(define first-id #f)
|
||||
|
|
@ -32,14 +29,30 @@
|
|||
chunks id
|
||||
`(,@(mapping-get chunks id) ,@exprs))))
|
||||
|
||||
(define-for-syntax (tangle orig-stx)
|
||||
(define-for-syntax (tangle orig-stx req-lng)
|
||||
(define chunk-mentions '())
|
||||
(unless first-id
|
||||
(raise-syntax-error 'scribble/lp "no chunks"))
|
||||
;(define orig-stx (syntax-case stx () [(_ orig) #'orig]))
|
||||
(define (restore nstx d) (datum->syntax orig-stx d nstx nstx))
|
||||
(define (shift nstx) (replace-context orig-stx nstx))
|
||||
(define body
|
||||
(let ([main-id (or main-id first-id)])
|
||||
;; HACK to get arrows drawn for built-ins imported by the module language.
|
||||
;; TODO: it fails with type-expander.lp2.rkt, because it re-requires λ
|
||||
;; (the new-λ) from 'main.
|
||||
(when req-lng
|
||||
(free-identifier-mapping-put!
|
||||
chunk-groups main-id
|
||||
(cons main-id (mapping-get chunk-groups main-id)))
|
||||
(free-identifier-mapping-put!
|
||||
chunks main-id
|
||||
`(,#`(require #,(datum->syntax main-id
|
||||
req-lng
|
||||
req-lng
|
||||
req-lng))
|
||||
,@(mapping-get chunks main-id))))
|
||||
;;;;;;;;;;;;;;
|
||||
(restore
|
||||
main-id
|
||||
(let loop ([block (get-chunk main-id)])
|
||||
|
|
@ -56,9 +69,7 @@
|
|||
(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])]
|
||||
(with-syntax ([(body ...) (strip-comments body)]
|
||||
;; construct arrows manually
|
||||
[((b-use b-id) ...)
|
||||
(append-map (lambda (m)
|
||||
|
|
@ -67,13 +78,12 @@
|
|||
(syntax-local-introduce u)))
|
||||
(mapping-get chunk-groups m)))
|
||||
chunk-mentions)])
|
||||
;(displayln (dynamic-require 'tyyyyyyyyyyyped/racket '#%module-begin))
|
||||
;; TODO: use disappeared-use and disappeared-binding.
|
||||
;; TODO: fix srcloc (already fixed?).
|
||||
;#`(#,(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 ...))))))
|
||||
#`(begin (let ([b-id (void)]) b-use) ... body ...)
|
||||
#;(replace-context #'#%module-begin;modbeg-ty
|
||||
#`(begin (let ([b-id (void)]) b-use) ... body ...))))
|
||||
|
||||
(define-for-syntax (strip-comments body)
|
||||
(cond
|
||||
|
|
@ -112,9 +122,7 @@
|
|||
[(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))))]
|
||||
(strip-comments (append (cdr ad) (cdr body)))]
|
||||
[else (cons (strip-comments a)
|
||||
(strip-comments (cdr body)))])]
|
||||
[else body]))
|
||||
|
|
@ -136,68 +144,26 @@
|
|||
(require (for-syntax racket/syntax
|
||||
syntax/parse))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(require (only-in typed/racket)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WORKAROUND ;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(require (for-syntax racket/pretty
|
||||
"no-auto-require.rkt"))
|
||||
|
||||
(define-for-syntax (strip-source e)
|
||||
(cond [(syntax? e)
|
||||
(update-source-location
|
||||
(datum->syntax e (strip-source (syntax-e e)) e e)
|
||||
#:source #f)]
|
||||
[(pair? e) (cons (strip-source (car e)) (strip-source (cdr e)))]
|
||||
[(vector? e) (list->vector (strip-source (vector->list e)))]
|
||||
[(prefab-struct-key e)
|
||||
=> (λ (k) (make-prefab-struct k (strip-source (struct->list e))))]
|
||||
;; TODO: hash tables
|
||||
[else e]))
|
||||
|
||||
;; Many thanks to Alex Knauth and Matthew Flatt for finding out how to make
|
||||
;; module meta-languages.
|
||||
(define-syntax (continue stx)
|
||||
(syntax-case stx ()
|
||||
[(_self lang-module-begin maybe-chain₊ . body)
|
||||
(let ()
|
||||
(define ch₊ (syntax->list #'maybe-chain₊))
|
||||
(define expanded (local-expand
|
||||
(datum->syntax stx
|
||||
`(,#'lang-module-begin ,@ch₊ . ,#'body)
|
||||
stx
|
||||
stx)
|
||||
'module-begin
|
||||
(list)))
|
||||
(define meta-language-nesting
|
||||
;; Use a module-like scope here, instead of (make-syntax-introducer),
|
||||
;; otherwise DrRacket stops drawing some arrows (why?).
|
||||
(make-module-like-named-scope 'meta-language-nesting))
|
||||
(syntax-case expanded (#%plain-module-begin)
|
||||
[(#%plain-module-begin . expanded-body)
|
||||
#`(begin
|
||||
.
|
||||
#,(meta-language-nesting #'expanded-body))]))]))
|
||||
|
||||
(define-for-syntax ((make-module-begin submod?) stx)
|
||||
(syntax-parse stx
|
||||
;; #: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₊))}
|
||||
[(_modbeg (lang:id (~optional (~and no-require-lang #:no-require-lang))
|
||||
(~optional (~and no-auto-require #:no-auto-require)))
|
||||
body0 . body)
|
||||
(let ()
|
||||
(define lang-sym (syntax-e #'lang))
|
||||
(let ([expanded
|
||||
(let ([expanded
|
||||
(expand `(,#'module
|
||||
scribble-lp-tmp-name hyper-literate/private/lp
|
||||
(require hyper-literate/private/chunks-toc-prefix
|
||||
(for-syntax racket/base
|
||||
hyper-literate/private/no-auto-require))
|
||||
(begin-for-syntax (set-box! no-auto-require?
|
||||
,(if (attribute no-auto-require) #t #f))
|
||||
(set-box! preexpanding? #t))
|
||||
,(if (attribute no-auto-require) #t #f)))
|
||||
(define-syntax-rule (if-preexpanding a b) a)
|
||||
(define-syntax-rule (when-preexpanding . b) (begin . b))
|
||||
(define-syntax-rule (unless-preexpanding . b) (begin))
|
||||
|
|
@ -206,20 +172,25 @@
|
|||
[(module name elang (mb . stuff))
|
||||
(let ()
|
||||
(extract-chunks #'stuff)
|
||||
(dynamic-require lang-sym #f)
|
||||
(namespace-require `(for-meta -1 ,lang-sym))
|
||||
#;(begin
|
||||
(define/with-syntax tngl (tangle #'body0))
|
||||
(define/with-syntax (tngl0 . tngl*) #'tngl)
|
||||
(define/with-syntax (ex-mod ex-nam ex-lng (ex-#%m . ex-rest))
|
||||
(expand-syntax
|
||||
#`(#,#'module hyper-literate-temp-expand #,lang-sym
|
||||
#,(replace-context #'here #'tngl))))
|
||||
#`(ex-#%m #,(datum->syntax (syntax-local-introduce #'ex-rest)
|
||||
'(#%require lang-sym))
|
||||
. ex-rest))
|
||||
(define/with-syntax tngl
|
||||
(tangle #'body0))
|
||||
(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
|
||||
(tangle #'body0 (if (attribute no-require-lang) #f #'lang)))
|
||||
;(replace-context
|
||||
;(namespace-symbol->identifier '#%module-begin)
|
||||
;#`(#,(syntax/loc #'lang #%module-begin) …)
|
||||
#`(#,(namespace-symbol->identifier '#%module-begin)
|
||||
tngl
|
||||
#,@(if submod?
|
||||
(list
|
||||
(with-syntax*
|
||||
|
|
@ -233,38 +204,32 @@
|
|||
#: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 _)
|
||||
)])))]))
|
||||
#`(module* doc lng ;module doc scribble/doclang2
|
||||
#,@(syntax-local-introduce
|
||||
;; TODO: instead use:
|
||||
;; (begin-for-syntax (set! preexpanding #f))
|
||||
;; and make these identifiers exported by
|
||||
;; hyper-literate
|
||||
(strip-context
|
||||
#`((require hyper-literate/private/chunks-toc-prefix
|
||||
(for-syntax racket/base
|
||||
hyper-literate/private/no-auto-require))
|
||||
(begin-for-syntax (set-box! no-auto-require?
|
||||
#,(if (attribute no-auto-require) #t #f)))
|
||||
(define-syntax-rule (if-preexpanding a b)
|
||||
b)
|
||||
(define-syntax-rule (when-preexpanding . b)
|
||||
(begin))
|
||||
(define-syntax-rule (unless-preexpanding . b)
|
||||
(begin . b))
|
||||
(require scribble-enhanced/with-manual
|
||||
hyper-literate))))
|
||||
(begn body0 . body))
|
||||
;(strip-context
|
||||
#;#`(modl doc lng ;module doc scribble/doclang2
|
||||
|
||||
(begn body0 . body))))
|
||||
'())))])))]))
|
||||
|
||||
(define-syntax module-begin/plain (make-module-begin #f))
|
||||
(define-syntax module-begin/doc (make-module-begin #t))
|
||||
|
|
|
|||
|
|
@ -7,10 +7,7 @@
|
|||
(for-syntax scheme/base
|
||||
syntax/boundmap
|
||||
syntax/parse
|
||||
racket/syntax
|
||||
racket/struct
|
||||
syntax/srcloc
|
||||
"../restore-comments.rkt"))
|
||||
racket/syntax))
|
||||
|
||||
(begin-for-syntax
|
||||
;; maps chunk identifiers to a counter, so we can distinguish multiple uses
|
||||
|
|
@ -116,30 +113,10 @@
|
|||
#'()
|
||||
#'((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)
|
||||
(define-for-syntax ((make-chunk-display racketblock) 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 ...)
|
||||
[(_ original-name:id name:id stxn:number expr ...)
|
||||
(define n (syntax-e #'stxn))
|
||||
(define original-name:n (syntax-local-introduce
|
||||
(format-id #'original-name
|
||||
|
|
@ -149,7 +126,6 @@
|
|||
(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
|
||||
|
|
@ -160,20 +136,6 @@
|
|||
(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
|
||||
|
|
@ -183,28 +145,20 @@
|
|||
(list (elemtag '(prefixable tag)
|
||||
(bold (italic (elemref '(prefixable tag)
|
||||
#:underline? #f
|
||||
#,str-display rest ...))
|
||||
" ::="))
|
||||
#,@(if (attribute button) #'{button} #'{}))
|
||||
#,str rest ...))
|
||||
" ::=")))
|
||||
(list (smaller
|
||||
(make-link-element "plainlink"
|
||||
(decode-content
|
||||
(list #,str-display rest ...))
|
||||
(decode-content (list #,str rest ...))
|
||||
`(elem (prefixable
|
||||
,@(chunks-toc-prefix)
|
||||
tag))))))
|
||||
(#,racketblock
|
||||
. #,(strip-source #'expr*+comments)))))]))
|
||||
(#,racketblock expr ...))))]))
|
||||
|
||||
(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} #'{})
|
||||
[(_ (~optional (~seq #:save-as save-as:id)) name:id expr ...)
|
||||
(define n (get-chunk-number (syntax-local-introduce #'name)))
|
||||
(define/with-syntax name:n (format-id #'name "~a:~a" #'name (or n 1)))
|
||||
|
||||
|
|
@ -221,18 +175,12 @@
|
|||
(define/with-syntax stx-chunk-display chunk-display)
|
||||
|
||||
#`(begin
|
||||
#,@(if (attribute display-only)
|
||||
#'{}
|
||||
#`{(stx-chunk-code name
|
||||
. #,(if preexpanding?
|
||||
#'(expr ...)
|
||||
#'(expr ...)
|
||||
#;(strip-source #'(expr ...))))})
|
||||
(stx-chunk-code name expr ...)
|
||||
#,@(if n
|
||||
#'()
|
||||
#'((define-syntax name (make-element-id-transformer
|
||||
(lambda (stx) #'(chunkref name))))
|
||||
(define-syntax dummy (init-chunk-number #'name))))
|
||||
(begin-for-syntax (init-chunk-number #'name))))
|
||||
#,(if (attribute save-as)
|
||||
#`(begin
|
||||
#,#'(define-syntax (do-for-syntax _)
|
||||
|
|
@ -261,27 +209,20 @@
|
|||
(quote-syntax name))]
|
||||
[(local-expr (... ...))
|
||||
(syntax-local-introduce
|
||||
(quote-syntax #,(strip-source #'(expr ...))))])
|
||||
(quote-syntax (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 ...))))))]))
|
||||
#`(list (stx-chunk-display name name stx-n 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-display (make-chunk-display #'racketblock))
|
||||
(define-syntax CHUNK-display (make-chunk-display #'RACKETBLOCK))
|
||||
(define-syntax chunk (make-chunk #'chunk-code #'chunk-display))
|
||||
(define-syntax CHUNK (make-chunk #'CHUNK-code #'CHUNK-display))
|
||||
|
||||
|
|
@ -290,8 +231,8 @@
|
|||
[(_ 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))]))
|
||||
[str (format "~a" (syntax-e #'id))])
|
||||
#'(elemref '(prefixable tag) #:underline? #f str))]))
|
||||
|
||||
|
||||
(provide (all-from-out scheme/base
|
||||
|
|
|
|||
|
|
@ -1,6 +1,4 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide no-auto-require?)
|
||||
(define no-auto-require? (box #f))
|
||||
(provide preexpanding?)
|
||||
(define preexpanding? (box #f))
|
||||
(define no-auto-require? (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))]
|
||||
|
|
@ -5,8 +5,8 @@
|
|||
(subtract-in scribble/manual hyper-literate)
|
||||
racket/contract]]
|
||||
|
||||
@title{Hyper-literate programming}
|
||||
@author[@author+email["Suzanne Soy" "racket@suzanne.soy"]]
|
||||
@title{hyper-literate}
|
||||
@author{Georges Dupéron}
|
||||
|
||||
@(require scribble/manual
|
||||
scribble/core
|
||||
|
|
@ -41,10 +41,8 @@ options:
|
|||
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))])))
|
||||
[maybe-no-req #:no-require-lang]
|
||||
[maybe-no-auto #:no-auto-require]])))
|
||||
|
||||
where @racket[_lang] is a module name which can be used as
|
||||
a @litchar{#lang}, for example @racketmodname[typed/racket]
|
||||
|
|
@ -54,11 +52,14 @@ 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)].
|
||||
@racket[_lang] itself. This extra @racket[require] statement
|
||||
can however conflict with later user-provided
|
||||
@racket[require] statements, which would otherwise shadow
|
||||
the built-ins. The @racket[#:no-require-lang] option
|
||||
disables that behaviour, and has the only drawback that
|
||||
built-ins of the @racket[_lang] language do not have an
|
||||
arrow in DrRacket (but they still should be highlighted with
|
||||
a turquoise background when hovered over with the mouse).
|
||||
|
||||
The current implementation of @racketmodname[scribble/lp2],
|
||||
on which @racketmodname[hyper-literate] relies (with a few
|
||||
|
|
@ -77,24 +78,6 @@ possible in this case to disable the feature using
|
|||
@racket[(require (for-label …))] and handle conflicting
|
||||
identifiers in a more fine-grained way.
|
||||
|
||||
@deprecated[#:what @racket[#:no-require-lang] ""]{
|
||||
|
||||
The @racket[#:no-require-lang] is deprecated starting from version 0.1, and
|
||||
is not needed anymore. It is still accepted for backwards compatibility. Note
|
||||
that version 0.1 of this library requires a fairly recent Racket version to
|
||||
work properly (it needs v.6.7.0.4 with the commit
|
||||
@tt{8a7852ebbfeb85a8f860700ba5ae481ed7aa9b41}, or v.6.7.0.5 or later). By
|
||||
default, raco will install v0.0 of hyper-literate on older Racket versions.
|
||||
|
||||
The extra @racket[require] statement injected by
|
||||
@racketmodname[hyper-literate] could in previous versions conflict with
|
||||
user-written @racket[require] statements. These @racket[require] statements
|
||||
can shadow some built-ins, and this case would yield conflicts. The
|
||||
@racket[#:no-require-lang] option disables that behaviour in versions < 0.1,
|
||||
and has the only drawback that built-ins of the @racket[_lang] language do not
|
||||
have an arrow in DrRacket (but they still should be highlighted with -a
|
||||
turquoise background when hovered over with the mouse).}
|
||||
|
||||
@section{What is hyper-literate programming?}
|
||||
|
||||
Hyper-literate programming is to literate programming
|
||||
|
|
@ -269,7 +252,4 @@ present).
|
|||
"@(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)]
|
||||
" 'program-code-here]\n"]}]}
|
||||
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))
|
||||
Loading…
Reference in New Issue
Block a user