`raco dist` Demo

$$README.md

Inspired by https://racket.discourse.group/t/how-to-make-small-executables/2244.

$EmbeddedCollects.md

EmbeddedCollects

[  12]    .
├── [  12]    bin
│   ├── [1.9M]    bar
│   └── [1.9M]    foo
└── [   6]    lib
    └── [  26]    plt
        └── [ 44M]    racketcs-8.10

4 directories, 3 files

Total 48M

$SharedCollects.md

SharedCollects

[  12]    .
├── [  12]    bin
│   ├── [ 55K]    bar
│   └── [ 56K]    foo
└── [   6]    lib
    └── [  32]    plt
        ├── [  16]    foo
        │   └── [  24]    collects
        │       ├── [  30]    racket
        │       │   ├── [ 294]    compiled
        │       │   │   ├── [ 42K]    base_rkt.zo
        │       │   │   ├── [5.3K]    phase+space_rkt.zo
        │       │   │   ├── [ 23K]    provide-transform_rkt.zo
        │       │   │   ├── [4.8K]    repl_rkt.zo
        │       │   │   ├── [ 28K]    require-transform_rkt.zo
        │       │   │   ├── [3.2K]    runtime-config_rkt.zo
        │       │   │   ├── [8.8K]    stxparam-exptime_rkt.zo
        │       │   │   └── [ 12K]    stxparam_rkt.zo
        │       │   └── [  16]    private
        │       │       └── [1.9K]    compiled
        │       │           ├── [ 36K]    base_rkt.zo
        │       │           ├── [ 44K]    case_rkt.zo
        │       │           ├── [6.4K]    cert_rkt.zo
        │       │           ├── [5.7K]    collect_rkt.zo
        │       │           ├── [ 11K]    cond_rkt.zo
        │       │           ├── [ 15K]    define-et-al_rkt.zo
        │       │           ├── [ 11K]    define_rkt.zo
        │       │           ├── [ 71K]    define-struct_rkt.zo
        │       │           ├── [7.6K]    ellipses_rkt.zo
        │       │           ├── [5.7K]    executable-path_rkt.zo
        │       │           ├── [3.1K]    fixnum_rkt.zo
        │       │           ├── [275K]    for_rkt.zo
        │       │           ├── [ 19K]    generic-interfaces_rkt.zo
        │       │           ├── [ 29K]    generic-methods_rkt.zo
        │       │           ├── [3.8K]    gen-temp_rkt.zo
        │       │           ├── [ 23K]    hash_rkt.zo
        │       │           ├── [9.0K]    immediate-default_rkt.zo
        │       │           ├── [ 36K]    kernstruct_rkt.zo
        │       │           ├── [ 30K]    kw-file_rkt.zo
        │       │           ├── [3.1K]    kw-prop-key_rkt.zo
        │       │           ├── [149K]    kw_rkt.zo
        │       │           ├── [ 14K]    kw-syntax-binding_rkt.zo
        │       │           ├── [ 15K]    kw-syntax-serialize_rkt.zo
        │       │           ├── [ 14K]    letstx-scheme_rkt.zo
        │       │           ├── [ 32K]    list_rkt.zo
        │       │           ├── [ 21K]    logger_rkt.zo
        │       │           ├── [ 19K]    map_rkt.zo
        │       │           ├── [4.6K]    member_rkt.zo
        │       │           ├── [ 23K]    misc_rkt.zo
        │       │           ├── [8.9K]    modbeg_rkt.zo
        │       │           ├── [ 51K]    more-scheme_rkt.zo
        │       │           ├── [4.8K]    name_rkt.zo
        │       │           ├── [ 18K]    namespace_rkt.zo
        │       │           ├── [ 18K]    norm-define_rkt.zo
        │       │           ├── [6.4K]    old-path_rkt.zo
        │       │           ├── [5.4K]    path-list_rkt.zo
        │       │           ├── [ 10K]    path_rkt.zo
        │       │           ├── [7.8K]    performance-hint_rkt.zo
        │       │           ├── [ 41K]    pre-base_rkt.zo
        │       │           ├── [6.4K]    print-value-columns_rkt.zo
        │       │           ├── [3.7K]    procedure-alias_rkt.zo
        │       │           ├── [ 36K]    promise_rkt.zo
        │       │           ├── [ 22K]    qq-and-or_rkt.zo
        │       │           ├── [ 22K]    qqstx_rkt.zo
        │       │           ├── [5.1K]    reading-param_rkt.zo
        │       │           ├── [ 78K]    reqprov_rkt.zo
        │       │           ├── [6.9K]    reverse_rkt.zo
        │       │           ├── [ 30K]    sc_rkt.zo
        │       │           ├── [ 23K]    sort_rkt.zo
        │       │           ├── [ 75K]    string_rkt.zo
        │       │           ├── [9.5K]    struct-info_rkt.zo
        │       │           ├── [ 11K]    struct_rkt.zo
        │       │           ├── [3.7K]    struct-util_rkt.zo
        │       │           ├── [ 23K]    stxcase_rkt.zo
        │       │           ├── [ 15K]    stxcase-scheme_rkt.zo
        │       │           ├── [ 11K]    stxloc_rkt.zo
        │       │           ├── [ 21K]    stxparamkey_rkt.zo
        │       │           ├── [ 15K]    stxparam_rkt.zo
        │       │           ├── [8.9K]    stx_rkt.zo
        │       │           ├── [ 12K]    submodule_rkt.zo
        │       │           ├── [ 52K]    template_rkt.zo
        │       │           ├── [7.5K]    top-int_rkt.zo
        │       │           └── [ 16K]    with-stx_rkt.zo
        │       └── [  16]    syntax
        │           └── [ 104]    compiled
        │               ├── [ 79K]    module-reader_rkt.zo
        │               ├── [ 15K]    readerr_rkt.zo
        │               └── [ 12K]    wrap-modbeg_rkt.zo
        └── [ 44M]    racketcs-8.10

