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

redex: fix for render-language with extend-language-show-union as #t

Browse Source 
Merging base languages didn't add non-terminals that are included only
in the extension.

Also, add `extend-language-show-extended-order` for showing productions in
the order of an extended language instead of the original language.
This commit is contained in:
Matthew Flatt 2014-06-26 12:37:37 +01:00
parent 31c35d8da2
commit ac169edfcf
4 changed files with 60 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3041,7 +3041,8 @@ This function sets @racket[dc-for-text-size]. See also
@defparam[extend-language-show-union show? boolean?]{
If this is @racket[#t], then a language constructed with
A parameter that controls the rendering of extended languages.
If the parameter value is @racket[#t], then a language constructed with
extend-language is shown as if the language had been
constructed directly with @racket[language]. If it is @racket[#f], then only
the last extension to the language is shown (with
@ -3054,6 +3055,18 @@ Note that the @racket[#t] variant can look a little bit strange if
multi-line right-hand sides.
}
@defparam[extend-language-show-extended-order ext-order? boolean?]{
A parameter that controls the rendering of extended languages when
@racket[extend-language-show-union] has a true value. If this
parameter's value is @racket[#t], then productions are shown as
ordered in the language extension instead of the order of the
original, unextended language.
Defaults to @racket[#f].
@history[#:added "1.2"]}
@defparam[render-reduction-relation-rules
rules
(or/c false/c

2
pkgs/redex-pkgs/redex-lib/info.rkt
View File

@ -18,4 +18,4 @@
(define pkg-authors '(robby bfetscher))
(define version "1.1")
(define version "1.2")

1
pkgs/redex-pkgs/redex-pict-lib/redex/pict.rkt
View File

@ -61,6 +61,7 @@
(provide/contract
[render-language-nts (parameter/c (or/c false/c (listof (or/c string? symbol?))))]
[extend-language-show-union (parameter/c boolean?)]
[extend-language-show-extended-order (parameter/c boolean?)]
[current-text (parameter/c (-> string? text-style/c number? pict?))])
(provide/contract

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

@ -80,6 +80,7 @@
judgment-form-cases
compact-vertical-min-width
extend-language-show-union
extend-language-show-extended-order
set-arrow-pict!
arrow->pict
horizontal-bar-spacing
@ -573,7 +574,7 @@
;; raw-info : language-pict-info
;; nts : (listof symbol) -- the nts that the user expects to see
(define (make-grammar-pict raw-info nts all-nts)
(let* ([info (remove-unwanted-nts nts (flatten-grammar-info raw-info all-nts))]
(let* ([info (remove-unwanted-nts nts (flatten-grammar-info raw-info all-nts nts))]
[term-space
(launder
(ghost
@ -604,6 +605,7 @@
(define extend-language-show-union (make-parameter #f))
(define extend-language-show-extended-order (make-parameter #f))
;; remove-unwanted-nts : (listof symbol) flattened-language-pict-info -> flattened-language-pict-info
(define (remove-unwanted-nts nts info)
@ -615,32 +617,53 @@
;; flatten-grammar-info : language-pict-info (listof symbol) -> flattened-language-pict-info
(define (flatten-grammar-info info all-nts)
(let ([union? (extend-language-show-union)])
(define (flatten-grammar-info info all-nts wanted-nts)
(define (merge-line nt extension orig-line)
(cond
[(and extension orig-line)
(let ([rhss (cdr extension)])
(cons nt
(map (λ (x)
(if (and (lw? x) (eq? '.... (lw-e x)))
(struct-copy lw
x
[e
(lw->pict all-nts
(find-enclosing-loc-wrapper
(add-bars (cdr orig-line))))])
x))
(cdr extension))))]
[extension extension]
[else orig-line]))
(let ([union? (extend-language-show-union)]
[ext-order? (extend-language-show-extended-order)])
(let loop ([info info])
(cond
[(vector? info)
(let ([orig (loop (vector-ref info 0))]
[extensions (vector-ref info 1)])
(if union?
(map (λ (orig-line)
(let* ([nt (car orig-line)]
[extension (assoc nt extensions)])
(if extension
(let ([rhss (cdr extension)])
(cons nt
(map (λ (x)
(if (and (lw? x) (eq? '.... (lw-e x)))
(struct-copy lw
x
[e
(lw->pict all-nts
(find-enclosing-loc-wrapper
(add-bars (cdr orig-line))))])
x))
(cdr extension))))
orig-line)))
orig)
(cond
[(not ext-order?)
;; Use original order, adding extra extensions after:
(define orig-nts (list->set (map car orig)))
(append
(map (λ (orig-line)
(define nt (car orig-line))
(merge-line nt (assoc nt extensions) orig-line))
orig)
(filter (lambda (extension) (not (set-member? orig-nts (car extension))))
extensions))]
[else
;; Use extension order, adding any extra originals after:
(define ext-nts (list->set (map car extensions)))
(append
(map (λ (extension)
(define nt (car extension))
(merge-line nt extension (assoc nt orig)))
extensions)
(filter (lambda (orig-line) (not (set-member? ext-nts (car orig-line))))
orig))])
extensions))]
[else info]))))