Skip to content

Automated Resyntax fixes #462

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 5 commits into
base: master
Choose a base branch
from
Open

Automated Resyntax fixes #462

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
aed7db1
Fix 5 occurrences of `tidy-require`
resyntax-ci[bot] Dec 4, 2024
5d5dac7
Fix 1 occurrence of `if-let-to-cond`
resyntax-ci[bot] Dec 4, 2024
5beca04
Fix 12 occurrences of `let-to-define`
resyntax-ci[bot] Dec 4, 2024
c65027e
Fix 1 occurrence of `define-let-to-double-define`
resyntax-ci[bot] Dec 4, 2024
893e52f
Fix 1 occurrence of `always-throwing-if-to-when`
resyntax-ci[bot] Dec 4, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
234 changes: 114 additions & 120 deletions scribble-doc/scribblings/scribble/class-diagrams.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,12 +1,12 @@
#lang racket/base
(require (prefix-in etc: mzlib/etc)
(require racket/class
racket/contract
racket/draw
racket/runtime-path
texpict/mrpict
(prefix-in etc: mzlib/etc)
(only-in pict pin-line pin-arrow-line)
(except-in texpict/utils pin-line pin-arrow-line)
racket/class
racket/runtime-path
racket/draw
racket/contract
(only-in racket/list last))

(define the-font-size 12)
Expand Down Expand Up @@ -70,41 +70,32 @@
(unless (even? (length args))
(error 'method-spec "expected a list of types and argument names, but found ~a arguments"
(length args)))
(let ([first-line
(hbl-append
(type-spec range)
(normal-font " ")
(var-font name)
(cond
[(null? args)
(normal-font "()")]
[else
(hbl-append
(normal-font "(")
(let loop ([args args])
(let* ([type (car args)]
[param (cadr args)]
[single-arg
(if param
(hbl-append (type-spec type)
(normal-font " ")
(var-font param))
(type-spec type))])

(cond
[(null? (cddr args))
(hbl-append single-arg (normal-font ")"))]
[else
(hbl-append single-arg
(normal-font ", ")
(loop (cddr args)))]))))])
(if body
(hbl-append (normal-font " {"))
(blank)))])
(if body
(vl-append first-line
(hbl-append (blank 8 0) body (normal-font "}")))
first-line)))
(define first-line
(hbl-append
(type-spec range)
(normal-font " ")
(var-font name)
(cond
[(null? args) (normal-font "()")]
[else
(hbl-append
(normal-font "(")
(let loop ([args args])
(let* ([type (car args)]
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This let* could be turned to define, I think?

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Agreed. Pretty sure the fix limit is the only thing that stopped Resyntax from addressing it.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think the fix limit should be somehow less strict so that this stops happening.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yeah, it keeps coming back up. Filed jackfirth/resyntax#429 to track it.

[param (cadr args)]
[single-arg (if param
(hbl-append (type-spec type) (normal-font " ") (var-font param))
(type-spec type))])

(cond
[(null? (cddr args)) (hbl-append single-arg (normal-font ")"))]
[else (hbl-append single-arg (normal-font ", ") (loop (cddr args)))]))))])
(if body
(hbl-append (normal-font " {"))
(blank))))
(if body
(vl-append first-line (hbl-append (blank 8 0) body (normal-font "}")))
first-line))

