about summary refs log tree commit diff
path: root/tools/magrathea/mg.scm
blob: ab8e5bb77e02a790efaa9c2f8b6b82957980795b (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
;; magrathea helps you build planets
;;
;; it is a tiny tool designed to ease workflows in monorepos that are
;; modeled after the tvl depot.
;;
;; users familiar with workflows from other, larger monorepos may be
;; used to having a build tool that can work in any tree location.
;; magrathea enables this, but with nix-y monorepos.

(import (chicken base)
        (chicken format)
        (chicken irregex)
        (chicken port)
        (chicken file)
        (chicken file posix)
        (chicken process)
        (chicken process-context)
        (chicken string)
        (matchable)
        (only (chicken io) read-string))

(define usage #<<USAGE
usage: mg <command> [<target>]

target:
  a target specification with meaning inside of the repository. can
  be absolute (starting with //) or relative to the current directory
  (as long as said directory is inside of the repo). if no target is
  specified, the current directory's physical target is built.

  for example:

    //tools/magrathea - absolute physical target
    //foo/bar:baz     - absolute virtual target
    magrathea         - relative physical target
    :baz              - relative virtual target

commands:
  build - build a target
  shell - enter a shell with the target's build dependencies
  path  - print source folder for the target
  repl  - start a nix repl in the repository root
  run   - build a target and execute its output

file all feedback on b.tvl.fyi
USAGE
)

;; parse target definitions. trailing slashes on physical targets are
;; allowed for shell autocompletion.
;;
;; component ::= any string without "/" or ":"
;;
;; physical-target ::= <component>
;;                   | <component> "/"
;;                   | <component> "/" <physical-target>
;;
;; virtual-target ::= ":" <component>
;;
;; relative-target ::= <physical-target>
;;                   | <virtual-target>
;;                   | <physical-target> <virtual-target>
;;
;; root-anchor ::= "//"
;;
;; target ::= <relative-target> | <root-anchor> <relative-target>

;; read a path component until it looks like something else is coming
(define (read-component first port)
  (let ((keep-reading?
         (lambda () (not (or (eq? #\/ (peek-char port))
                             (eq? #\: (peek-char port))
                             (eof-object? (peek-char port)))))))
    (let reader ((acc (list first))
                 (condition (keep-reading?)))
      (if condition (reader (cons (read-char port) acc) (keep-reading?))
          (list->string (reverse acc))))))

;; read something that started with a slash. what will it be?
(define (read-slash port)
  (if (eq? #\/ (peek-char port))
      (begin (read-char port)
             'root-anchor)
      'path-separator))

;; read any target token and leave port sitting at the next one
(define (read-token port)
  (match (read-char port)
         [#\/ (read-slash port)]
         [#\: 'virtual-separator]
         [other (read-component other port)]))

;; read a target into a list of target tokens
(define (read-target target-str)
  (call-with-input-string
   target-str
   (lambda (port)
     (let reader ((acc '()))
       (if (eof-object? (peek-char port))
           (reverse acc)
           (reader (cons (read-token port) acc)))))))

(define-record target absolute components virtual)
(define (empty-target) (make-target #f '() #f))

(define-record-printer (target t out)
  (fprintf out (conc (if (target-absolute t) "//" "")
                     (string-intersperse (target-components t) "/")
                     (if (target-virtual t) ":" "")
                     (or (target-virtual t) ""))))

;; parse and validate a list of target tokens
(define parse-tokens
  (lambda (tokens #!optional (mode 'root) (acc (empty-target)))
    (match (cons mode tokens)
           ;; absolute target
           [('root . ('root-anchor . rest))
            (begin (target-absolute-set! acc #t)
                   (parse-tokens rest 'root acc))]

           ;; relative target minus potential garbage
           [('root . (not ('path-separator . _)))
            (parse-tokens tokens 'normal acc)]

           ;; virtual target
           [('normal . ('virtual-separator . rest))
            (parse-tokens rest 'virtual acc)]

           [('virtual . ((? string? v)))
            (begin
              (target-virtual-set! acc v)
              acc)]

           ;; chomp through all components and separators
           [('normal . ('path-separator . rest)) (parse-tokens rest 'normal acc)]
           [('normal . ((? string? component) . rest))
            (begin (target-components-set!
                    acc (append (target-components acc) (list component)))
                   (parse-tokens rest 'normal acc ))]

           ;; nothing more to parse and not in a weird state, all done, yay!
           [('normal . ()) acc]

           ;; oh no, we ran out of input too early :(
           [(_ . ()) `(error . ,(format "unexpected end of input while parsing ~s target" mode))]

           ;; something else was invalid :(
           [_ `(error . ,(format "unexpected ~s while parsing ~s target" (car tokens) mode))])))

(define (parse-target target)
  (parse-tokens (read-target target)))

;; turn relative targets into absolute targets based on the current
;; directory
(define (normalise-target t)
  (when (not (target-absolute t))
    (target-components-set! t (append (relative-repo-path)
                                      (target-components t)))
    (target-absolute-set! t #t))
  t)

;; nix doesn't care about the distinction between physical and virtual
;; targets, normalise it away
(define (normalised-components t)
  (if (target-virtual t)
      (append (target-components t) (list (target-virtual t)))
      (target-components t)))

;; return the current repository root as a string
(define mg--repository-root #f)
(define (repository-root)
  (or mg--repository-root
      (begin
        (set! mg--repository-root
              (or (get-environment-variable "MG_ROOT")
                  (string-chomp
                   (call-with-input-pipe "git rev-parse --show-toplevel"
                                         (lambda (p) (read-string #f p))))))
        mg--repository-root)))

;; determine the current path relative to the root of the repository
;; and return it as a list of path components.
(define (relative-repo-path)
  (string-split
   (substring (current-directory) (string-length (repository-root))) "/"))

;; escape a string for interpolation in nix code
(define (nix-escape str)
  (string-translate* str '(("\"" . "\\\"")
                           ("${" . "\\${"))))

;; create a nix expression to build the attribute at the specified
;; components
;;
;; an empty target will build the current folder instead.
;;
;; this uses builtins.getAttr explicitly to avoid problems with
;; escaping.
(define (nix-expr-for target)
  (let nest ((parts (normalised-components (normalise-target target)))
             (acc (conc "(import " (repository-root) " {})")))
    (match parts
           [() (conc "with builtins; " acc)]
           [_ (nest (cdr parts)
                    (conc "(getAttr \""
                          (nix-escape (car parts))
                          "\" " acc ")"))])))

;; exit and complain at the user if something went wrong
(define (mg-error message)
  (format (current-error-port) "[mg] error: ~A~%" message)
  (exit 1))

(define (guarantee-success value)
  (match value
         [('error . message) (mg-error message)]
         [_ value]))

(define-record build-args target passthru unknown)
(define (execute-build args)
  (let ((expr (nix-expr-for (build-args-target args))))
    (fprintf (current-error-port) "[mg] building target ~A~%" (build-args-target args))
    (process-execute "nix-build" (append (list "-E" expr "--show-trace")
                                         (or (build-args-passthru args) '())))))

;; split the arguments used for builds into target/unknown args/nix
;; args, where the latter occur after '--'
(define (parse-build-args acc args)
  (match args
         ;; no arguments remaining, return accumulator as is
         [() acc]

         ;; next argument is '--' separator, split off passthru and
         ;; return
         [("--" . passthru)
          (begin
            (build-args-passthru-set! acc passthru)
            acc)]

         [(arg . rest)
          ;; set target if not already known (and if the first
          ;; argument does not look like an accidental unknown
          ;; parameter)
          (if (and (not (build-args-target acc))
                   (not (substring=? "-" arg)))
              (begin
                (build-args-target-set! acc (guarantee-success (parse-target arg)))
                (parse-build-args acc rest))

              ;; otherwise, collect unknown arguments
              (begin
                (build-args-unknown-set! acc (append (or (build-args-unknown acc) '())
                                                     (list arg)))
                (parse-build-args acc rest)))]))

;; parse the passed build args, applying sanity checks and defaulting
;; the target if necessary, then execute the build
(define (build args)
  (let ((parsed (parse-build-args (make-build-args #f #f #f) args)))
    ;; fail if there are unknown arguments present
    (when (build-args-unknown parsed)
      (let ((unknown (string-intersperse (build-args-unknown parsed))))
        (mg-error (sprintf "unknown arguments: ~a

if you meant to pass these arguments to nix, please separate them with
'--' like so:

  mg build ~a -- ~a"
                        unknown
                        (or (build-args-target parsed) "")
                        unknown))))

    ;; default the target to the current folder's main target
    (unless (build-args-target parsed)
      (build-args-target-set! parsed (empty-target)))

    (execute-build parsed)))

(define (execute-shell t)
  (let ((expr (nix-expr-for t))
        (user-shell (or (get-environment-variable "SHELL") "bash")))
    (fprintf (current-error-port) "[mg] entering shell for ~A~%" t)
    (process-execute "nix-shell"
                     (list "-E" expr "--command" user-shell))))

(define (shell args)
  (match args
         [() (execute-shell (empty-target))]
         [(arg) (execute-shell
                 (guarantee-success (parse-target arg)))]
         [other (print "not yet implemented")]))

(define (repl args)
  (process-execute "nix" (append (list "repl" "--show-trace" (repository-root)) args)))

(define (execute-run t #!optional cmd-args)
  (fprintf (current-error-port) "[mg] building target ~A~%" t)
  (let* ((expr (nix-expr-for t))
         (out (call-with-input-pipe
               (apply string-append
                      ;; TODO(sterni): temporary gc root
                      (intersperse `("nix-build" "-E" ,(qs expr) "--no-out-link")
                                   " "))
               (lambda (p)
                 (string-chomp (let ((s (read-string #f p)))
                                 (if (eq? s #!eof) "" s)))))))

    ;; TODO(sterni): can we get the exit code of nix-build somehow?
    (when (= (string-length out) 0)
      (mg-error (string-append "Couldn't build target " (format "~A" t)))
      (exit 1))

    (fprintf (current-error-port) "[mg] running target ~A~%" t)
    (process-execute
     ;; If the output is a file, we assume it's an executable à la writeExecline,
     ;; otherwise we look in the bin subdirectory and pick the only executable.
     ;; Handling multiple executables is not possible at the moment, the choice
     ;; could be made via a command line flag in the future.
     (if (regular-file? out)
         out
         (let* ((dir-path (string-append out "/bin"))
                (dir-contents (if (directory-exists? dir-path)
                                  (directory dir-path #f)
                                  '())))
           (case (length dir-contents)
             ((0) (mg-error "no executables in build output")
                  (exit 1))
             ((1) (string-append dir-path "/" (car dir-contents)))
             (else (mg-error "more than one executable in build output")
                   (exit 1)))))
     cmd-args)))

(define (run args)
  (match args
         [() (execute-run (empty-target))]
         ;; TODO(sterni): flag for selecting binary name
         [other (execute-run (guarantee-success (parse-target (car args)))
                             (cdr args))]))

(define (path args)
  (match args
         [(arg)
          (print (apply string-append
                        (intersperse
                         (cons (repository-root)
                               (target-components
                                (normalise-target
                                 (guarantee-success (parse-target arg)))))
                         "/")))]
         [() (mg-error "path command needs a target")]
         [other (mg-error (format "unknown arguments: ~a" other))]))

(define (main args)
  (match args
         [() (print usage)]
         [("build" . _) (build (cdr args))]
         [("shell" . _) (shell (cdr args))]
         [("path" . _) (path (cdr args))]
         [("repl" . _) (repl (cdr args))]
         [("run" . _) (run (cdr args))]
         [other (begin (print "unknown command: mg " args)
                       (print usage))]))

(main (command-line-arguments))