281 lines
11 KiB
Racket
281 lines
11 KiB
Racket
#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)
|
|
(cond
|
|
[(and (eq? mode '-)
|
|
(or (pair? (car body))
|
|
(and (syntax (car body))
|
|
(pair? (syntax-e (car body))))))
|
|
(let ([r (loop mode (car guide) (car body))])
|
|
(append (if (syntax? r) (syntax->list r) r)
|
|
acc))]
|
|
[(eq? mode '-)
|
|
acc]
|
|
[else
|
|
(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)))]))
|
|
|