#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)))]))