Racket release branch diagram

.gitignore

*~
\#*
.\#*
.DS_Store
compiled/
/doc/

README.md

This is a diagram of the branches of https://github.com/racket/racket during the release process.

branches.pdf

branches.rkt

#!/usr/bin/env -S slideshow --export
#lang slideshow/widescreen
;; SPDX-License-Identifier: (Apache-2.0 OR MIT)

(require pict
         pict/conditional
         pict/balloon
         slideshow/text
         slideshow/step)

(define-syntax-rule (define-labels id ...)
  (define-values [id ...]
    (let ([mk (λ (sym)
                (pict-case sym #:combine rbl-superimpose
                           [(id) (tt (symbol->string 'id))] ...))])
      (big (values (mk 'id) ...)))))
(define-labels master release stable)


(define commit-width
  (* 8/10 (pict-width master)))
(define commit-height
  (* 3/2 (pict-height master)))
(define master-color
  "Pale Turquoise")
(define stable-color
  "Yellow")
(define merge-color
  "Light Green")
(define tag-color
  "Fuchsia")
(define line-thickness
  (* 1/5 (current-font-size)))
(define (midline* [width (* 1/4 commit-width)])
  (filled-rectangle width line-thickness))
(define midline
  (midline*))


(define (commit [label ""] #:dense? [dense? #f] #:color [color master-color])
  (cc-superimpose (filled-rounded-rectangle
                   commit-width commit-height
                   #:border-width line-thickness
                   #:draw-border? #t
                   #:color color)
                  (if dense?
                      (small (t label))
                      (t label))))
(define before-merge-8.7
  (commit "8.7.0.3"))
(define v8.7
  (commit "8.7" #:color stable-color))
(define before-branch
  (commit "8.7.0.12"))
(define alpha
  (commit "8.7.0.900" #:color stable-color))
(define post-branch
  (commit "8.8.0.1"))
(define v8.8
  (commit "8.8" #:color stable-color))
(define merge-8.7
  (commit "merge 8.7" #:color merge-color))
(define cherry-pick
  (commit "cherry pick" #:dense? #t #:color merge-color))
(define dev1 (commit))
(define dev2 (commit))
(define merge-8.8
  (commit "merge 8.8" #:color merge-color))

(define (tag label)
  (wrap-balloon (tt label) 'n 0 (- (pict-width midline)) tag-color))
(define (map-balloon f b)
  (make-balloon (f (balloon-pict b)) (balloon-point-x b) (balloon-point-y b)))
(define tag8.7 (tag "v8.7"))
(define tag8.8 (tag "v8.8"))


(define all-steps
  (with-steps
      [Start Branch ContinueMaster CherryPick FinalCommit ToStable Tag DeleteRelease Merge]
    (define-syntax-rule (from? id)
      (not (before? id)))
    (define-syntax-rule (vfrom id)
      (if (from? id) identity ghost))
    (define-syntax-rule (step-case #:combine combine [id rhs0 rhs* ...] ...)
      (pict-cond
       #:combine combine
       [(only? id) rhs0 rhs* ...] ...
       [#t (if (or (only? id) ...)
               (blank)
               (error 'step-case "not exhaustive"))]))
    (define title
      (step-case
       #:combine cbl-superimpose
       [Start (titlet "Before Release Process")]
       [Branch (hbl-append (titlet "Create ") (tt "release") (titlet " Branch"))]
       [ContinueMaster (hbl-append (titlet "Continue Development on ") (tt "master"))]
       [CherryPick (titlet "Fix Bugs")]
       [FinalCommit (titlet "Commit New Version")]
       [ToStable (hbl-append (titlet "Fast-forward ") (tt "stable"))]
       [Tag (hbl-append (titlet "Tag via ") (tt "finalize-catalog.sh"))]
       [DeleteRelease (hbl-append (titlet "Delete ") (tt "release") (titlet " Branch"))]
       [Merge (hbl-append
               (titlet "Merge ") (tt "stable") (titlet " into ") (tt "master")
               (titlet " (using ") (tt "-s ours") (titlet ")"))]))
    (define (fade p)
      (cellophane p 0.25))
    (define master-commits
      (hc-append midline
                 before-merge-8.7
                 midline
                 merge-8.7
                 midline
                 before-branch
                 ((vfrom Branch)
                  (hc-append midline
                             post-branch
                             ((vfrom ContinueMaster)
                              (hc-append midline dev1 midline dev2
                                         ((vfrom Merge)
                                          (hc-append midline merge-8.8))))))))
    (define combined-commits
      ((vfrom CherryPick)
       (hc-append cherry-pick ((vfrom FinalCommit)
                               (hc-append midline v8.8)))))
    (define faded-combined-commits
      (launder (fade combined-commits)))
    (define release-commits
      (hc-append (ghost midline)
                 (ghost (commit))
                 (ghost midline)
                 (ghost (commit))
                 (ghost midline)
                 (ghost (commit))
                 (ghost midline)
                 ((vafter Branch) alpha)
                 ((cond
                    [(between-excl? CherryPick ToStable)
                     identity]
                    [(between-excl? ToStable DeleteRelease)
                     fade]
                    [else
                     ghost])
                  midline)
                 (if (between-excl? CherryPick ToStable)
                     combined-commits
                     ((vbetween-excl ToStable DeleteRelease)
                      faded-combined-commits))
                 (ghost midline)
                 (ghost (commit))))
    (define skipped-commit-width
      (+ (* 3 commit-width)
         (* 4 (pict-width midline))))
    (define stable-commits
      (hc-append midline
                 v8.7
                 (ghost (midline* skipped-commit-width))
                 (if (from? ToStable)
                     combined-commits
                     (ghost faded-combined-commits))
                 (ghost midline)
                 (ghost (commit))))
    (define background-line
      (hline (pict-width master-commits) 1))
    (define branches
      (apply (curry vl-append commit-height)
             (map (curry apply hc-append (pict-width midline))
                  `([,master ,(cc-superimpose background-line master-commits)]
                    [,((vbetween-excl Branch DeleteRelease)
                       release)
                     ,(cc-superimpose (lc-superimpose
                                       ((vbetween-excl Branch ToStable)
                                        background-line)
                                       ((vbetween-excl ToStable DeleteRelease)
                                        (hline skipped-commit-width
                                               (pict-height background-line))))
                                      release-commits)]
                    [,stable ,(cc-superimpose background-line stable-commits)]))))
    (define (ancestor-line branches from to #:from-above? from-above?)
      (pin-line #:line-width (pict-height midline)
                branches
                from
                rc-find
                to
                (λ (parent child)
                  (define inset 6)
                  (define-values [find +/-]
                    (if from-above?
                        (values lt-find +)
                        (values lb-find -)))
                  (define-values [x y]
                    (find parent child))
                  (values (+ x inset) (+/- y inset)))))
    (let* ([branches (pin-balloon tag8.7 branches v8.7 cb-find)]
           [branches (if (before? Tag)
                         branches
                         (pin-balloon tag8.8 branches v8.8 cb-find))]
           [branches (ancestor-line branches
                                    v8.7
                                    merge-8.7
                                    #:from-above? #f)]
           [branches (if (before? Branch)
                         branches
                         (ancestor-line branches
                                        before-branch
                                        alpha
                                        #:from-above? #t))]
           [branches (if (before? ToStable)
                         branches
                         (ancestor-line branches
                                        alpha
                                        cherry-pick
                                        #:from-above? #t))]
           [branches (if (before? Merge)
                         branches
                         (ancestor-line branches
                                        v8.8
                                        merge-8.8
                                        #:from-above? #f))]
           [branches (if (before? CherryPick)
                         branches
                         (pin-arrow-line (pict-width midline)
                                         #:line-width (pict-height midline)
                                         #:style 'dot
                                         branches
                                         dev1
                                         cb-find
                                         cherry-pick
                                         ct-find))]
           [row-height (* 1/3 (pict-height branches))]
           [branches (panorama branches)])
      (vc-append
       row-height
       title
       (scale-to-fit branches titleless-page)))))

(for-each slide all-steps)