1#lang racket/base
2(require racket/cmdline
3         racket/format
4         racket/path
5         racket/file)
6
7;; Adjust the configuration to consult a catalog that is
8;; expected to map some packages to directory links.
9
10;; Used by the top-level Makefile in the main Racket repository.
11
12(define config-dir-path (build-path "racket" "etc"))
13(define config-file-path (build-path config-dir-path "config.rktd"))
14
15(define catalog-relative-path (build-path 'up "share" "pkgs-catalog"))
16(define catalog-relative-path-str (path->string catalog-relative-path))
17
18(define-values (default-src-catalog src-catalog)
19  (command-line
20   #:args
21   (default-src-catalog src-catalog)
22   (values default-src-catalog src-catalog)))
23
24(define src-catalog-is-default?
25  (equal? src-catalog default-src-catalog))
26
27(when (file-exists? config-file-path)
28  (call-with-input-file*
29   config-file-path
30   (lambda (i)
31     (define r (read i))
32     (define l (hash-ref r 'catalogs #f))
33     (define starts-as-expected?
34       (and (list? l)
35            ((length l) . >= . 1)
36            (equal? (car l) catalog-relative-path-str)))
37     (define has-src-catalog?
38       (or (and src-catalog-is-default?
39                (member #f l))
40           (member src-catalog l)))
41     (unless (and starts-as-expected?
42                  has-src-catalog?)
43       (error 'pkgs-catalog
44              (~a "config file exists, but with a mismatched `catalogs';\n"
45                  " the existing configuration does not ~a\n"
46                  "  config file: ~a\n"
47                  "  expected ~acatalog: ~s\n"
48                  "  possible solution: delete the config file")
49              (if (not starts-as-expected?)
50                  "start as expected"
51                  "include the specified catalog")
52              config-file-path
53              (if (not starts-as-expected?)
54                  "initial "
55                  "")
56              (if (not starts-as-expected?)
57                  catalog-relative-path-str
58                  src-catalog))))))
59
60(unless (file-exists? config-file-path)
61  (printf "Writing ~a\n" config-file-path)
62  (let-values ([(base name dir?) (split-path config-file-path)])
63    (when (path? base) (make-directory* base)))
64  (call-with-output-file*
65   config-file-path
66   (lambda (o)
67     (write (hash 'catalogs
68                  (cons catalog-relative-path-str
69                        (append
70                         (if src-catalog-is-default?
71                             '()
72                             (list src-catalog))
73                         (list #f)))
74                  'installation-name
75                  "development"
76                  'default-scope
77                  "installation"
78                  'interactive-file
79                  'racket/interactive
80                  'gui-interactive-file
81                  'racket/gui/interactive)
82            o)
83     (newline o))))
84