(define (type-spec str)
(cond
Expand All @@ -126,83 +117,86 @@

;; class-box : pict (or/c #f (listof pict)) (or/c #f (listof pict)) -> pict
(define (class-box name fields methods)
(let* ([mk-blank (λ () (blank 0 (+ class-box-margin class-box-margin)))])
(cond
[(and methods fields)
(let* ([top-spacer (mk-blank)]
[bottom-spacer (mk-blank)]
[main (vl-append name
top-spacer
(if (null? fields)
(blank 0 4)
(apply vl-append fields))
bottom-spacer
(if (null? methods)
(blank 0 4)
(apply vl-append methods)))])
(add-hline
(add-hline (frame (inset main class-box-margin))
top-spacer)
bottom-spacer))]
[fields
(let* ([top-spacer (mk-blank)]
[main (vl-append name
top-spacer
(if (null? fields)
(blank)
(apply vl-append fields)))])
(add-hline (frame (inset main class-box-margin))
top-spacer))]
[methods (class-box name methods fields)]
[else (frame (inset name class-box-margin))])))
(define (mk-blank)
(blank 0 (+ class-box-margin class-box-margin)))
(cond
[(and methods fields)
(let* ([top-spacer (mk-blank)]
[bottom-spacer (mk-blank)]
[main (vl-append name
top-spacer
(if (null? fields)
(blank 0 4)
(apply vl-append fields))
bottom-spacer
(if (null? methods)
(blank 0 4)
(apply vl-append methods)))])
(add-hline (add-hline (frame (inset main class-box-margin)) top-spacer) bottom-spacer))]
[fields
(let* ([top-spacer (mk-blank)]
[main (vl-append name
top-spacer
(if (null? fields)
(blank)
(apply vl-append fields)))])
(add-hline (frame (inset main class-box-margin)) top-spacer))]
[methods (class-box name methods fields)]
[else (frame (inset name class-box-margin))]))

(define (add-hline main sub)
(let-values ([(x y) (cc-find main sub)])
(pin-line main
sub (λ (p1 p2) (values 0 y))
sub (λ (p1 p2) (values (pict-width main) y)))))
(define-values (x y) (cc-find main sub))
(pin-line main sub (λ (p1 p2) (values 0 y)) sub (λ (p1 p2) (values (pict-width main) y))))

;; hierarchy : pict (cons pict (listof pict)) (cons pict (listof pict)) -> pict
(define (hierarchy main supers subs)
(let ([supers-bottoms (apply max (map (λ (x) (let-values ([(x y) (cb-find main x)]) y)) supers))]
[subs-tops (apply min (map (λ (x) (let-values ([(x y) (ct-find main x)]) y)) subs))]
[sorted-subs (sort subs (λ (x y) (< (left-edge-x main x) (left-edge-x main y))))])
(unless (< supers-bottoms subs-tops)
(error 'hierarchy "expected supers to be on top of subs, supers bottom is at ~a, and subs tops is at ~a"
supers-bottoms
subs-tops))
(let* ([main-line-y (max (- subs-tops 20) (/ (+ supers-bottoms subs-tops) 2))]
[main-line-start-x (center-x main (car sorted-subs))]
[main-line-end-x (center-x main (last sorted-subs))]
[w/main-line
(pin-line main
main (λ (_1 _2) (values main-line-start-x main-line-y))
main (λ (_1 _2) (values main-line-end-x main-line-y))
#:color hierarchy-color)]
[super-lines
(map (λ (super)
(let-values ([(x y) (cb-find main super)])
(pin-over
(pin-line (ghost main)
super cb-find
main (λ (_1 _2) (values x main-line-y)))
(- x (/ (pict-width triangle) 2))
(- (/ (+ y main-line-y) 2)
(/ (pict-height triangle) 2))
triangle)))
supers)]
[sub-lines
(map (λ (sub)
(let-values ([(x y) (ct-find main sub)])
(pin-line (ghost main)
sub ct-find
main (λ (_1 _2) (values x main-line-y))
#:color hierarchy-color)))
subs)])
(apply cc-superimpose
w/main-line
(append sub-lines
super-lines)))))
(define supers-bottoms
(apply max
(map (λ (x)
(let-values ([(x y) (cb-find main x)])
y))
supers)))
(define subs-tops
(apply min
(map (λ (x)
(let-values ([(x y) (ct-find main x)])
y))
subs)))
(define sorted-subs (sort subs (λ (x y) (< (left-edge-x main x) (left-edge-x main y)))))
(unless (< supers-bottoms subs-tops)
(error 'hierarchy
"expected supers to be on top of subs, supers bottom is at ~a, and subs tops is at ~a"
supers-bottoms
subs-tops))
(define main-line-y (max (- subs-tops 20) (/ (+ supers-bottoms subs-tops) 2)))
(define main-line-start-x (center-x main (car sorted-subs)))
(define main-line-end-x (center-x main (last sorted-subs)))
(define w/main-line
(pin-line main
main
(λ (_1 _2) (values main-line-start-x main-line-y))
main
(λ (_1 _2) (values main-line-end-x main-line-y))
#:color hierarchy-color))
(define super-lines
(map (λ (super)
(let-values ([(x y) (cb-find main super)])
(pin-over (pin-line (ghost main) super cb-find main (λ (_1 _2) (values x main-line-y)))
(- x (/ (pict-width triangle) 2))
(- (/ (+ y main-line-y) 2) (/ (pict-height triangle) 2))
triangle)))
supers))
(define sub-lines
(map (λ (sub)
(let-values ([(x y) (ct-find main sub)])
(pin-line (ghost main)
sub
ct-find
main
(λ (_1 _2) (values x main-line-y))
#:color hierarchy-color)))
subs))
(apply cc-superimpose w/main-line (append sub-lines super-lines)))

(define triangle-width 12)
(define triangle-height 12)
Expand All @@ -212,21 +206,21 @@
(make-object point% triangle-width triangle-height))])
(colorize
(dc (λ (dc dx dy)
(let ([brush (send dc get-brush)])
(send dc set-brush (send brush get-color) 'solid)
(send dc draw-polygon points dx dy)
(send dc set-brush brush)))
(define brush (send dc get-brush))
(send dc set-brush (send brush get-color) 'solid)
(send dc draw-polygon points dx dy)
(send dc set-brush brush))
triangle-width
triangle-height)
hierarchy-color)))

(define (center-x main pict)
(let-values ([(x y) (cc-find main pict)])
x))
(define-values (x y) (cc-find main pict))
x)

(define (left-edge-x main pict)
(let-values ([(x y) (lc-find main pict)])
x))
(define-values (x y) (lc-find main pict))
x)


(define (add-dot-right main class field) (add-dot-left-right/offset main class field 0 rc-find))
Expand Down
82 changes: 37 additions & 45 deletions scribble-doc/scribblings/scribble/struct-hierarchy.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,12 +1,12 @@
#lang racket/base

(require "class-diagrams.rkt"
(only-in pict pin-arrow-line)
(require racket/class
racket/draw
racket/system
texpict/mrpict
(only-in pict pin-arrow-line)
(except-in texpict/utils pin-arrow-line)
racket/system
racket/class
racket/draw)
"class-diagrams.rkt")

(define (mk-ps-diagram)
;; thicken up the lines for postscript
Expand Down Expand Up @@ -315,20 +315,15 @@
(inset (panorama w/delayed-connections) 0 0 1 0))

(define (double f p0 a b c d [count 1])
(let ([arrows1 (launder (f (ghost p0) a b c d count #:dot-delta 1))]
[arrows2 (launder (f (ghost p0) a b c d count #:dot-delta -1))])
(cc-superimpose p0
arrows1
arrows2)))
(define arrows1 (launder (f (ghost p0) a b c d count #:dot-delta 1)))
(define arrows2 (launder (f (ghost p0) a b c d count #:dot-delta -1)))
(cc-superimpose p0 arrows1 arrows2))

(define (triple f p0 a b c d [count 1])
(let ([arrows (launder (f (ghost p0) a b c d count))]
[up-arrows (launder (f (ghost p0) a b c d count #:dot-delta 2))]
[down-arrows (launder (f (ghost p0) a b c d count #:dot-delta -2))])
(cc-superimpose p0
arrows
up-arrows
down-arrows)))
(define arrows (launder (f (ghost p0) a b c d count)))
(define up-arrows (launder (f (ghost p0) a b c d count #:dot-delta 2)))
(define down-arrows (launder (f (ghost p0) a b c d count #:dot-delta -2)))
(cc-superimpose p0 arrows up-arrows down-arrows))

(define (connect-circly-dots show-arrowhead? main dot1 . dots)
(let loop ([prev-dot dot1]
Expand All @@ -343,38 +338,35 @@

;; this is a hack -- it will only work with right-right-reference
(define (connect-two-circly-dots pict dot1 dot2 arrowhead?)
(let ([base
(let*-values ([(sx sy) (cc-find pict dot1)]
[(raw-ex ey) (cc-find pict dot2)]
[(ex) (if arrowhead?
(+ raw-ex 2)
raw-ex)])
(cc-superimpose
(dc
(λ (dc dx dy)
(let ([pen (send dc get-pen)])
(send dc set-pen
type-link-color ;(send pen get-color)
(if (is-a? dc post-script-dc%)
4
2)
'dot)
(send dc draw-line
(+ dx sx) (+ dy sy)
(+ dx ex) (+ dy ey))
(send dc set-pen pen)))
(pict-width pict)
(pict-height pict))
pict))])
(define base
(let*-values ([(sx sy) (cc-find pict dot1)]
[(raw-ex ey) (cc-find pict dot2)]
[(ex) (if arrowhead?
(+ raw-ex 2)
raw-ex)])
(cc-superimpose (dc (λ (dc dx dy)
(let ([pen (send dc get-pen)])
(send dc
set-pen
type-link-color ;(send pen get-color)
(if (is-a? dc post-script-dc%) 4 2)
'dot)
(send dc draw-line (+ dx sx) (+ dy sy) (+ dx ex) (+ dy ey))
(send dc set-pen pen)))
(pict-width pict)
(pict-height pict))
pict)))
(if arrowhead?
(pin-arrow-line field-arrowhead-size
base
dot1 (λ (ignored1 ignored2)
(let-values ([(x y) (cc-find pict dot2)])
(values (+ x 2) y)))
dot2 cc-find
dot1
(λ (ignored1 ignored2)
(let-values ([(x y) (cc-find pict dot2)])
(values (+ x 2) y)))
dot2
cc-find
#:color type-link-color)
base)))
base))

(define (dotted-right-right-reference p0 a b c d [count 1])
(right-right-reference p0 a b c d count #:connect-dots connect-circly-dots))
Expand Down
Loading
Loading