#!/bin/sh
#| -*- scheme -*-
exec racket "$0"

Instructions:

* Create a copy of a distributed PLT tree, change all files that need to change
  for the patch.  If this is not a first patch, then begin this process with a
  tree that has the previous patch applied.  (Patch numbers should go from 1
  up.)

  I do this:
    cd ...git-repo...
    git checkout -b patch <PREV-VER-OR-PATCH> patched
    git cherry-pick fix-sha1s...
    ... more merges as needed ...
  And at the end don't forget to drop a new tag for the patched result.

* Make sure that "collects/version/patchlevel.ss" contains the new patch
  number, and add comments about this patch, with a list of files that are
  modified.  (This is good for the next step, when doing additional patches.)

* In the code below,
  - set `plt-version' to the version you're patching (base version, the code
    will expect `(version)' to return an equal value).
  - set `plt-base' to the location of the patched PLT tree on your system.
  - put the list of files in the `files' definition.  Each patch should also
    have all preceding patches in it, which means that if you're patching an
    already-patched tree, then you should add more files.  (This is why it is
    good to keep track of the modified files.)  Note that
    "collects/version/patchlevel.ss" must be included in this list, and that
    the file does have the correct patchlevel number (there is currently no way
    to check whether the patchlevel makes sense).

* Note that the patch is a collection with the same name ("plt-patch" below).
  This means that installing a patch is a process that first overwrites any
  preexisting patch collections.  This is fine, because patches are linear and
  cumulative.  The worst that can happen is that someone downloads a patch
  older than what's installed -- in that case the PLT tree already has the
  higher patch level, and when the collection's installer is doing its work it
  will simply be skipped (a successful patch installation happens only once,
  and is later skipped when setup-plt is re-run).

* Test, put in "iplt/web/download/patches/", publish new html, announce.

* Commit the patched tree as a new tag.

|#

#lang mzscheme

