diff --git a/collects/redex/pict.rkt b/collects/redex/pict.rkt index 6bc6a914ba..367227779b 100644 --- a/collects/redex/pict.rkt +++ b/collects/redex/pict.rkt @@ -77,7 +77,9 @@ [white-bracket-sizing (parameter/c (-> string? number? (values number? number? number? number?)))] [horizontal-bar-spacing (parameter/c exact-nonnegative-integer?)] - [relation-clauses-combine (parameter/c (-> (listof pict?) pict?))]) + [relation-clauses-combine (parameter/c (-> (listof pict?) pict?))] + [where-make-prefix-pict (parameter/c (-> pict?))] + [where-combine (parameter/c (-> pict? pict? pict?))]) (provide/contract [rule-pict-style diff --git a/collects/redex/private/pict.rkt b/collects/redex/private/pict.rkt index 119482d543..ac9fdfad77 100644 --- a/collects/redex/private/pict.rkt +++ b/collects/redex/private/pict.rkt @@ -63,6 +63,9 @@ default-font-size metafunction-font-size reduction-relation-rule-separation + + where-make-prefix-pict + where-combine just-before just-after @@ -352,7 +355,7 @@ frsh))]) (if (null? lst) (blank) - (let ([where (basic-text " where " (default-style))]) + (let ([where ((where-make-prefix-pict))]) (let ([max-w (- max-w (pict-width where))]) (htl-append where (let loop ([p (car lst)][lst (cdr lst)]) @@ -366,8 +369,16 @@ (loop (car lst) (cdr lst)))] [else (loop (htl-append p (car lst)) (cdr lst))])))))))) +(define where-make-prefix-pict + (make-parameter (lambda () + (basic-text " where " (default-style))))) + (define (where-pict lhs rhs) - (htl-append lhs (make-=) rhs)) + ((where-combine) lhs rhs)) + +(define where-combine + (make-parameter (lambda (lhs rhs) + (htl-append lhs (make-=) rhs)))) (define (rp->side-condition-pict rp max-w) (side-condition-pict (rule-pict-fresh-vars rp) diff --git a/collects/redex/scribblings/ref.scrbl b/collects/redex/scribblings/ref.scrbl index 8473a06e58..6585b8861e 100644 --- a/collects/redex/scribblings/ref.scrbl +++ b/collects/redex/scribblings/ref.scrbl @@ -11,7 +11,7 @@ mrlib/graph (except-in 2htdp/image make-pen text) (only-in pict pict? text dc-for-text-size text-style/c - vc-append) + vc-append hbl-append) redex)) @(define-syntax (defpattech stx) @@ -3045,11 +3045,24 @@ single reduction relation. } @defparam[relation-clauses-combine combine (parameter/c (-> (listof pict?) pict?))]{ - @racket[combine] is called with the list of picts that are obtained by rendering + The @racket[combine] function is called with the list of picts that are obtained by rendering a relation; it should put them together into a single pict. It defaults to @racket[(λ (l) (apply vc-append 20 l))] } +@defparam[where-make-prefix-pict make-prefix (parameter/c (-> pict?))]{ + The @racket[make-prefix] function is called with no arguments to generate a pict + that prefixes @tech{@racket[where] clauses}. It defaults to a function that + produces a pict for ``where'' surrounded by spaces using the default style. +} + +@defparam[where-combine combine (parameter/c (-> pict? pict? pict?))]{ + The @racket[combine] function is called with picts for the left and right + side of a where clause, and it should put them together into a single pict. It defaults to + @racket[(λ (l r) (hbl-append l _=-pict r))], where @racket[_=-pict] is an equal + sign surrounded by spaces using the default style. +} + @subsection[#:tag "pink"]{Removing the Pink Background} @declare-exporting[redex/pict redex] diff --git a/doc/release-notes/redex/HISTORY.txt b/doc/release-notes/redex/HISTORY.txt index 48f82f706b..ff0440f864 100644 --- a/doc/release-notes/redex/HISTORY.txt +++ b/doc/release-notes/redex/HISTORY.txt @@ -1,3 +1,8 @@ +v5.3.4.11 + + * added where-make-prefix-pict and where-combine parameters. + + v5.3.4 * adjusted define-union-language to allow the unioned languages to