1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889 |
- (use-modules (guix inferior) (guix channels)
- (guix)
- (guix ui)
- (srfi srfi-1)
- (ice-9 match))
- (setvbuf (current-error-port) 'line)
- (set-current-output-port (current-error-port))
- (define (find-current-checkout arguments)
- "Find the first checkout of ARGUMENTS that provided the current file.
- Return #f if no such checkout is found."
- (let ((current-root
- (canonicalize-path
- (string-append (dirname (current-filename)) "/../.."))))
- (find (lambda (argument)
- (and=> (assq-ref argument 'file-name)
- (lambda (name)
- (string=? name current-root)))) arguments)))
- (define (hydra-jobs store arguments)
- "Return a list of jobs where each job is a NAME/THUNK pair."
- (define checkout
- (find-current-checkout arguments))
- (define commit
- (assq-ref checkout 'revision))
- (define source
- (assq-ref checkout 'file-name))
- (define instance
- (checkout->channel-instance source #:commit commit))
- (define derivation
-
- (run-with-store store
- (channel-instances->derivation (list instance))))
-
-
- (show-what-to-build store (list derivation))
- (build-derivations store (list derivation))
-
- (let ((inferior (open-inferior (derivation->output-path derivation))))
- (inferior-eval '(use-modules (gnu ci) (ice-9 match)) inferior)
- (map (match-lambda
- ((name . fields)
-
- (cons name (lambda () fields))))
- (inferior-eval-with-store
- inferior store
- `(lambda (store)
- (map (match-lambda
- ((name . thunk)
- (cons name (thunk))))
- (hydra-jobs store '((superior-guix-checkout . ,checkout)
- ,@arguments))))))))
|