388 lines
16 KiB
Racket
388 lines
16 KiB
Racket
#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)))]))
|
|
|