;; ============================================================================
;; customization (items marked with `[*]' should be edited for all patches)

;; [*] which PLT version is this patch for?
(define plt-version "370")

;; [*] location of a patched PLT tree
(define plt-base "~/patched")

;; [*] patched files in this tree (including previously patched files, if any)
(define files '("collects/version/patchlevel.ss"
                "collects/drscheme/private/module-language.ss"
                "collects/framework/private/scheme.ss"
                "collects/slideshow/tool.ss"
                "collects/lang/htdp-langs.ss"
                "collects/drscheme/private/unit.ss"))

;; message to show after the last `Done' (#f => no extra text)
(define exit-message "please restart DrScheme")

;; template for the output archive file
(define patchfile-template "/tmp/plt-patch-v~ap~a.plt")

;; template for archive name
(define name-template "PLT Scheme v~ap~a patch")

;; patchlevel file in the PLT tree (must be included in `files' above)
(define patchlevel-file "collects/version/patchlevel.ss")

;; ============================================================================
;; code folows

(require (lib "list.ss") (lib "pack.ss" "setup"))

;; move patchlevel file to the end
(unless (member patchlevel-file files)
  (error 'make-patch
         "missing patchlevel file (~a) in the list of files" patchlevel-file))
(set! files (append (remove patchlevel-file files) (list patchlevel-file)))

(unless (absolute-path? plt-base)
  (error 'make-patch "plt-base is not an absolute path: ~a" plt-base))

(define patchlevel
  ;; use `dynamic-require' -- not `require' since the patch can be built by a
  ;; different PLT installation
  (dynamic-require (build-path plt-base patchlevel-file) 'patchlevel))
(define archive-name (format name-template plt-version patchlevel))
(define archive-filename (format patchfile-template plt-version patchlevel))

(define unpacker-body
  `((define me ,(format "v~ap~a-patch" plt-version patchlevel))
    (define (error* fmt . args)
      (error (string-append "ERROR applying "me": " (apply format fmt args))))
    (define (message fmt . args)
      (printf "*** ~a: ~a\n" me (apply format fmt args)))
    (define collects-dir (find-collects-dir))
    (cond
      [(not (equal? ,plt-version (version)))
       (error* "bad version number; this patch is for version ~a, you have ~a"
               ',plt-version (version))]
      [(= patchlevel ,patchlevel) (error* "Already installed")]
      [(> patchlevel ,patchlevel) (error* "Newer patch installed")]
      [else (message "Applying patch...")])
    (mzuntar void)
    (message "Patch applied successfully, recompiling...")
    ;; return a list of all toplevel collections to recompile
    ;; (define (has-info? c)
    ;;   (file-exists? (build-path collects-dir c "info.ss")))
    ;; (let* ([cs (directory-list collects-dir)]
    ;;        [cs (filter has-info? cs)]
    ;;        [cs (map path->string cs)]
    ;;        [cs (sort cs string<?)]
    ;;        [cs (map list cs)])
    ;;   cs)
    ;; instead of the above, invoke setup-plt directly to avoid installers
    ;; (otherwise, running this .plt from DrScheme on Windows complains about
    ;; not being able to recreate the executable)
    (let ([x 0])
      (parameterize ([exit-handler (lambda (n) (set! x n))])
        (run-setup))
      (message ,(if exit-message (format "Done, ~a." exit-message) "Done."))
      (exit x))
    ;; everything below does not matter since we exit above
    ;; (but just in case, return '() so no collections to recompile)
    '()))

(define run-setup
  ;; This code is based on setup-go
  `(module run-setup mzscheme
     (require (lib "unit.ss") (lib "option-sig.ss" "setup")
              (lib "option-unit.ss" "setup") (lib "cm.ss"))
     (define-values/invoke-unit/infer setup:option@)
     ;; settings
     (clean              #f) ; no cleaning
     (make-zo            #t) ; recompile zos
     (call-install       #f) ; no installers
     (make-launchers     #f) ; no launcher recreation
     (make-so            #f) ; no extension compilation
     (verbose            #f) ; be quiet
     (make-verbose       #f) ; be quiet
     (trust-existing-zos #f) ; recompile files when needed
     (pause-on-errors    #f) ; no interactions
     (force-unpacks      #f) ; not doing any unpacking
     (compile-mode       #f) ; default compilation
     ;; not unpacking, but just in case, make it go into the PLT tree
     (current-target-plt-directory-getter
      (lambda (preferred main-collects-parent-dir choices)
        main-collects-parent-dir))
     (specific-collections '()) ; no specifics, do all collections
     (archives             '()) ; no archives to unpack
     (specific-planet-dirs '()) ; no planet stuff
     ;; invoke it
     (require (lib "setup-unit.ss" "setup")
              (lib "option-unit.ss" "compiler")
              (lib "compiler-unit.ss" "compiler")
              (lib "launcher-unit.ss" "launcher")
              (lib "dynext-unit.ss" "dynext"))
     (provide run-setup)
     (define (run-setup)
       (invoke-unit (compound-unit/infer (import setup-option^) (export)
                      (link launcher@ dynext:compile@ dynext:link@ dynext:file@
                            compiler:option@ compiler@ setup@))
                    (import setup-option^)))))

(define unpack-unit
  `(begin (require (lib "list.ss")
                   (lib "patchlevel.ss" "version")
                   (lib "dirs.ss" "setup"))
          ,run-setup
          (require run-setup)
          (unit (import main-collects-parent-dir mzuntar) (export)
            ,@unpacker-body)))

;; Pack up a .plt file

(current-directory plt-base)

(when (file-exists? archive-filename) (delete-file archive-filename))

(pack-plt archive-filename
          archive-name
          files
          #:requires `((("rackeg") ()) (("gracket") ()))
          #:file-mode 'file-replace
          #:plt-relative? #t
          #:at-plt-home? #t
          #:unpack-unit unpack-unit)
(printf "Patch file created: ~a\n" archive-filename)