suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

slideshow/code: handle infix notation

Browse Source 
and also improve `code:line' alignment across lines
 Closes PR 8334
This commit is contained in:
Matthew Flatt 2011-03-04 07:56:26 -07:00
parent 63d465f114
commit 4f93672666
1 changed files with 90 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

124
collects/texpict/code.rkt
View File

@ -1,11 +1,13 @@
(module code mzscheme
(module code racket/base
(require "mrpict.ss"
(prefix r: racket/base)
(prefix-in r: racket/base)
mzlib/class
mzlib/list
(only scheme/list last)
(only-in scheme/list last)
racket/draw
mzlib/unit)
mzlib/unit
(for-syntax racket/base)
(only-in mzscheme make-namespace))
(provide define-code code^ code-params^ code@)
@ -66,7 +68,7 @@
(define (stx->loc-s-expr v)
(cond
[(syntax? v)
(let ([mk `(datum->syntax-object
(let ([mk `(datum->syntax
#f
,(syntax-case v (uncode)
[(uncode e) #'e]
@ -89,7 +91,7 @@
[(null? v) 'null]
[else `(quote ,v)]))
(define (cvt s)
(datum->syntax-object #'here (stx->loc-s-expr s)))
(datum->syntax #'here (stx->loc-s-expr s)))
(syntax-case stx ()
[(_ expr) #`(typeset-code #,(cvt #'expr))]
[(_ expr (... ...))
@ -172,14 +174,14 @@
(define current-keyword-list
(make-parameter
(let ([ht (make-hash-table)])
(for-each (lambda (n) (hash-table-put! ht n #f))
(let ([ht (make-hasheq)])
(for-each (lambda (n) (hash-set! ht n #f))
mzscheme-vars)
(for-each (lambda (n) (hash-table-put! ht n #f))
(for-each (lambda (n) (hash-set! ht n #f))
racket/base-vars)
(map symbol->string
(filter (lambda (n)
(hash-table-get ht n (lambda () #t)))
(hash-ref ht n #t))
(append mzscheme-bindings
racket/base-bindings))))))
(define current-const-list
@ -429,11 +431,27 @@
(code-htl-append (mode-colorize mode 'literal quasisyntax-p)
(loop #'x closes mode))]
[(code:contract i ...)
(add-semis (loop (datum->syntax-object #f (syntax->list #'(i ...)))
(add-semis (loop (datum->syntax #f (syntax->list #'(i ...)))
closes 'contract))]
[(code:line i ...)
(loop (datum->syntax-object #f (syntax->list #'(i ...)))
closes 'line)]
(loop (datum->syntax #f (syntax->list #'(i ...))
(syntax-case stx ()
[(_ a . b)
(let ([src (syntax-source stx)]
[line (syntax-line stx)]
[col (syntax-column stx)]
[pos (syntax-position stx)]
[span (syntax-span stx)]
[a-pos (syntax-position #'a)])
(if (and pos a-pos (a-pos . > . pos))
(vector src
line
(and col (+ col (- a-pos pos)))
a-pos
(and span (max 0 (- span (- a-pos pos)))))
stx))]
[else stx]))
closes 'line)]
[(code:comment s ...)
(apply htl-append
(color-semi-p)
@ -444,6 +462,44 @@
(syntax->list #'(s ...))))]
[(code:template i ...)
(add-semis (loop #'(code:line i ...) closes 'template))]
[(a b i ... c)
(let ([pos (for/fold ([pos (syntax-position #'b)]) ([i (in-list (syntax->list #'(i ... c)))])
(and pos
((syntax-position i) . > . pos)
(syntax-position i)))])
(and pos
((syntax-position #'a) . > . (syntax-position #'b))
((syntax-position #'a) . < . (syntax-position #'c))))
;; position of `a' is after `b', while everything else is in
;; order, so print as infix-dot notation
(loop
(datum->syntax
stx
(cons #'b
(let loop ([l (syntax->list #'(i ... c))])
(cond
[((syntax-position #'a) . < . (syntax-position (car l)))
(let ([src (syntax-source #'a)]
[pos (syntax-position #'a)]
[line (syntax-line #'a)]
[col (syntax-column #'a)]
[span (syntax-span #'a)])
(list* (datum->syntax #f '|.|
(vector src line
(and col (max 0 (- col 2)))
(max 1 (- pos 2))
1))
#'a
(datum->syntax #f '|.|
(vector src line
(and col (+ col 1 span))
(+ pos 1 span)
1))
l))]
[else (cons (car l) (loop (cdr l)))])))
stx)
closes
mode)]
[(i ...)
(let ([is (syntax->list #'(i ...))])
;; Convert each i to a picture, include close paren in last item:
@ -470,7 +526,7 @@
[col (+ left 1)]
[line (syntax-line stx)]
[always-space? #f]
[col->width (make-hash-table 'equal)])
[col->width (make-hash)])
(cond
[(null? ps) (blank)]
[(or (not line)
@ -483,9 +539,9 @@
line-so-far
(pad-left space (car ps)))])
(unless (equal? +inf.0 (+ space col))
(hash-table-put! col->width
(+ space col)
(pict-width (code-htl-append line-so-far (pad-left space (blank))))))
(hash-set! col->width
(+ space col)
(pict-width (code-htl-append line-so-far (pad-left space (blank))))))
(if (null? (cdr stxs))
p
(loop (cdr stxs)
@ -506,10 +562,10 @@
[p
(let/ec k
(code-htl-append
(blank (hash-table-get col->width
(+ space left)
(lambda ()
(k (pad-left space (car ps)))))
(blank (hash-ref col->width
(+ space left)
(lambda ()
(k (pad-left space (car ps)))))
0)
(car ps)))])
(if (null? (cdr stxs))
@ -520,9 +576,9 @@
(+ left space (get-span (car stxs)))
(or (syntax-line (car stxs)) (add1 line))
#t
(let ([ht (make-hash-table 'equal)]
[v (hash-table-get col->width (+ space left) #f)])
(when v (hash-table-put! ht (+ space left) v))
(let ([ht (make-hash)]
[v (hash-ref col->width (+ space left) #f)])
(when v (hash-set! ht (+ space left) v))
ht)))))])))))]
[id
(identifier? stx)
@ -535,17 +591,17 @@
(let ([p (let loop ([a (syntax-e stx)])
(cond
[(pair? a) (cons (car a) (loop (cdr a)))]
[else (list (datum->syntax-object #f
(mode-colorize mode #f dot-p)
(list (syntax-source a)
(syntax-line a)
(- (syntax-column a) 2)
(- (syntax-position a) 2)
1))
[else (list (datum->syntax #f
(mode-colorize mode #f dot-p)
(list (syntax-source a)
(syntax-line a)
(- (syntax-column a) 2)
(- (syntax-position a) 2)
1))
a)]))])
(loop (datum->syntax-object stx
p
stx)
(loop (datum->syntax stx
p
stx)
closes
mode))]
[else