suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

fix typesetting for curried procedures

Browse Source 
The indentation for multi-line typesetting is weird, because it still
uses the table-basd layout that lines up all arguments independent of
nesting. But at least the parentheses are not broken.

Relevant to #211
This commit is contained in:
Matthew Flatt 2019-09-21 17:53:42 -06:00
parent d9b6f0eab2
commit 50862d0132
1 changed files with 35 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
scribble-lib/scribble/private/manual-proc.rkt
View File

@ -40,7 +40,7 @@
(case n [(1) "("] [(0) ""] [(2) "(("] [else (make-string n #\()]))) (case n [(1) "("] [(0) ""] [(2) "(("] [else (make-string n #\()])))
(define (make-closers n) (define (make-closers n)
(racketparenfont (racketparenfont
(case n [(1) ")"] [(0) ""] [(2) "))"] [else (make-string n #\()]))) (case n [(1) ")"] [(0) ""] [(2) "))"] [else (make-string n #\))])))
(define-syntax (arg-contract stx) (define-syntax (arg-contract stx)
(syntax-case stx (... ...+ _...superclass-args...) (syntax-case stx (... ...+ _...superclass-args...)
@ -207,13 +207,13 @@
(list (result-value value.value) ...)))))])) (list (result-value value.value) ...)))))]))
(define-struct arg (define-struct arg
(special? kw id optional? starts-optional? ends-optional? num-closers)) (special? kw id optional? starts-optional? ends-optional? depth))
(define (*defproc kind link? mode within-id (define (*defproc kind link? mode within-id
stx-ids sym prototypes arg-contractss arg-valss result-contracts content-thunk stx-ids sym prototypes arg-contractss arg-valss result-contracts content-thunk
[result-values (map (lambda (x) #f) result-contracts)]) [result-values (map (lambda (x) #f) result-contracts)])
(define max-proto-width (current-display-width)) (define max-proto-width (current-display-width))
(define ((arg->elem show-opt-start?) arg) (define ((arg->elem show-opt-start?) arg next-depth)
(let* ([e (cond [(not (arg-special? arg)) (let* ([e (cond [(not (arg-special? arg))
(if (arg-kw arg) (if (arg-kw arg)
(if (eq? mode 'new) (if (eq? mode 'new)
@ -235,10 +235,11 @@
[e (if (arg-ends-optional? arg) [e (if (arg-ends-optional? arg)
(make-element #f (list e "]")) (make-element #f (list e "]"))
e)] e)]
[e (if (zero? (arg-num-closers arg)) [num-closers (- (arg-depth arg) next-depth)]
[e (if (zero? num-closers)
e e
(make-element (make-element
#f (list e (make-closers (arg-num-closers arg)))))]) #f (list e (make-closers num-closers))))])
(if (and show-opt-start? (arg-starts-optional? arg)) (if (and show-opt-start? (arg-starts-optional? arg))
(make-element #f (list "[" e)) (make-element #f (list "[" e))
e))) e)))
@ -258,21 +259,23 @@
(not next-optional?) (not next-optional?)
(not next-special-dots?))) (not next-special-dots?)))
depth))) depth)))
(let loop ([p p] [last-depth 0]) (let loop ([p p] [depth 0])
(define head
(if (symbol? (car p))
null
(loop (car p) (add1 depth))))
(append (append
(if (symbol? (car p)) head
null (let loop ([p (cdr p)] [in-optional? #f])
(loop (car p) (add1 last-depth)))
(let loop ([p (cdr p)][in-optional? #f])
(cond (cond
[(null? p) null] [(null? p) null]
[(null? (cdr p)) [(null? (cdr p))
(list (parse-arg (car p) in-optional? last-depth #f #f))] (list (parse-arg (car p) in-optional? depth #f #f))]
[else [else
(let ([a (parse-arg (let ([a (parse-arg
(car p) (car p)
in-optional? in-optional?
0 depth
(let ([v (cadr p)]) (let ([v (cadr p)])
(and (pair? v) (and (pair? v)
(not (not
@ -282,6 +285,10 @@
(cons a (loop (cdr p) (cons a (loop (cdr p)
(and (arg-optional? a) (and (arg-optional? a)
(not (arg-ends-optional? a))))))]))))) (not (arg-ends-optional? a))))))])))))
(define (next-args-depth args)
(if (null? args)
0
(arg-depth (car args))))
(define (prototype-size args first-combine next-combine special-combine?) (define (prototype-size args first-combine next-combine special-combine?)
(let loop ([s args] [combine first-combine]) (let loop ([s args] [combine first-combine])
(if (null? s) (if (null? s)
@ -289,7 +296,7 @@
(combine (combine
(loop (cdr s) next-combine) (loop (cdr s) next-combine)
(let ([a (car s)]) (let ([a (car s)])
(+ (arg-num-closers a) (+ (- (arg-depth a) (next-args-depth (cdr s)))
(if (arg-special? a) (if (arg-special? a)
(string-length (symbol->string (arg-id a))) (string-length (symbol->string (arg-id a)))
(+ (if (arg-kw a) (+ (if (arg-kw a)
@ -468,11 +475,19 @@
#f #f
`(,(make-openers (add1 p-depth)) `(,(make-openers (add1 p-depth))
,tagged ,tagged
,(let ([num-closers (- p-depth (next-args-depth args))])
(if (zero? num-closers)
'()
(make-closers num-closers)))
,@(if (null? args) ,@(if (null? args)
(list (make-closers p-depth)) (list (make-closers p-depth))
(append-map (lambda (arg) (let loop ([args args])
(list spacer ((arg->elem #t) arg))) (cond
args)) [(null? args) null]
[else
(append
(list spacer ((arg->elem #t) (car args) (next-args-depth (cdr args))))
(loop (cdr args)))])))
,(racketparenfont ")")))) ,(racketparenfont ")"))))
(if result-next-line? null end)))) (if result-next-line? null end))))
;; The multi-line case: ;; The multi-line case:
@ -498,7 +513,7 @@
(if (arg-starts-optional? (car args)) (if (arg-starts-optional? (car args))
(to-flow (make-element #f (list spacer "["))) (to-flow (make-element #f (list spacer "[")))
flow-spacer) flow-spacer)
(to-flow ((arg->elem #f) (car args))) (to-flow ((arg->elem #f) (car args) (next-args-depth (cdr args))))
not-end) not-end)
(list* 'cont 'cont not-end))) (list* 'cont 'cont not-end)))
(let loop ([args (if one-ok? (cdr args) args)]) (let loop ([args (if one-ok? (cdr args) args)])
@ -517,12 +532,13 @@
(if (arg-starts-optional? (car args)) (if (arg-starts-optional? (car args))
(to-flow (make-element #f (list spacer "["))) (to-flow (make-element #f (list spacer "[")))
flow-spacer) flow-spacer)
(let ([a ((arg->elem #f) (car args))] (let ([a ((arg->elem #f) (car args) (next-args-depth (cdr args)))]
[next (if dots-next? [next (if dots-next?
(make-element (make-element
#f (list spacer #f (list spacer
((arg->elem #f) ((arg->elem #f)
(cadr args)))) (cadr args)
(next-args-depth (cddr args)))))
"")]) "")])
(to-flow (to-flow
(cond (cond