From a499901eada777ac6d1734d0a7419f2450b5b586 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Mon, 15 May 2017 21:38:49 +0200
Subject: [PATCH] Added support for highlighting parts of literate programs.
---
diff1.rkt | 271 +++++++++++++++++++++++++++++++++++++++++++++
private/common.rkt | 10 +-
private/lp.rkt | 15 ++-
3 files changed, 288 insertions(+), 8 deletions(-)
create mode 100644 diff1.rkt
diff --git a/diff1.rkt b/diff1.rkt
new file mode 100644
index 00000000..cf28a781
--- /dev/null
+++ b/diff1.rkt
@@ -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)))]))
+
diff --git a/private/common.rkt b/private/common.rkt
index d723cfb8..63e33816 100644
--- a/private/common.rkt
+++ b/private/common.rkt
@@ -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]))
diff --git a/private/lp.rkt b/private/lp.rkt
index ad5b428a..638149d4 100644
--- a/private/lp.rkt
+++ b/private/lp.rkt
@@ -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 _)