12 directories, 77 files

Total 46M

$SingleUtility.md

SingleUtility

[  12]    .
├── [   6]    bin
│   └── [1.9M]    foo
└── [   6]    lib
    └── [  26]    plt
        └── [ 44M]    racketcs-8.10

4 directories, 2 files

Total 46M

.gitignore

/config.mk
/build
/*.tar
/*.html
/_zuo.db
/_zuo_tc.db
/compiled
*~
\#*
.\#*
.DS_Store

bar.rkt

#lang racket/base
42

check.sh

#!/bin/sh
exitStatus=0
invoke () {
    echo $1
    ./$1
    if [ ! $? -eq 0 ]; then
        exitStatus=1
    fi
}
for layout in -exe /bin
do
    for label in Embedded Shared
    do
        for exe in foo bar
        do
            invoke build/${label}Collects${layout}/${exe}
        done
    done
    invoke build/SingleUtility${layout}/foo
done
exit $exitStatus

foo.rkt

#lang racket/base
(displayln "Hi, world!")

main.zuo

#lang zuo
;; SPDX-License-Identifier: (Apache-2.0 OR MIT)
;; SPDX-FileCopyrightText:  2023 Philip McGrath <philip@philipmcgrath.com>
;; SPDX-FileCopyrightText:  Racket contributors (see `directory-sha256`)

(provide-targets targets-at)

(define names
  `("foo" "bar"))

(define (targets-at at-dir arg-vars)
  (define config.mk
    (at-dir "config.mk"))
  (define vars
    (if (file-exists? config.mk)
        (let ([vars (config-file->hash config.mk arg-vars)])
          (alert (~a (if (equal? arg-vars (hash))
                         "Used"
                         "Extended")
                     " configuration from "
                     (~v config.mk)))
          (for-each (lambda (k)
                      (alert (~a "  " k) (hash-ref vars k)))
                    (hash-keys vars))
          vars)
        arg-vars))
  (define raco
    (hash-ref vars 'RACO "raco"))
  (define raco-target
    (input-data-target 'raco raco))
  (define at-build-dir
    (make-at-dir "build"))
  (define at-make-dir
    (make-at-dir (at-build-dir "make")))
  (define (make-targets/db specs)
    ;; https://github.com/racket/racket/issues/4732
    (make-targets `([:db-dir ,(at-dir ".")]
                    ,@specs)))
  (define cp-targets
    (make-targets/db
     (map (lambda (base)
            (define src
              (at-source (~a base ".rkt")))
            `[:target ,(at-make-dir (~a base ".rkt")) (,src)
                      ,(lambda (dest token)
                         (mkdir-p (at-make-dir))
                         (cp src dest))])
          names)))
  (define zo+dep-targets
    (make-targets/db
     `([:target ,(map (make-at-dir (at-make-dir "compiled"))
                      (append-map (lambda (base)
                                    (list (~a base "_rkt.zo")
                                          (~a base "_rkt.dep")))
                                  names))
                (,raco-target ,@cp-targets)
                ,(lambda (dest0 token)
                   (shell/wait
                    (build-shell raco "make"
                                 "-j" (~a (min (length names)
                                               ;; FIXME
                                               #;
                                               (max (or (maybe-jobserver-jobs)
                                                        1)
                                                    1)))
                                 "--"
                                 (map target-shell cp-targets))
                    (hash 'desc "raco make")))])))
  (define (make-raco-dist-targets dist-name share-collects? [single-util? #f])
    (define at-exe-dir
      (make-at-dir (at-build-dir (~a dist-name "-exe"))))
    (define exe-files
      (map at-exe-dir (map .exe (if single-util?
                                    (list (car names))
                                    names))))
    (define (raco-exe rkt exe [extra '()])
      (shell/wait
       (build-shell raco "exe"
                    "-o" (string->shell (path-replace-extension exe ""))
                    extra
                    "--"
                    (string->shell rkt))
       (hash 'desc "raco exe")))
    (define exe-targets
      (if share-collects?
          (list
           (target
            (at-exe-dir "collects")
            (lambda (collects-dir token)
              (rule (cons raco-target
                          (append cp-targets
                                  zo+dep-targets))
                    (lambda ()
                      (mkdir-p (at-exe-dir))
                      (for-each rm* exe-files)
                      (map (lambda (exe rkt-target)
                             (raco-exe (target-path rkt-target)
                                       exe
                                       (list "--collects-path"
                                             "collects"
                                             "--collects-dest"
                                             (string->shell collects-dir))))
                           exe-files
                           (if single-util?
                               (list (car cp-targets))
                               cp-targets))
                      (unless (directory-exists? collects-dir)
                        (error (~a dist-name ": failed to create "
                                   (~v collects-dir))))
                      (directory-sha256 collects-dir token))
                    (directory-sha256 collects-dir token)))
            (hash 'precious? #t
                  'co-outputs exe-files)))
          (make-targets/db
           (map (lambda (exe rkt-target)
                  `[:target ,exe (,rkt-target ,raco-target ,@zo+dep-targets)
                            ,(lambda (dest token)
                               (mkdir-p (at-exe-dir))
                               (raco-exe (target-path rkt-target)
                                         exe))])
                exe-files
                (if single-util?
                    (list (car cp-targets))
                    cp-targets)))))
    (cons
     (target (at-build-dir dist-name)
             (lambda (dist-dir token)
               (rule
                (cons raco-target exe-targets)
                (lambda ()
                  (rm* dist-dir)
                  (shell/wait 
                   (build-shell raco "dist"
                                (if share-collects?
                                    (list "++collects-copy"
                                          (at-exe-dir "collects"))
                                    "")
                                "--"
                                (string->shell dist-dir)
                                (map string->shell exe-files))
                   (hash 'desc "raco dist"))
                  (directory-sha256 dist-dir token))
                (directory-sha256 dist-dir token))))
     exe-targets))
  (define dist-target-lists
    (list (make-raco-dist-targets "EmbeddedCollects" #f)
          (make-raco-dist-targets "SharedCollects" #t)
          (make-raco-dist-targets "SingleUtility" #f #t)))
  (define dist-dir-targets
    (map car dist-target-lists))
  (define dist+exe-targets
    (apply append dist-target-lists))
  (define tar-targets
    (let* ([tar (hash-ref vars 'TAR "tar --sort=name")]
           [cmd-target (input-data-target 'tar tar)])
      (make-targets/db
       (map (lambda (dist-target)
              (define dist-path (target-path dist-target))
              (define dist-name (file-name-from-path dist-path))
              (define pwd (build-path dist-path ".."))
              `[:target ,(at-dir (~a (file-name-from-path
                                      (target-path dist-target))
                                     ".tar"))
                        (,cmd-target ,dist-target)
                        ,(lambda (dest token)
                           (rm* dest)
                           (shell/wait
                            (build-shell tar "-cf"
                                         (string->shell
                                          (find-relative-path
                                           (simple-form-path pwd)
                                           (simple-form-path dest)))
                                         (string->shell dist-name))
                            (hash 'desc "tar"
                                  'dir pwd)))])
            dist-dir-targets))))
  (define html-targets
    (let* ([tree (hash-ref vars 'TREE "tree")]
           [du (hash-ref vars 'DU "du")]
           [echo (hash-ref vars 'ECHO "echo")]
           [data-targets (map input-data-target
                              '(tree du echo)
                              (list tree du echo))])
      (make-targets/db
       (append-map
        (lambda (dist-target)
          (define dist-name
            (file-name-from-path (target-path dist-target)))
          (map (lambda (html?)
                 `[:target
                   ,(at-dir (~a (if html? "" "$")
                                dist-name
                                (if html? ".html" ".md")))
                   (,dist-target ,@data-targets)
                   ,(lambda (dist-html token)
                      (define size
                        (car (string-split
                              (shell/wait/output
                               ;; `tree --du` is broken for me
                               (build-shell du "-hs" (target-shell
                                                      dist-target))
                               "du")
                              "\t")))
                      (define outro
                        (~a "<p>Total " size "</p>"
                            (if html? "</body></html>" "")))
                      (define tree-cmd
                        (build-shell
                         echo (string->shell outro) "|"
                         tree "-o" (if html?
                                       (string->shell dist-html)
                                       "/dev/stdout")
                         (if html? "-C" "--hintro=/dev/null")
                         "--nolinks" "--houtro=/dev/stdin" "-H" "." "-h"
                         "-T" (string->shell dist-name)
                         (target-shell dist-target)))
                      (cond
                        [html?
                         (shell/wait tree-cmd (hash 'desc "tree"))]
                        [else
                         (define lines
                           (string-split (shell/wait/output tree-cmd "tree")
                                         "\n"))
                         (define trimmed
                           (map (lambda (l)
                                  (if (or (equal? "" l)
                                          (not (equal? (char "\t")
                                                       (string-ref l 0))))
                                      l
                                      (substring l 1)))
                                lines))
                         (display-to-file
                          (string-join (cons (~a "<h1>" dist-name "</h1>")
                                             trimmed)
                                       "\n")
                          dist-html)]))])
               '(#t #f)))
        dist-dir-targets))))
  (append (make-targets/db
           `([:target all (,@tar-targets ,@html-targets)
                      ,void]
             [:target tar (,@tar-targets)
                      ,void]
             [:target html (,@html-targets)
                      ,void]
             [:target md (,@html-targets)
                      ,void]
             [:target clean ()
                      ,(lambda (token)
                         (for-each rm*
                                   (cons (at-build-dir)
                                         (map target-path
                                              (append tar-targets
                                                      html-targets)))))]
             [:target check (,(at-source "check.sh") ,@dist+exe-targets)
                      ,(lambda (token)
                         (when (eq? 'windows (hash-ref (runtime-env)
                                                       'system-type))
                           (error (~a (~v (at-source "check.sh"))
                                      " not supported on Windows")))
                         (define p (process (at-source "check.sh")))
                         (process-wait (hash-ref p 'process))
                         (unless (= 0 (process-status (hash-ref p 'process)))
                           (error (~a (~v (at-source "check.sh"))
                                      " failed"))))]
             ,@(map (lambda (dir-target . deps)
                      `[:target ,(string->symbol (file-name-from-path
                                                  (target-path dir-target)))
                                ,deps
                                ,void])
                    dist-dir-targets
                    tar-targets)))
          tar-targets
          html-targets
          dist+exe-targets
          zo+dep-targets
          cp-targets))

(define (append-map proc lst0 . lsts)
  (apply append (apply map (list* proc lst0 lsts))))

(define (make-max prefer-first?)
  (lambda (init . args)
    (foldl (lambda (a b)
             (if (prefer-first? a b)
                 a
                 b))
           init
           args)))
(define max
  (make-max >))
(define min
  (make-max <))

(define (shell/wait/output cmd [desc "shell command"])
  (displayln cmd)
  (define p (shell cmd (hash 'stdout 'pipe)))
  (define i (hash-ref p 'stdout))
  (thread-process-wait (hash-ref p 'process))
  (unless (= 0 (process-status (hash-ref p 'process)))
    (error (~a desc " failed")))
  (let ([str (fd-read i 'avail)])
    (fd-close i)
    str))

(define (directory-sha256 dir token)
  ;; based on `source-tree` from racket/src/ChezScheme/makefiles/lib.zuo
  (if (directory-exists? dir)
      (string-join
       (let loop ([dir dir] [accum '()])
         (foldl (lambda (e-name accum)
                  (define e (build-path dir e-name))
                  (define st (stat e))
                  (define type (and st (hash-ref st 'type)))
                  (cond
                    [(eq? type 'file) (list* (string-sha256 e)
                                             (file-sha256 e token)
                                             accum)]
                    [(eq? type 'dir) (loop e accum)]
                    [else accum]))
                accum
                (ls dir)))
       "")
      no-sha256))