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

added names to clauses in define-judgment-form and added

Browse Source 
judgment-form-cases to use the names to control typesetting
This commit is contained in:
Robby Findler 2012-08-08 20:25:35 -05:00
parent a190ecfb7b
commit 0369342bfe
6 changed files with 154 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/redex/pict.rkt
View File

@ -83,6 +83,8 @@
[arrow-space (parameter/c natural-number/c)] [arrow-space (parameter/c natural-number/c)]
[label-space (parameter/c natural-number/c)] [label-space (parameter/c natural-number/c)]
[metafunction-cases (parameter/c (or/c #f (and/c pair? (listof (and/c integer? (or/c zero? positive?))))))] [metafunction-cases (parameter/c (or/c #f (and/c pair? (listof (and/c integer? (or/c zero? positive?))))))]
[judgment-form-cases (parameter/c (or/c #f (and/c (listof (or/c exact-nonnegative-integer? string?))
pair?)))]
[metafunction-pict-style [metafunction-pict-style
(parameter/c (symbols 'left-right (parameter/c (symbols 'left-right
'left-right/vertical-side-conditions 'left-right/vertical-side-conditions

52
collects/redex/private/judgment-form.rkt
View File

@ -337,12 +337,12 @@
(define-for-syntax (do-extended-judgment-form lang syn-err-name body orig stx) (define-for-syntax (do-extended-judgment-form lang syn-err-name body orig stx)
(define nts (definition-nts lang stx syn-err-name)) (define nts (definition-nts lang stx syn-err-name))
(define-values (judgment-form-name dup-form-names mode position-contracts clauses) (define-values (judgment-form-name dup-form-names mode position-contracts clauses rule-names)
(parse-judgment-form-body body syn-err-name stx (identifier? orig))) (parse-judgment-form-body body syn-err-name stx (identifier? orig)))
(define definitions (define definitions
#`(begin #`(begin
(define-syntax #,judgment-form-name (define-syntax #,judgment-form-name
(judgment-form '#,judgment-form-name '#,(cdr (syntax->datum mode)) #'judgment-form-runtime-proc #'mk-judgment-form-proc #'#,lang #'judgment-form-lws)) (judgment-form '#,judgment-form-name '#,(cdr (syntax->datum mode)) #'judgment-form-runtime-proc #'mk-judgment-form-proc #'#,lang #'judgment-form-lws '#,rule-names))
(define mk-judgment-form-proc (define mk-judgment-form-proc
(compile-judgment-form-proc #,judgment-form-name #,mode #,lang #,clauses #,position-contracts #,orig #,stx #,syn-err-name)) (compile-judgment-form-proc #,judgment-form-name #,mode #,lang #,clauses #,position-contracts #,orig #,stx #,syn-err-name))
(define judgment-form-runtime-proc (mk-judgment-form-proc #,lang)) (define judgment-form-runtime-proc (mk-judgment-form-proc #,lang))
@ -375,13 +375,29 @@
(regexp-match? #rx"^-+$" (symbol->string (syntax-e id)))) (regexp-match? #rx"^-+$" (symbol->string (syntax-e id))))
(define-syntax-class horizontal-line (define-syntax-class horizontal-line
(pattern x:id #:when (horizontal-line? #'x))) (pattern x:id #:when (horizontal-line? #'x)))
(define-syntax-class name
(pattern x #:when (string? (syntax-e #'x))))
(define (parse-rules rules) (define (parse-rules rules)
(for/list ([rule rules]) (define-values (backward-rules backward-names)
(syntax-parse rule (for/fold ([parsed-rules '()]
[(prem ... _:horizontal-line conc) [names '()])
#'(conc prem ...)] ([rule rules])
[_ rule]))) (syntax-parse rule
(define-values (name/mode mode-stx name/contract contract rules) [(prem ... _:horizontal-line n:name conc)
(values (cons #'(conc prem ...) parsed-rules)
(cons #'n names))]
[(prem ... _:horizontal-line conc)
(values (cons #'(conc prem ...) parsed-rules)
(cons #f names))]
[(conc prem ... n:name)
(values (cons #'(conc prem ...) parsed-rules)
(cons #'n names))]
[else
(values (cons rule parsed-rules)
(cons #f names))])))
(values (reverse backward-rules)
(reverse backward-names)))
(define-values (name/mode mode-stx name/contract contract rules rule-names)
(syntax-parse body #:context full-stx (syntax-parse body #:context full-stx
[((~or (~seq #:mode ~! mode:mode-spec) [((~or (~seq #:mode ~! mode:mode-spec)
(~seq #:contract ~! contract:contract-spec)) (~seq #:contract ~! contract:contract-spec))
@ -405,9 +421,10 @@
(raise-syntax-error (raise-syntax-error
syn-err-name "expected at most one contract specification" syn-err-name "expected at most one contract specification"
#f #f (syntax->list #'dups))])]) #f #f (syntax->list #'dups))])])
(values name/mode mode name/ctc ctc (define-values (parsed-rules rule-names) (parse-rules (syntax->list #'(rule ...))))
(parse-rules (syntax->list #'(rule ...)))))])) (values name/mode mode name/ctc ctc parsed-rules rule-names))]))
(check-clauses full-stx syn-err-name rules #t) (check-clauses full-stx syn-err-name rules #t)
(check-dup-rule-names full-stx syn-err-name rule-names)
(check-arity-consistency mode-stx contract full-stx) (check-arity-consistency mode-stx contract full-stx)
(define-values (form-name dup-names) (define-values (form-name dup-names)
(syntax-case rules () (syntax-case rules ()
@ -415,7 +432,20 @@
(not extension?) (not extension?)
(raise-syntax-error #f "expected at least one rule" full-stx)] (raise-syntax-error #f "expected at least one rule" full-stx)]
[_ (defined-name (list name/mode name/contract) rules full-stx)])) [_ (defined-name (list name/mode name/contract) rules full-stx)]))
(values form-name dup-names mode-stx contract rules)) (values form-name dup-names mode-stx contract rules rule-names))
;; names : (listof (or/c #f syntax[string]))
(define-for-syntax (check-dup-rule-names full-stx syn-err-name names)
(define tab (make-hash))
(for ([name (in-list names)])
(when (syntax? name)
(define k (syntax-e name))
(hash-set! tab k (cons name (hash-ref tab k '())))))
(for ([(k names) (in-hash tab)])
(unless (= 1 (length names))
(raise-syntax-error syn-err-name
"duplicate rule names"
(car names) #f (cdr names)))))
(define-for-syntax (check-arity-consistency mode-stx contracts full-def) (define-for-syntax (check-arity-consistency mode-stx contracts full-def)
(when (and contracts (not (= (length (cdr (syntax->datum mode-stx))) (when (and contracts (not (= (length (cdr (syntax->datum mode-stx)))

115
collects/redex/private/pict.rkt
View File

@ -62,6 +62,7 @@
label-space label-space
metafunction-pict-style metafunction-pict-style
metafunction-cases metafunction-cases
judgment-form-cases
compact-vertical-min-width compact-vertical-min-width
extend-language-show-union extend-language-show-union
set-arrow-pict! set-arrow-pict!
@ -360,23 +361,27 @@
max-w)) max-w))
(define (rp->pict-label rp) (define (rp->pict-label rp)
(define (bracket label)
(hbl-append
((current-text) " [" (label-style) (label-font-size))
label
((current-text) "]" (label-style) (label-font-size))))
(cond [(rule-pict-computed-label rp) => bracket] (cond [(rule-pict-computed-label rp) => bracket]
[(rule-pict-label rp) [(rule-pict-label rp)
(let ([m (regexp-match #rx"^([^_]*)(?:_([^_]*)|)$" (string->bracketed-label
(format "~a" (rule-pict-label rp)))]) (format "~a" (rule-pict-label rp)))]
(bracket
(hbl-append
((current-text) (cadr m) (label-style) (label-font-size))
(if (caddr m)
((current-text) (caddr m) `(subscript . ,(label-style)) (label-font-size))
(blank)))))]
[else (blank)])) [else (blank)]))
(define (string->bracketed-label str)
(define m (regexp-match #rx"^([^_]*)(?:_([^_]*)|)$" str))
(bracket
(hbl-append
((current-text) (cadr m) (label-style) (label-font-size))
(if (caddr m)
((current-text) (caddr m) `(subscript . ,(label-style)) (label-font-size))
(blank)))))
(define (bracket label)
(hbl-append
((current-text) " [" (label-style) (label-font-size))
label
((current-text) "]" (label-style) (label-font-size))))
(define (add-between i l) (define (add-between i l)
(cond (cond
[(null? l) l] [(null? l) l]
@ -774,7 +779,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-cases eqns) (define (select-mf-cases eqns)
(let ([cases (metafunction-cases)]) (let ([cases (metafunction-cases)])
(if cases (if cases
(let loop ([eqns eqns] (let loop ([eqns eqns]
@ -792,6 +797,31 @@
(loop (cdr eqns) cases (+ i 1))])])) (loop (cdr eqns) cases (+ i 1))])]))
eqns))) eqns)))
(define judgment-form-cases (make-parameter #f))
(define (select-jf-cases eqns conclusions eqn-names)
(define cases
(or (judgment-form-cases)
(metafunction-cases)))
(cond
[cases
(define-values (rev-eqns rev-concs rev-eqn-names)
(for/fold ([eqns '()]
[concs '()]
[eqn-names '()])
([eqn (in-list eqns)]
[conc (in-list conclusions)]
[eqn-name (in-list eqn-names)]
[i (in-naturals)])
(if (or (member i cases)
(member eqn-name cases))
(values (cons eqn eqns)
(cons conc concs)
(cons eqn-name eqn-names))
(values eqns concs eqn-names))))
(values (reverse rev-eqns) (reverse rev-concs) (reverse rev-eqn-names))]
[else
(values eqns conclusions eqn-names)]))
;; remove-dups : (listof number)[sorted] -> (listof number)[sorted] ;; remove-dups : (listof number)[sorted] -> (listof number)[sorted]
;; removes duplicate numbers from 'l' ;; removes duplicate numbers from 'l'
(define (remove-dups l) (define (remove-dups l)
@ -826,8 +856,8 @@
(list-ref eqn 0)))) (list-ref eqn 0))))
(metafunc-proc-pict-info (metafunction-proc mf)))) (metafunc-proc-pict-info (metafunction-proc mf))))
mfs))] mfs))]
[eqns (select-cases all-eqns)] [eqns (select-mf-cases all-eqns #f)]
[lhss (select-cases all-lhss)] [lhss (select-mf-cases all-lhss #f)]
[rhss (map (lambda (eqn) (wrapper->pict (list-ref eqn 2))) eqns)] [rhss (map (lambda (eqn) (wrapper->pict (list-ref eqn 2))) eqns)]
[_ (unless (or (not current-linebreaks) [_ (unless (or (not current-linebreaks)
(= (length current-linebreaks) (length eqns))) (= (length current-linebreaks) (length eqns)))
@ -1034,6 +1064,7 @@
(error form "expected relation as argument, got a metafunction")) (error form "expected relation as argument, got a metafunction"))
(inference-rules-pict (metafunc-proc-name (metafunction-proc mf)) (inference-rules-pict (metafunc-proc-name (metafunction-proc mf))
(metafunc-proc-pict-info (metafunction-proc mf)) (metafunc-proc-pict-info (metafunction-proc mf))
(map (λ (x) #f) (metafunc-proc-pict-info (metafunction-proc mf)))
(metafunc-proc-lang (metafunction-proc mf)))) (metafunc-proc-lang (metafunction-proc mf))))
(define (render-pict make-pict filename) (define (render-pict make-pict filename)
@ -1044,17 +1075,17 @@
(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))])
(make-pict))])) (make-pict))]))
(define (inference-rules-pict name all-eqns lang) (define (inference-rules-pict name all-eqns eqn-names lang)
(let* ([all-nts (language-nts lang)] (define all-nts (language-nts lang))
[wrapper->pict (lambda (lw) (lw->pict all-nts lw))] (define (wrapper->pict lw) (lw->pict all-nts lw))
[all-conclusions (define all-conclusions
(map (lambda (eqn) (map (lambda (eqn)
(wrapper->pict (wrapper->pict
(metafunction-call name (list-ref eqn 0)))) (metafunction-call name (list-ref eqn 0))))
all-eqns)] all-eqns))
[eqns (select-cases all-eqns)] (define-values (selected-eqns conclusions selected-eqn-names)
[conclusions (select-cases all-conclusions)] (select-jf-cases all-eqns all-conclusions eqn-names))
[premisess (map (lambda (eqn) (define premisess (map (lambda (eqn)
(append (map wrapper->pict (list-ref eqn 2)) (append (map wrapper->pict (list-ref eqn 2))
(map (match-lambda (map (match-lambda
[(struct metafunc-extra-where (lhs rhs)) [(struct metafunc-extra-where (lhs rhs))
@ -1063,18 +1094,29 @@
(wrapper->pict expr)] (wrapper->pict expr)]
[wrapper (wrapper->pict wrapper)]) [wrapper (wrapper->pict wrapper)])
(list-ref eqn 1)))) (list-ref eqn 1))))
eqns)]) selected-eqns))
((relation-clauses-combine) ((relation-clauses-combine)
(for/list ([conclusion (in-list conclusions)] (for/list ([conclusion (in-list conclusions)]
[premises (in-list premisess)]) [premises (in-list premisess)]
(define top (apply hbl-append 20 premises)) [name (in-list selected-eqn-names)])
(define line-w (max (pict-width top) (pict-width conclusion))) (define top (apply hbl-append 20 premises))
(define line-w (max (pict-width top) (pict-width conclusion)))
(define line (dc (λ (dc dx dy) (send dc draw-line dx dy (+ dx line-w) dy))
line-w 1))
(define w/out-label
(vc-append (vc-append
(horizontal-bar-spacing) (horizontal-bar-spacing)
top top
(dc (λ (dc dx dy) (send dc draw-line dx dy (+ dx line-w) dy)) line
line-w 1) conclusion))
conclusion))))) (if name
(let ([label (string->bracketed-label name)])
(let-values ([(x y) (rc-find w/out-label line)])
(hb-append w/out-label
(vl-append label
(blank 0 (- (- (pict-height w/out-label) y)
(/ (pict-height label) 2)))))))
w/out-label))))
(define horizontal-bar-spacing (make-parameter 4)) (define horizontal-bar-spacing (make-parameter 4))
(define relation-clauses-combine (make-parameter (λ (l) (apply vc-append 20 l)))) (define relation-clauses-combine (make-parameter (λ (l) (apply vc-append 20 l))))
@ -1084,6 +1126,7 @@
(syntax-property (syntax-property
#`(inference-rules-pict '#,(judgment-form-name jf) #`(inference-rules-pict '#,(judgment-form-name jf)
#,(judgment-form-lws jf) #,(judgment-form-lws jf)
'#,(judgment-form-rule-names jf)
#,(judgment-form-lang jf)) #,(judgment-form-lang jf))
'disappeared-use 'disappeared-use
form-name)) form-name))

2
collects/redex/private/term-fn.rkt
View File

@ -27,7 +27,7 @@
(cond [(syntax-local-value stx (λ () #f)) => p?] (cond [(syntax-local-value stx (λ () #f)) => p?]
[else #f]))) [else #f])))
(define-struct judgment-form (name mode proc mk-proc lang lws)) (define-struct judgment-form (name mode proc mk-proc lang lws rule-names))
(define-struct defined-term (value)) (define-struct defined-term (value))
(define (defined-term-id? stx) (define (defined-term-id? stx)

33
collects/redex/scribblings/ref.scrbl
View File

@ -1148,17 +1148,20 @@ and @racket[#f] otherwise.
O] O]
[rule [premise [rule [premise
... ...
dashes dashes rule-name
conclusion] conclusion]
[conclusion [conclusion
premise premise
...]] ...
rule-name]]
[conclusion (form-id pat/term ...)] [conclusion (form-id pat/term ...)]
[premise (code:line (judgment-form-id pat/term ...) maybe-ellipsis) [premise (code:line (judgment-form-id pat/term ...) maybe-ellipsis)
(where @#,ttpattern @#,tttterm) (where @#,ttpattern @#,tttterm)
(where/hidden @#,ttpattern @#,tttterm) (where/hidden @#,ttpattern @#,tttterm)
(side-condition @#,tttterm) (side-condition @#,tttterm)
(side-condition/hidden @#,tttterm)] (side-condition/hidden @#,tttterm)]
[rule-name (code:line)
string]
[pat/term @#,ttpattern [pat/term @#,ttpattern
@#,tttterm] @#,tttterm]
[maybe-ellipsis (code:line) [maybe-ellipsis (code:line)
@ -1187,11 +1190,11 @@ For example, the following defines addition on natural numbers:
(define-judgment-form nats (define-judgment-form nats
#:mode (sum I I O) #:mode (sum I I O)
#:contract (sum n n n) #:contract (sum n n n)
[----------- [----------- "zero"
(sum z n n)] (sum z n n)]
[(sum n_1 n_2 n_3) [(sum n_1 n_2 n_3)
------------------------- ------------------------- "add1"
(sum (s n_1) n_2 (s n_3))])] (sum (s n_1) n_2 (s n_3))])]
The @racket[judgment-holds] form checks whether a relation holds for any The @racket[judgment-holds] form checks whether a relation holds for any
@ -1267,11 +1270,11 @@ one.
#:mode (even I) #:mode (even I)
#:contract (even n) #:contract (even n)
[-------- [-------- "evenz"
(even z)] (even z)]
[(even n) [(even n)
---------------- ---------------- "even2"
(even (s (s n)))]) (even (s (s n)))])
(define-judgment-form nats (define-judgment-form nats
@ -2546,8 +2549,24 @@ precede ellipses that represent argument sequences; when it is
(or/c zero? positive?))) (or/c zero? positive?)))
pair?))]{ pair?))]{
This parameter controls which cases in a metafunction are rendered. If it is @racket[#f] (the default), then all of the Controls which cases in a metafunction are rendered. If it is @racket[#f] (the default), then all of the
cases appear. If it is a list of numbers, then only the selected cases appear (counting from @racket[0]). cases appear. If it is a list of numbers, then only the selected cases appear (counting from @racket[0]).
This parameter also controls how which clauses in judgment forms are rendered, but
only in the case that @racket[judgment-form-cases] is @racket[#f].
}
@defparam[judgment-form-cases
cases
(or/c #f
(and/c (listof (or/c exact-nonnegative-integer?
string?))
pair?))]{
Controls which clauses in a judgment form are rendered. If it is
@racket[#f] (the default), then all of them are rendered. If
it is a list, then only the selected clauses appear (numbers
count from @racket[0], and strings correspond to the labels
in a judgment form).
} }
@deftogether[[ @deftogether[[

4
doc/release-notes/redex/HISTORY.txt
View File

@ -2,6 +2,10 @@ v5.3.1
* added optional #:lang keyword to term * added optional #:lang keyword to term
* added the ability to name clauses to define-judgment-form
* added judgment-form-cases
v5.3 v5.3
* added the amb tutorial. * added the amb tutorial.