Added support for highlighting parts of literate programs.
This commit is contained in:
Georges Dupéron
parent
d0a3a0b255
commit
a499901ead
271
diff1.rkt
Normal file
271
diff1.rkt
Normal file
|
|
@ -0,0 +1,271 @@
|
||||||
|
#lang at-exp racket/base
|
||||||
|
|
||||||
|
(provide hlite
|
||||||
|
init)
|
||||||
|
|
||||||
|
(require hyper-literate
|
||||||
|
(for-syntax syntax/parse
|
||||||
|
(rename-in racket/base [... …])
|
||||||
|
racket/match
|
||||||
|
syntax/srcloc)
|
||||||
|
scribble/core
|
||||||
|
scribble/html-properties
|
||||||
|
scribble/base)
|
||||||
|
|
||||||
|
(define the-css-addition
|
||||||
|
#"
|
||||||
|
.el-dim {
|
||||||
|
filter: brightness(150%) contrast(30%) opacity(0.7);
|
||||||
|
background: none; /* rgba(82, 103, 255, 0.36); */
|
||||||
|
}
|
||||||
|
|
||||||
|
.el-hliteadd{
|
||||||
|
filter: initial;
|
||||||
|
background: rgba(108, 175, 108, 0.36);
|
||||||
|
}
|
||||||
|
|
||||||
|
.el-hliterm {
|
||||||
|
filter: initial;
|
||||||
|
background: rgba(173, 54, 54, 0.36);
|
||||||
|
}
|
||||||
|
|
||||||
|
.el-undim {
|
||||||
|
filter: initial;
|
||||||
|
background: none;
|
||||||
|
}")
|
||||||
|
|
||||||
|
(define (init)
|
||||||
|
(elem
|
||||||
|
#:style (style "dim"
|
||||||
|
(list (css-addition the-css-addition)))))
|
||||||
|
|
||||||
|
(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-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 #'+)) '+]
|
||||||
|
[(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
|
||||||
|
[(/) "el-dim"]
|
||||||
|
[(=) "el-undim"]
|
||||||
|
[(-) "el-hliterm"]
|
||||||
|
[(+) "el-hliteadd"]))
|
||||||
|
(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)])
|
||||||
|
(cons
|
||||||
|
(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)))
|
||||||
|
(loop (car guide) (cdr guide) body))))]
|
||||||
|
[(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 highligh 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)))]
|
||||||
|
['()
|
||||||
|
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 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:
|
||||||
|
;; (accumulated ... . rest)
|
||||||
|
(let ([r-acc (reverse acc)])
|
||||||
|
(append
|
||||||
|
r-acc
|
||||||
|
(loop (car guide) (cdr guide) body))))]
|
||||||
|
[(and (pair? guide) (pair? body))
|
||||||
|
;; accumulate the first element of body, if mode is not '-
|
||||||
|
;; which means that the element should be removed.
|
||||||
|
(loop2 #f
|
||||||
|
(cdr guide)
|
||||||
|
(cdr body)
|
||||||
|
(if (eq? mode '-)
|
||||||
|
acc
|
||||||
|
(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)
|
||||||
|
;; produce:
|
||||||
|
;; ((accumulated ...))
|
||||||
|
(let* ([r-acc (reverse acc)])
|
||||||
|
r-acc)]
|
||||||
|
[else
|
||||||
|
;; produce:
|
||||||
|
;; (accumulated ... . improper-tail)
|
||||||
|
(let* ([new-body (loop mode guide body)]
|
||||||
|
[r-acc+tail (append (reverse acc) new-body)])
|
||||||
|
r-acc+tail)])))
|
||||||
|
(if (syntax? body)
|
||||||
|
(datum->syntax body loop2-result body body)
|
||||||
|
loop2-result)]
|
||||||
|
[(? symbol?)
|
||||||
|
body]
|
||||||
|
['()
|
||||||
|
body])))
|
||||||
|
;(show-stx #'body)
|
||||||
|
(displayln new-body)
|
||||||
|
#`(begin
|
||||||
|
#,(datum->syntax
|
||||||
|
stx
|
||||||
|
`(,(datum->syntax #'here 'chunk #'self)
|
||||||
|
#:display-only
|
||||||
|
,#'name
|
||||||
|
. ,(syntax-e new-body))
|
||||||
|
stx)
|
||||||
|
(chunk #:save-as dommy name
|
||||||
|
. #,new-executable-code)))]))
|
||||||
|
|
||||||
|
|
@ -56,7 +56,9 @@
|
||||||
(list (restore expr (loop subs)))
|
(list (restore expr (loop subs)))
|
||||||
(list (shift expr))))))
|
(list (shift expr))))))
|
||||||
block)))))
|
block)))))
|
||||||
(with-syntax ([(body0 body ...) (strip-comments body)]
|
(with-syntax ([body (strip-comments body)]
|
||||||
|
;; Hopefully the scopes are correct enough on the whole body.
|
||||||
|
[body0 (syntax-case body () [(a . _) #'a] [a #'a])]
|
||||||
;; construct arrows manually
|
;; construct arrows manually
|
||||||
[((b-use b-id) ...)
|
[((b-use b-id) ...)
|
||||||
(append-map (lambda (m)
|
(append-map (lambda (m)
|
||||||
|
|
@ -69,7 +71,7 @@
|
||||||
;; TODO: fix srcloc (already fixed?).
|
;; TODO: fix srcloc (already fixed?).
|
||||||
;#`(#,(datum->syntax #'body0 'begin) (let ([b-id (void)]) b-use) ... body0 body ...)
|
;#`(#,(datum->syntax #'body0 'begin) (let ([b-id (void)]) b-use) ... body0 body ...)
|
||||||
(syntax-property
|
(syntax-property
|
||||||
(syntax-property #`(#,(datum->syntax #'body0 'begin) body0 body ...)
|
(syntax-property #`(#,(datum->syntax #'body0 'begin) . body)
|
||||||
'disappeared-binding (syntax->list (syntax-local-introduce #'(b-id ...))))
|
'disappeared-binding (syntax->list (syntax-local-introduce #'(b-id ...))))
|
||||||
'disappeared-use (syntax->list (syntax-local-introduce #'(b-use ...))))))
|
'disappeared-use (syntax->list (syntax-local-introduce #'(b-use ...))))))
|
||||||
|
|
||||||
|
|
@ -110,7 +112,9 @@
|
||||||
[(and (pair? ad)
|
[(and (pair? ad)
|
||||||
(eq? (syntax-e (car ad))
|
(eq? (syntax-e (car ad))
|
||||||
'code:line))
|
'code:line))
|
||||||
(strip-comments (append (cdr ad) (cdr body)))]
|
(if (null? (cdr body))
|
||||||
|
(strip-comments (cdr ad))
|
||||||
|
(strip-comments (append (cdr ad) (cdr body))))]
|
||||||
[else (cons (strip-comments a)
|
[else (cons (strip-comments a)
|
||||||
(strip-comments (cdr body)))])]
|
(strip-comments (cdr body)))])]
|
||||||
[else body]))
|
[else body]))
|
||||||
|
|
|
||||||
|
|
@ -197,7 +197,8 @@
|
||||||
(define-for-syntax (make-chunk chunk-code chunk-display)
|
(define-for-syntax (make-chunk chunk-code chunk-display)
|
||||||
(syntax-parser
|
(syntax-parser
|
||||||
;; no need for more error checking, using chunk for the code will do that
|
;; no need for more error checking, using chunk for the code will do that
|
||||||
[(_ (~optional (~seq #:save-as save-as:id))
|
[(_ {~optional {~seq #:save-as save-as:id}}
|
||||||
|
{~optional {~and #:display-only display-only}}
|
||||||
{~and name:id original-before-expr}
|
{~and name:id original-before-expr}
|
||||||
expr ...)
|
expr ...)
|
||||||
(define n (get-chunk-number (syntax-local-introduce #'name)))
|
(define n (get-chunk-number (syntax-local-introduce #'name)))
|
||||||
|
|
@ -216,14 +217,18 @@
|
||||||
(define/with-syntax stx-chunk-display chunk-display)
|
(define/with-syntax stx-chunk-display chunk-display)
|
||||||
|
|
||||||
#`(begin
|
#`(begin
|
||||||
(stx-chunk-code name . #,(if preexpanding?
|
#,@(if (attribute display-only)
|
||||||
#'(expr ...)
|
#'{}
|
||||||
#'(expr ...) #;(strip-source #'(expr ...))))
|
#`{(stx-chunk-code name
|
||||||
|
. #,(if preexpanding?
|
||||||
|
#'(expr ...)
|
||||||
|
#'(expr ...)
|
||||||
|
#;(strip-source #'(expr ...))))})
|
||||||
#,@(if n
|
#,@(if n
|
||||||
#'()
|
#'()
|
||||||
#'((define-syntax name (make-element-id-transformer
|
#'((define-syntax name (make-element-id-transformer
|
||||||
(lambda (stx) #'(chunkref name))))
|
(lambda (stx) #'(chunkref name))))
|
||||||
(begin-for-syntax (init-chunk-number #'name))))
|
(define-syntax dummy (init-chunk-number #'name))))
|
||||||
#,(if (attribute save-as)
|
#,(if (attribute save-as)
|
||||||
#`(begin
|
#`(begin
|
||||||
#,#'(define-syntax (do-for-syntax _)
|
#,#'(define-syntax (do-for-syntax _)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user