diff1.rkt (16811B)
1 #lang at-exp racket/base 2 3 (provide hlite) 4 5 (require hyper-literate 6 (for-syntax syntax/parse 7 (rename-in racket/base [... …]) 8 racket/match 9 syntax/srcloc) 10 scribble/core 11 scribble/html-properties 12 scribble/latex-properties 13 scribble/base) 14 15 ;; For debugging. 16 (define-for-syntax (show-stx e) 17 (define (r e) 18 (cond 19 ([syntax? e] 20 (display "#'") 21 (r (syntax-e e))) 22 [(pair? e) 23 (display "(") 24 (let loop ([e e]) 25 (if (pair? e) 26 (begin (r (car e)) 27 (display " ") 28 (loop (cdr e))) 29 (if (null? e) 30 (display ")") 31 (begin 32 (display ". ") 33 (r e) 34 (display ")")))))] 35 [else 36 (print (syntax->datum (datum->syntax #f e)))])) 37 (r e) 38 (newline) 39 (newline)) 40 41 42 (define the-css-addition 43 #" 44 .HyperLiterateNormal { 45 filter: initial; 46 background: none; 47 } 48 49 .HyperLiterateDim { 50 filter: brightness(150%) contrast(30%) opacity(0.7); 51 background: none; /* rgba(82, 103, 255, 0.36); */ 52 } 53 54 .HyperLiterateAdd{ 55 filter: initial; 56 background: rgb(202, 226, 202); 57 } 58 59 .HyperLiterateRemove { 60 filter: initial; 61 background: rgb(225, 182, 182); 62 }") 63 64 (define the-latex-addition 65 #" 66 %\\usepackage{framed}% \begin{snugshade}\end{snugshade} 67 \\definecolor{HyperLiterateDimColor}{RGB}{210,210,210} 68 \\definecolor{HyperLiterateAddColor}{RGB}{202,226,202} 69 \\definecolor{HyperLiterateRemoveColor}{RGB}{225,182,182} 70 71 \\def\\HyperLiterateNormal#1{#1} 72 \\def\\HyperLiterateDim#1{\\colorbox{HyperLiterateDimColor}{% 73 \\vphantom{\\RktPn{(}\\RktValDef{Xj}}#1}} 74 \\def\\HyperLiterateAdd#1{\\colorbox{HyperLiterateAddColor}{% 75 \\vphantom{\\RktPn{(}\\RktValDef{Xj}}#1}} 76 \\def\\HyperLiterateRemove#1{\\colorbox{HyperLiterateRemoveColor}{% 77 \\vphantom{\\RktPn{(}\\RktValDef{Xj}}#1}} 78 ") 79 80 (define (init) 81 (elem 82 #:style (style #f 83 (list (css-addition the-css-addition) 84 (tex-addition the-latex-addition))))) 85 86 (begin-for-syntax 87 (define (stx-null? e) 88 (or (null? e) 89 (and (syntax? e) 90 (null? (syntax-e e))))) 91 (define (stx-pair? e) 92 (or (pair? e) 93 (and (syntax? e) 94 (pair? (syntax-e e)))))) 95 96 (define-syntax (hlite stx) 97 (syntax-case stx () 98 [(self name guide1 . body) 99 (and (identifier? #'self) 100 (identifier? #'name)) 101 (let () 102 (define (simplify-guide g) 103 (cond 104 [(and (identifier? g) (free-identifier=? g #'/)) '/] 105 [(and (identifier? g) (free-identifier=? g #'=)) '=] 106 [(and (identifier? g) (free-identifier=? g #'-)) '-] 107 [(and (identifier? g) (free-identifier=? g #'+)) '+] 108 [(and (identifier? g) (free-identifier=? g #'-/)) '-/] 109 [(and (identifier? g) (free-identifier=? g #'-=)) '-=] 110 [(and (identifier? g) (free-identifier=? g #'-+)) '-+] 111 [(identifier? g) '_] 112 [(syntax? g) (simplify-guide (syntax-e g))] 113 [(pair? g) (cons (simplify-guide (car g)) 114 (simplify-guide (cdr g)))] 115 [(null? g) '()])) 116 (define (mode→style m) 117 (case m 118 [(/) "HyperLiterateDim"] 119 [(=) "HyperLiterateNormal"] 120 [(-) "HyperLiterateRemove"] 121 [(+) "HyperLiterateAdd"] 122 [(-/) "HyperLiterateDim"] 123 [(-=) "HyperLiterateNormal"] 124 [(-+) "HyperLiterateAdd"])) 125 (define simplified-guide (simplify-guide #'guide1)) 126 (define (syntax-e? v) 127 (if (syntax? v) (syntax-e v) v)) 128 (define new-body 129 (let loop ([mode '=] 130 [guide simplified-guide] 131 [body #'body]) 132 (match guide 133 [(cons (and new-mode (or '/ '= '- '+ '-/ '-= '-+)) rest-guide) 134 (loop new-mode rest-guide body)] 135 [(list car-guide rest-guide) 136 #:when (and (pair? (syntax-e? body)) 137 (memq (syntax-e? (car (syntax-e? body))) 138 '[quote quasiquote 139 unquote unquote-splicing 140 quasisyntax syntax 141 unsyntax unsyntax-splicing]) 142 (pair? (syntax-e? (cdr (syntax-e? body)))) 143 (null? (syntax-e? 144 (cdr (syntax-e? (cdr (syntax-e? body)))))) 145 (let ([sp (syntax-span (car (syntax-e? body)))]) 146 (or (= sp 1) 147 (= sp 2)))) 148 (unless (symbol? car-guide) 149 (raise-syntax-error 'hlite 150 (format 151 "expected pattern ~a, found identifier" 152 car-guide) 153 (datum->syntax #f (car (syntax-e? body))))) 154 (define result 155 `(,(car (syntax-e? body)) 156 ,(loop mode 157 rest-guide 158 (car (syntax-e? (cdr (syntax-e? body))))))) 159 (if (syntax? body) 160 (datum->syntax body result body body) 161 body)] 162 [(cons car-guide rest-guide) 163 (unless (pair? (syntax-e? body)) 164 (raise-syntax-error 'hlite 165 (format 166 "expected pair ~a, found non-pair" 167 guide) 168 (datum->syntax #f body))) 169 (define loop2-result 170 (let loop2 ([first-iteration? #t] 171 [guide guide] 172 [body (if (syntax? body) (syntax-e body) body)] 173 [acc '()]) 174 (cond 175 [(and (pair? guide) 176 (memq (car guide) '(/ = - + -/ -= -+))) 177 (if first-iteration? 178 (loop (car guide) (cdr guide) body) 179 ;; produce: 180 ;; ({code:hilite {code:line accumulated ...}} . rest) 181 (let ([r-acc (reverse acc)] 182 [after (loop (car guide) (cdr guide) body)]) 183 (define (do after) 184 (datum->syntax 185 (car r-acc) 186 `(code:hilite (code:line ,@r-acc . ,after) 187 ,(mode→style mode)) 188 (build-source-location-list 189 (update-source-location (car r-acc) 190 #:span 0)))) 191 (if (stx-pair? body) 192 ;; TODO: refactor the two branches, they are very 193 ;; similar. 194 (cons (do '()) 195 after) 196 ;; Special case to handle (a . b) when b and a 197 ;; do not have the same highlighting. 198 ;; This assigns to the dot the highlighting for 199 ;; b, although it would be possible to assign 200 ;; andother highliughting (just change the 201 ;; mode→style below) 202 (let* ([loc1 (build-source-location-list 203 (update-source-location 204 (car acc) 205 #:span 0))] 206 [loc2 (build-source-location-list 207 (update-source-location 208 after 209 #:column (- (syntax-column after) 210 3) ;; spc + dot + spc 211 #:span 0))]) 212 `(,(do `(,(datum->syntax 213 #f 214 `(code:hilite 215 ,(datum->syntax 216 #f `(code:line . ,after) loc2) 217 ,(mode→style (car guide))) 218 loc1))))))))] 219 [(and (pair? guide) (pair? body)) 220 ;; accumulate the first element of body 221 (loop2 #f 222 (cdr guide) 223 (cdr body) 224 (cons (loop mode (car guide) (car body)) acc))] 225 ;; If body is not a pair, then we will treat it as an 226 ;; "improper tail" element, unless it is null? 227 [(null? body) 228 (unless (null? guide) 229 (raise-syntax-error 230 'hlite 231 ;; TODO: thread the syntax version of body, so that 232 ;; we can highlight the error. 233 "Expected non-null body, but found null" 234 stx)) 235 ;; produce: 236 ;; ({code:hilite {code:line accumulated ...}}) 237 (let* ([r-acc (reverse acc)]) 238 `(,(datum->syntax (car r-acc) 239 `(code:hilite (code:line . ,r-acc) 240 ,(mode→style mode)) 241 (build-source-location-list 242 (update-source-location (car r-acc) 243 #:span 0)))) 244 )] 245 [else 246 ;; produce: 247 ;; ({code:hilite 248 ;; {code:line accumulated ... . improper-tail}}) 249 (let* ([new-body (loop mode guide body)] 250 [r-acc+tail (append (reverse acc) new-body)]) 251 `(,(datum->syntax 252 (car r-acc+tail) 253 `(code:hilite (code:line . ,r-acc+tail) 254 ,(mode→style mode)) 255 (build-source-location-list 256 (update-source-location (car r-acc+tail) 257 #:span 0)))) 258 ) 259 ]))) 260 (if (syntax? body) 261 (datum->syntax body loop2-result body body) 262 loop2-result)] 263 [(? symbol?) 264 (datum->syntax body `(code:hilite (code:line ,body) 265 ,(mode→style mode)) 266 (build-source-location-list 267 (update-source-location body #:span 0)))] 268 ['() 269 (unless (stx-null? body) 270 (raise-syntax-error 271 'hlite 272 ;; TODO: thread the syntax version of body, so that 273 ;; we can highlight the error. 274 (format "Expected null body, but found non-null ~a" 275 (syntax->datum body)) 276 stx)) 277 body]))) 278 (define new-executable-code 279 (let loop ([mode '=] 280 [guide simplified-guide] 281 [body #'body]) 282 (match guide 283 [(cons (and new-mode (or '/ '= '- '+ '-/ '-= '-+)) rest-guide) 284 (loop new-mode rest-guide body)] 285 [(cons car-guide rest-guide) 286 (define (do-append-last-acc last-acc acc) 287 ;; When nothing is later added to acc, we can 288 ;; simply put r as the last element of the 289 ;; reversed acc. This allows r to be an 290 ;; improper list. 291 ;; do-append-last-acc is called when elements follow 292 ;; the current value of last-acc. 293 (unless (syntax->list (datum->syntax #f last-acc)) 294 (raise-syntax-error 295 'hlite 296 (format 297 (string-append 298 "the removal of elements caused a list with a" 299 "dotted tail to be spliced in a non-final position: ~a") 300 (syntax->datum (datum->syntax #f last-acc))) 301 stx)) 302 (append (reverse (syntax->list (datum->syntax #f last-acc))) 303 acc)) 304 (define loop2-result 305 (let loop2 ([first-iteration? #t] 306 [guide guide] 307 [body (if (syntax? body) (syntax-e body) body)] 308 [acc '()] 309 [last-acc '()]) 310 (cond 311 [(and (pair? guide) 312 (memq (car guide) '(/ = - + -/ -= -+))) 313 (if (or first-iteration? 314 (eq? (car guide) mode)) 315 (loop (car guide) (cdr guide) body) 316 (let ([r (loop (car guide) (cdr guide) body)]) 317 (if (stx-null? r) 318 ;; produce: (accumulated ... . last-acc) 319 (append (reverse acc) last-acc) 320 ;; produce: (accumulated ... last-acc ... . rest) 321 (let ([r-acc (reverse (do-append-last-acc 322 last-acc 323 acc))]) 324 (append r-acc r)))))] 325 [(and (pair? guide) (pair? body)) 326 ;; accumulate the first element of body, if mode is not '- 327 ;; which means that the element should be removed. 328 (cond 329 [(and (memq mode '(- -/ -= -+)) 330 (or (pair? (car body)) 331 (and (syntax? (car body)) 332 (pair? (syntax-e (car body)))))) 333 (let ([r (loop mode (car guide) (car body))]) 334 (loop2 #f 335 (cdr guide) 336 (cdr body) 337 (do-append-last-acc last-acc acc) 338 r))] 339 [(memq mode '(- -/ -= -+)) 340 (loop2 #f 341 (cdr guide) 342 (cdr body) 343 acc 344 last-acc)] 345 [else 346 (loop2 #f 347 (cdr guide) 348 (cdr body) 349 (do-append-last-acc last-acc acc) 350 (list (loop mode (car guide) (car body))))])] 351 ;; If body is not a pair, then we will treat it as an 352 ;; "improper tail" element, unless it is null? 353 [(null? body) 354 ;; produce: 355 ;; ((accumulated ...)) 356 (let* ([r-acc (append (reverse acc) last-acc)]) 357 r-acc)] 358 [else 359 ;; produce: 360 ;; (accumulated ... . improper-tail) 361 (let* ([new-body (loop mode guide body)] 362 [r-acc+tail (append 363 (reverse 364 (do-append-last-acc last-acc acc)) 365 new-body)]) 366 r-acc+tail)]))) 367 (if (syntax? body) 368 (datum->syntax body loop2-result body body) 369 loop2-result)] 370 [(? symbol?) 371 body] 372 ['() 373 body]))) 374 ;(displayln new-body) 375 ;(show-stx new-body) 376 #`(begin 377 (init) 378 #,(datum->syntax 379 stx 380 `(,(datum->syntax #'here 'chunk #'self) 381 #:display-only 382 ,#'name 383 . ,(syntax-e new-body)) 384 stx) 385 (chunk #:save-as dummy name 386 . #,new-executable-code)))])) 387