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 (shift expr))))))
|
||||
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
|
||||
[((b-use b-id) ...)
|
||||
(append-map (lambda (m)
|
||||
|
|
@ -69,7 +71,7 @@
|
|||
;; 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) body0 body ...)
|
||||
(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 ...))))))
|
||||
|
||||
|
|
@ -110,7 +112,9 @@
|
|||
[(and (pair? ad)
|
||||
(eq? (syntax-e (car ad))
|
||||
'code:line))
|
||||
(strip-comments (append (cdr ad) (cdr body)))]
|
||||
(if (null? (cdr body))
|
||||
(strip-comments (cdr ad))
|
||||
(strip-comments (append (cdr ad) (cdr body))))]
|
||||
[else (cons (strip-comments a)
|
||||
(strip-comments (cdr body)))])]
|
||||
[else body]))
|
||||
|
|
|
|||
|
|
@ -197,7 +197,8 @@
|
|||
(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 {~seq #:save-as save-as:id}}
|
||||
{~optional {~and #:display-only display-only}}
|
||||
{~and name:id original-before-expr}
|
||||
expr ...)
|
||||
(define n (get-chunk-number (syntax-local-introduce #'name)))
|
||||
|
|
@ -216,14 +217,18 @@
|
|||
(define/with-syntax stx-chunk-display chunk-display)
|
||||
|
||||
#`(begin
|
||||
(stx-chunk-code name . #,(if preexpanding?
|
||||
#'(expr ...)
|
||||
#'(expr ...) #;(strip-source #'(expr ...))))
|
||||
#,@(if (attribute display-only)
|
||||
#'{}
|
||||
#`{(stx-chunk-code name
|
||||
. #,(if preexpanding?
|
||||
#'(expr ...)
|
||||
#'(expr ...)
|
||||
#;(strip-source #'(expr ...))))})
|
||||
#,@(if n
|
||||
#'()
|
||||
#'((define-syntax name (make-element-id-transformer
|
||||
(lambda (stx) #'(chunkref name))))
|
||||
(begin-for-syntax (init-chunk-number #'name))))
|
||||
(define-syntax dummy (init-chunk-number #'name))))
|
||||
#,(if (attribute save-as)
|
||||
#`(begin
|
||||
#,#'(define-syntax (do-for-syntax _)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user