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

Metafunctions now typeset their contracts as the first line

Browse Source 
This is a backwards incompatible change, but there is a keyword
argument to render-metafunction and render-metafunctions that
goes back to the old behavior
This commit is contained in:
Robby Findler 2014-06-12 02:14:06 -05:00
parent 445a5dca15
commit d067311cf7
6 changed files with 242 additions and 167 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
pkgs/redex-pkgs/redex-doc/redex/scribblings/ref.scrbl
View File

@ -2952,18 +2952,22 @@ other tools that combine @racketmodname[pict]s together.
} }
@deftogether[[ @deftogether[[
@defform[(render-metafunction metafunction-name)]{} @defform[(render-metafunction metafunction-name maybe-contract)]{}
@defform/none[#:literals (render-metafunction) @defform/none[#:literals (render-metafunction)
(render-metafunction metafunction-name filename)]{} (render-metafunction metafunction-name filename maybe-contract)]{}
@defform[(render-metafunctions metafunction-name ...)]{} @defform[(render-metafunctions metafunction-name ... maybe-filename maybe-contract)
@defform/none[#:literals (render-metafunctions) #:grammar ([maybe-filename (code:line) (code:line #:file filename)]
(render-metafunctions metafunction-name ... #:file filename)]{}]]{ [maybe-contract? (code:line) (code:line #:contract? bool-expr)])]{}]]{
Like @racket[render-reduction-relation] but for metafunctions. Like @racket[render-reduction-relation] but for metafunctions.
Similarly, @racket[render-metafunctions] accepts multiple Similarly, @racket[render-metafunctions] accepts multiple
metafunctions and renders them together, lining up all of the metafunctions and renders them together, lining up all of the
clauses together. clauses together.
If the metafunctions have contracts, they are typeset as the first
lines of the output, unless the expression following @racket[#:contract?]
evaluates to @racket[#f].
This function sets @racket[dc-for-text-size]. See also This function sets @racket[dc-for-text-size]. See also
@racket[metafunction->pict] and @racket[metafunction->pict] and
@racket[metafunctions->pict]. @racket[metafunctions->pict].
@ -3146,10 +3150,10 @@ precede ellipses that represent argument sequences; when it is
are rendered on two lines and which are rendered on one. are rendered on two lines and which are rendered on one.
If its value is a list, the length of the list must match If its value is a list, the length of the list must match
the number of cases and each boolean indicates if that the number of cases plus one if there is a contract.
case has a linebreak or not. Each boolean indicates if that case has a linebreak or not.
This influences the @racket['left/right] styles only. This parameter's value influences the @racket['left/right] styles only.
} }
@defparam[metafunction-cases @defparam[metafunction-cases

9
pkgs/redex-pkgs/redex-lib/redex/private/judgment-form.rkt
View File

@ -407,7 +407,7 @@
(begin (begin
(unless (identifier? #'lang) (unless (identifier? #'lang)
(raise-syntax-error #f "expected an identifier in the language position" stx #'lang)) (raise-syntax-error #f "expected an identifier in the language position" stx #'lang))
(define-values (contract-name dom-ctcs codom-contracts pats) (define-values (contract-name dom-ctcs pre-condition codom-contracts pats)
(split-out-contract stx (syntax-e #'def-form-id) #'body #t)) (split-out-contract stx (syntax-e #'def-form-id) #'body #t))
(with-syntax* ([((name trms ...) rest ...) (car pats)] (with-syntax* ([((name trms ...) rest ...) (car pats)]
[(mode-stx ...) #`(#:mode (name I))] [(mode-stx ...) #`(#:mode (name I))]
@ -425,7 +425,7 @@
;; initial test determines if a contract is specified or not ;; initial test determines if a contract is specified or not
(cond (cond
[(pair? (syntax-e (car (syntax->list rest)))) [(pair? (syntax-e (car (syntax->list rest))))
(values #f #f (list #'any) (check-clauses stx syn-error-name (syntax->list rest) relation?))] (values #f #f #f (list #'any) (check-clauses stx syn-error-name (syntax->list rest) relation?))]
[else [else
(syntax-case rest () (syntax-case rest ()
[(id separator more ...) [(id separator more ...)
@ -438,7 +438,7 @@
(raise-syntax-error syn-error-name (raise-syntax-error syn-error-name
"expected clause definitions to follow domain contract" "expected clause definitions to follow domain contract"
stx)) stx))
(values #'id contract (list #'any) (check-clauses stx syn-error-name clauses #t)))] (values #'id contract #f (list #'any) (check-clauses stx syn-error-name clauses #t)))]
[else [else
(unless (eq? ': (syntax-e #'separator)) (unless (eq? ': (syntax-e #'separator))
(raise-syntax-error syn-error-name "expected a colon to follow the meta-function's name" stx #'separator)) (raise-syntax-error syn-error-name "expected a colon to follow the meta-function's name" stx #'separator))
@ -482,9 +482,8 @@
(let ([doms (reverse dom-pats)] (let ([doms (reverse dom-pats)]
[clauses (check-clauses stx syn-error-name raw-clauses relation?)]) [clauses (check-clauses stx syn-error-name raw-clauses relation?)])
(values #'id (values #'id
(if relation?
doms doms
#`(side-condition #,doms (term #,pre-condition))) (if relation? #f pre-condition)
(reverse rev-codomains) (reverse rev-codomains)
clauses))] clauses))]
[else [else

25
pkgs/redex-pkgs/redex-lib/redex/private/reduction-semantics.rkt
View File

@ -1187,7 +1187,7 @@
prev-metafunction prev-metafunction
(λ () (λ ()
(raise-syntax-error syn-error-name "expected a previously defined metafunction" orig-stx prev-metafunction)))) (raise-syntax-error syn-error-name "expected a previously defined metafunction" orig-stx prev-metafunction))))
(let*-values ([(contract-name dom-ctcs codom-contracts pats) (let*-values ([(contract-name dom-ctcs pre-condition codom-contracts pats)
(split-out-contract orig-stx syn-error-name #'rest #f)] (split-out-contract orig-stx syn-error-name #'rest #f)]
[(name _) (defined-name (list contract-name) pats orig-stx)]) [(name _) (defined-name (list contract-name) pats orig-stx)])
(when (and prev-metafunction (eq? (syntax-e #'name) (syntax-e prev-metafunction))) (when (and prev-metafunction (eq? (syntax-e #'name) (syntax-e prev-metafunction)))
@ -1208,6 +1208,7 @@
name name
name-predicate name-predicate
#,dom-ctcs #,dom-ctcs
#,pre-condition
#,codom-contracts #,codom-contracts
#,pats #,pats
#,syn-error-name)) #,syn-error-name))
@ -1251,9 +1252,13 @@
(define-syntax (generate-metafunction stx) (define-syntax (generate-metafunction stx)
(syntax-case stx () (syntax-case stx ()
[(_ orig-stx lang prev-metafunction name name-predicate dom-ctcs codom-contracts pats syn-error-name) [(_ orig-stx lang prev-metafunction
name name-predicate
dom-ctcs pre-condition
codom-contracts pats syn-error-name)
(let ([prev-metafunction (and (syntax-e #'prev-metafunction) #'prev-metafunction)] (let ([prev-metafunction (and (syntax-e #'prev-metafunction) #'prev-metafunction)]
[dom-ctcs (syntax-e #'dom-ctcs)] [dom-ctcs (syntax-e #'dom-ctcs)]
[pre-condition (syntax-e #'pre-condition)]
[codom-contracts (syntax-e #'codom-contracts)] [codom-contracts (syntax-e #'codom-contracts)]
[pats (syntax-e #'pats)] [pats (syntax-e #'pats)]
[syn-error-name (syntax-e #'syn-error-name)]) [syn-error-name (syntax-e #'syn-error-name)])
@ -1323,7 +1328,7 @@
#'lang #'lang
syn-error-name syn-error-name
#f #f
dom-ctcs) #`(side-condition #,dom-ctcs (term #,pre-condition)))
#'((void) any () ()))] #'((void) any () ()))]
[((codom-syncheck-expr codom-side-conditions-rewritten codom-names codom-names/ellipses) ...) [((codom-syncheck-expr codom-side-conditions-rewritten codom-names codom-names/ellipses) ...)
(map (λ (codom-contract) (map (λ (codom-contract)
@ -1369,7 +1374,6 @@
#,(if prev-metafunction #,(if prev-metafunction
#`(metafunc-proc-cases #,(term-fn-get-id (syntax-local-value prev-metafunction))) #`(metafunc-proc-cases #,(term-fn-get-id (syntax-local-value prev-metafunction)))
#'null)]) #'null)])
(build-metafunction (build-metafunction
lang lang
cases cases
@ -1378,12 +1382,23 @@
(make-metafunc-proc (make-metafunc-proc
(let ([name (lambda (x) (f/dom x))]) name) (let ([name (lambda (x) (f/dom x))]) name)
'(clause-name ...) '(clause-name ...)
(list
;; mf contract
#,(if (and dom-ctcs codom-contracts)
#`(list
#,(with-syntax ([(dom-ctc ...) dom-ctcs])
#`(list (to-lw dom-ctc) ...))
#,(with-syntax ([(codom-ctc ...) codom-contracts])
#`(list (to-lw codom-ctc) ...)))
#'#f)
;; body of mf
(generate-lws #f (generate-lws #f
(lhs ...) (lhs ...)
(lhs-for-lw ...) (lhs-for-lw ...)
((stuff ...) ...) ((stuff ...) ...)
(rhs ...) (rhs ...)
#t) #t))
lang lang
#t ;; multi-args? #t ;; multi-args?
'name 'name

224
pkgs/redex-pkgs/redex-pict-lib/redex/private/pict.rkt
View File

@ -5,7 +5,7 @@
racket/match racket/match
racket/pretty racket/pretty
racket/set racket/set
(only-in racket/list drop-right last partition) (only-in racket/list drop-right last partition add-between)
texpict/mrpict texpict/mrpict
texpict/utils texpict/utils
@ -21,7 +21,8 @@
(prefix-in lw/rt: redex/private/loc-wrapper-rt)) (prefix-in lw/rt: redex/private/loc-wrapper-rt))
(require (for-syntax racket/base (require (for-syntax racket/base
redex/private/term-fn)) redex/private/term-fn
syntax/parse))
(provide render-term (provide render-term
term->pict term->pict
@ -261,7 +262,6 @@
(apply (apply
vl-append vl-append
(add-between (add-between
(blank 0 (reduction-relation-rule-separation))
(map (λ (rp) (map (λ (rp)
(side-condition-combiner (side-condition-combiner
(vl-append (vl-append
@ -274,7 +274,8 @@
(rp->pict-label rp))) (rp->pict-label rp)))
(rule-pict-rhs rp)) (rule-pict-rhs rp))
(rp->side-condition-pict rp +inf.0))) (rp->side-condition-pict rp +inf.0)))
rps)))))) rps)
(blank 0 (reduction-relation-rule-separation)))))))
(define compact-vertical-min-width (make-parameter 0)) (define compact-vertical-min-width (make-parameter 0))
@ -352,14 +353,14 @@
(apply (apply
hbl-append hbl-append
(add-between (add-between
(basic-text ", " (default-style)) fresh-vars
fresh-vars)) (basic-text ", " (default-style))))
(basic-text " fresh" (default-style)))))] (basic-text " fresh" (default-style)))))]
[lst (add-between [lst (add-between
'comma
(append (append
pattern-binds/sc pattern-binds/sc
frsh))]) frsh)
'comma)])
(if (null? lst) (if (null? lst)
(blank) (blank)
(let ([where ((where-make-prefix-pict))]) (let ([where ((where-make-prefix-pict))])
@ -414,14 +415,6 @@
label label
((current-text) "]" (label-style) (label-font-size)))) ((current-text) "]" (label-style) (label-font-size))))
(define (add-between i l)
(cond
[(null? l) l]
[else
(cons (car l)
(apply append
(map (λ (x) (list i x)) (cdr l))))]))
(define (make-horiz-space picts) (blank (pict-width (apply cc-superimpose picts)) 0)) (define (make-horiz-space picts) (blank (pict-width (apply cc-superimpose picts)) 0))
(define rule-pict-style (make-parameter 'vertical)) (define rule-pict-style (make-parameter 'vertical))
@ -773,11 +766,11 @@
#'(metafunctions->pict name)])) #'(metafunctions->pict name)]))
(define-syntax (metafunctions->pict stx) (define-syntax (metafunctions->pict stx)
(syntax-case stx () (syntax-parse stx
[(_ name1 name2 ...) [(_ name1:id name2:id ... (~optional (~seq #:contract? contract-e:expr) #:defaults ([contract-e #'#t])))
(and (identifier? #'name1) #'(metafunctions->pict/proc (list (metafunction name1) (metafunction name2) ...)
(andmap identifier? (syntax->list #'(name2 ...)))) contract-e
#'(metafunctions->pict/proc (list (metafunction name1) (metafunction name2) ...) 'metafunctions->pict)])) 'metafunctions->pict)]))
(define-syntax (relation->pict stx) (define-syntax (relation->pict stx)
(syntax-case stx () (syntax-case stx ()
@ -786,24 +779,39 @@
#'(inference-rules-pict/relation 'form (metafunction name1))])) #'(inference-rules-pict/relation 'form (metafunction name1))]))
(define-syntax (render-metafunctions stx) (define-syntax (render-metafunctions stx)
(syntax-case stx () (syntax-parse stx
[(_ name1 name2 ...) [(_ name1:id name2:id ... (~seq k:keyword e:expr) ...)
(and (identifier? #'name) (define filename #'#f)
(andmap identifier? (syntax->list #'(name2 ...)))) (define contract? #'#t)
#'(render-metafunction/proc (list (metafunction name1) (metafunction name2) ...) #f 'render-metafunctions)] (for ([kwd (in-list (syntax->list #'(k ...)))]
[(_ name1 name2 ... #:file filename) [e (in-list (syntax->list #'(e ...)))])
(and (identifier? #'name1) (cond
(andmap identifier? (syntax->list #'(name2 ...)))) [(equal? '#:filename (syntax-e kwd))
#'(render-metafunction/proc (list (metafunction name1) (metafunction name2) ...) filename 'render-metafunctions)])) (set! filename e)]
[(equal? '#:contract? (syntax-e kwd))
(set! contract? e)]
[else
(raise-syntax-error #f "unexpected keyword" stx kwd)]))
#`(render-metafunction/proc
(list (metafunction name1) (metafunction name2) ...)
#,contract?
#,filename
'render-metafunctions)]))
(define-syntax (render-metafunction stx) (define-syntax (render-metafunction stx)
(syntax-case stx () (syntax-parse stx
[(_ name) [(_ name:id
(identifier? #'name) (~optional file:expr #:defaults ([file #'#f]))
#'(render-metafunction/proc (list (metafunction name)) #f 'render-metafunction)] (~optional (~seq k:keyword e:expr)))
[(_ name file) #`(render-metafunction/proc (list (metafunction name))
(identifier? #'name) #,(cond
#'(render-metafunction/proc (list (metafunction name)) file 'render-metafunction)])) [(not (attribute k)) #'#f]
[(and (equal? (syntax-e (attribute k)) '#:contract?))
#'e]
[else
(raise-syntax-error #f "unknown keyword" stx #'k)])
file
'render-metafunction)]))
(define-syntax (render-relation stx) (define-syntax (render-relation stx)
(syntax-case stx () (syntax-case stx ()
@ -814,7 +822,7 @@
(define metafunction-pict-style (make-parameter 'left-right)) (define metafunction-pict-style (make-parameter 'left-right))
(define metafunction-cases (make-parameter #f)) (define metafunction-cases (make-parameter #f))
(define (select-mf-cases eqns case-labelss) (define (select-mf-cases contracts eqns case-labelss)
(define mf-cases (metafunction-cases)) (define mf-cases (metafunction-cases))
(cond (cond
[mf-cases [mf-cases
@ -824,9 +832,12 @@
(apply (apply
append append
(for/list ([eqns (in-list eqns)] (for/list ([eqns (in-list eqns)]
[contract (in-list contracts)]
[case-labels (in-list case-labelss)]) [case-labels (in-list case-labelss)])
(filter (filter
values values
(cons
contract
(for/list ([eqn (in-list eqns)] (for/list ([eqn (in-list eqns)]
[case-label (in-list case-labels)]) [case-label (in-list case-labels)])
(begin0 (begin0
@ -837,8 +848,13 @@
[(set-member? named-cases case-label) [(set-member? named-cases case-label)
eqn] eqn]
[else #f]) [else #f])
(set! i (+ i 1)))))))] (set! i (+ i 1))))))))]
[else (apply append eqns)])) [else (apply append
(for/list ([eqns (in-list eqns)]
[contract (in-list contracts)])
(if contract
(cons contract eqns)
eqns)))]))
(define judgment-form-cases (make-parameter #f)) (define judgment-form-cases (make-parameter #f))
(define (select-jf-cases eqns conclusions eqn-names) (define (select-jf-cases eqns conclusions eqn-names)
@ -877,8 +893,8 @@
[else [else
(cons (car l) (loop (cdr l)))]))) (cons (car l) (loop (cdr l)))])))
(define (metafunctions->pict/proc mfs name) (define (metafunctions->pict/proc mfs contract? name)
(unless (andmap (λ (mf) (eq? (metafunc-proc-lang (metafunction-proc (car mfs))) (unless (andmap (λ (mf) (equal? (metafunc-proc-lang (metafunction-proc (car mfs)))
(metafunc-proc-lang (metafunction-proc mf)))) (metafunc-proc-lang (metafunction-proc mf))))
mfs) mfs)
(error name "expected metafunctions that are all drawn from the same language")) (error name "expected metafunctions that are all drawn from the same language"))
@ -887,22 +903,39 @@
(define sep 2) (define sep 2)
(define style (metafunction-pict-style)) (define style (metafunction-pict-style))
(define (wrapper->pict lw) (lw->pict all-nts lw)) (define (wrapper->pict lw) (lw->pict all-nts lw))
(define all-eqns (map (λ (mf) (metafunc-proc-pict-info (metafunction-proc mf))) mfs)) (define contracts (for/list ([mf (in-list mfs)])
(define lws (list-ref (metafunc-proc-pict-info (metafunction-proc mf)) 0))
(cond
[(and contract? lws)
(define doms (list-ref lws 0))
(define rngs (list-ref lws 1))
(render-metafunction-contract
(metafunc-proc-lang (metafunction-proc mf))
(metafunc-proc-name (metafunction-proc mf))
doms
rngs)]
[else #f])))
(define all-eqns (map (λ (mf) (list-ref (metafunc-proc-pict-info (metafunction-proc mf)) 1)) mfs))
(define all-lhss (define all-lhss
(map (λ (mf) (for/list ([mf (in-list mfs)])
(map (lambda (eqn) (for/list ([eqn (in-list (list-ref (metafunc-proc-pict-info (metafunction-proc mf)) 1))])
(wrapper->pict (wrapper->pict
(metafunction-call (metafunc-proc-name (metafunction-proc mf)) (metafunction-call (metafunc-proc-name (metafunction-proc mf))
(list-ref eqn 0)))) (list-ref eqn 0))))))
(metafunc-proc-pict-info (metafunction-proc mf))))
mfs))
(define case-labels (map (λ (mf) (metafunc-proc-clause-names (metafunction-proc mf))) mfs)) (define case-labels (map (λ (mf) (metafunc-proc-clause-names (metafunction-proc mf))) mfs))
(define eqns (select-mf-cases all-eqns case-labels)) (define eqns (select-mf-cases contracts all-eqns case-labels))
(define lhss (select-mf-cases all-lhss case-labels)) (define lhs/contracts (select-mf-cases contracts all-lhss case-labels))
(define rhss (map (lambda (eqn) (wrapper->pict (list-ref eqn 2))) eqns)) (define rhss (for/list ([eqn/contract (in-list eqns)])
(if (pict? eqn/contract)
'contract
(wrapper->pict (list-ref eqn/contract 2)))))
(unless (or (not current-linebreaks) (unless (or (not current-linebreaks)
(= (length current-linebreaks) (length eqns))) (= (length current-linebreaks) (length eqns)))
(error 'metafunction->pict "expected the current-linebreaks parameter to be a list whose length matches the number of cases in the metafunction (~a), but got ~s" (error 'metafunction->pict
(string-append
"expected the current-linebreaks parameter to be a list"
" whose length matches the number of cases in the metafunction"
" plus one if there is a contract (~a), but got ~s")
(length eqns) (length eqns)
current-linebreaks)) current-linebreaks))
(define linebreak-list (or current-linebreaks (define linebreak-list (or current-linebreaks
@ -923,26 +956,36 @@
left-right*/compact-side-conditions))) left-right*/compact-side-conditions)))
(define max-line-w/pre-sc (and (define max-line-w/pre-sc (and
compact-side-conditions? compact-side-conditions?
(apply (for/fold ([biggest 0]) ([lhs/contract (in-list lhs/contracts)]
max [rhs (in-list rhss)]
(map (lambda (lhs rhs linebreak?) [linebreak? (in-list linebreak-list)])
(cond (cond
[(equal? rhs 'contract)
;; this is a contract
(max biggest (pict-width lhs/contract))]
[(eq? mode 'vertical) [(eq? mode 'vertical)
(max (+ (pict-width lhs) (pict-width =-pict)) (max biggest
(+ (pict-width lhs/contract) (pict-width =-pict))
(pict-width rhs))] (pict-width rhs))]
[linebreak? [linebreak?
(max (pict-width lhs) (max biggest
(pict-width lhs/contract)
(+ (pict-width rhs) sep (pict-width =-pict)))] (+ (pict-width rhs) sep (pict-width =-pict)))]
[else [else
(+ (pict-width lhs) (pict-width rhs) (pict-width =-pict) (max biggest
(* 2 sep))])) (+ (pict-width lhs/contract) (pict-width rhs) (pict-width =-pict)
lhss rhss linebreak-list)))) (* 2 sep)))]))))
(define scs (for/list ([eqn (in-list eqns)]) (define scs (for/list ([eqn (in-list eqns)])
(let ([scs (reverse (list-ref eqn 1))]) (cond
(if (null? scs) [(pict? eqn) #f]
#f [else
(let-values ([(fresh where/sc) (partition metafunc-extra-fresh? scs)]) (define scs (reverse (list-ref eqn 1)))
(side-condition-pict (foldl (λ (clause picts) (cond
[(null? scs) #f]
[else
(define-values (fresh where/sc) (partition metafunc-extra-fresh? scs))
(side-condition-pict
(foldl (λ (clause picts)
(foldr (λ (l ps) (cons (wrapper->pict l) ps)) (foldr (λ (l ps) (cons (wrapper->pict l) ps))
picts (metafunc-extra-fresh-vars clause))) picts (metafunc-extra-fresh-vars clause)))
'() fresh) '() fresh)
@ -961,7 +1004,7 @@
max-line-w/pre-sc] max-line-w/pre-sc]
[else [else
;; no line breaks: ;; no line breaks:
+inf.0]))))))) +inf.0]))])])))
(case mode (case mode
[(horizontal) [(horizontal)
(define (adjust-for-fills rows) (define (adjust-for-fills rows)
@ -1000,16 +1043,21 @@
(table 3 (table 3
(adjust-for-fills (adjust-for-fills
(apply append (apply append
(map (lambda (lhs sc rhs linebreak?) (for/list ([lhs/contract (in-list lhs/contracts)]
[sc (in-list scs)]
[rhs (in-list rhss)]
[linebreak? (in-list linebreak-list)])
(append (append
(list (list
(cond (cond
[(equal? rhs 'contract) ;; contract
(list lhs/contract 'fill 'fill)]
[linebreak? [linebreak?
(list lhs 'fill 'fill)] (list lhs/contract 'fill 'fill)]
[(and sc (eq? style 'left-right/beside-side-conditions)) [(and sc (eq? style 'left-right/beside-side-conditions))
(list lhs =-pict (htl-append 10 rhs sc))] (list lhs/contract =-pict (htl-append 10 rhs sc))]
[else [else
(list lhs =-pict rhs)])) (list lhs/contract =-pict rhs)]))
(if linebreak? (if linebreak?
(list (list
(list (htl-append sep =-pict rhs) (list (htl-append sep =-pict rhs)
@ -1021,26 +1069,34 @@
(eq? style 'left-right/beside-side-conditions))) (eq? style 'left-right/beside-side-conditions)))
null null
(list (list
(list sc 'fill 'fill))))) (list sc 'fill 'fill)))))))
lhss
scs
rhss
linebreak-list)))
ltl-superimpose ltl-superimpose ltl-superimpose ltl-superimpose
sep sep)] sep sep)]
[(vertical) [(vertical)
(apply vl-append (apply vl-append
sep sep
(apply append (apply append
(map (lambda (lhs sc rhs) (for/list ([lhs/contract (in-list lhs/contracts)]
[sc (in-list scs)]
[rhs (in-list rhss)])
(cond
[(equal? rhs 'contract) ;; contract
(list lhs/contract)]
[else
(cons (cons
(vl-append (htl-append lhs =-pict) rhs) (vl-append (htl-append lhs/contract =-pict) rhs)
(if (not sc) (if (not sc)
null null
(list sc)))) (list sc)))]))))]))
lhss
scs (define (render-metafunction-contract lang name doms rngs)
rhss)))])) (hbl-append (basic-text (format "~a" name) (metafunction-style))
(basic-text " : " (default-style))
(apply hbl-append (add-between (map (λ (x) (lw->pict lang x)) doms)
(basic-text " " (default-style))))
(basic-text " → " (default-style))
(apply hbl-append (add-between (map (λ (x) (lw->pict lang x)) rngs)
(basic-text " " (default-style))))))
(define (metafunction-call name an-lw) (define (metafunction-call name an-lw)
(struct-copy lw an-lw (struct-copy lw an-lw
@ -1122,14 +1178,14 @@
(basic-text "]" (default-style)))])] (basic-text "]" (default-style)))])]
[else x])) [else x]))
(define (render-metafunction/proc mfs filename name) (define (render-metafunction/proc mfs contract? filename name)
(cond (cond
[filename [filename
(save-as-ps/pdf (λ () (metafunctions->pict/proc mfs name)) (save-as-ps/pdf (λ () (metafunctions->pict/proc mfs contract? name))
filename)] filename)]
[else [else
(parameterize ([dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1))]) (parameterize ([dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1))])
(metafunctions->pict/proc mfs name))])) (metafunctions->pict/proc mfs contract? name))]))
(define (render-pict make-pict filename) (define (render-pict make-pict filename)
(cond (cond

1
pkgs/redex-pkgs/redex-test/redex/tests/bitmap-test.rkt
View File

@ -96,6 +96,7 @@
"red-with-where-name.png")) "red-with-where-name.png"))
(define-metafunction lang (define-metafunction lang
S : x v e -> e
[(S x v e) e]) [(S x v e) e])
(btest (render-metafunction S) (btest (render-metafunction S)

BIN
pkgs/redex-pkgs/redex-test/redex/tests/bmps-macosx/metafunctions-multiple.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 15 KiB

After

Width:  |  Height:  |  Size: 16 KiB