@@ 20,6 20,7 @@
(guix utils)
(guix packages)
(guix build-system gnu)
+ (guix build-system trivial)
(gnu system accounts)
(ruther services system)
(ruther services bind)
@@ 417,93 418,39 @@
(ice-9 match)
(guix records))
-(define-record-type <non-grafted>
- (non-grafted derivation)
- non-grafted?
- (derivation non-grafted-derivation))
-
-(define-gexp-compiler (non-grafted-compiler (non-grafted <non-grafted>) system target)
- (mlet* %store-monad ((drv (non-grafted-derivation non-grafted)))
- (without-grafting
- (gexp->derivation "non-grafted"
- #~(symlink #$drv #$output)))))
-
-(define-record-type* <drv-name>
- drv-name-record drv-name
- drv-name?
- (derivation drv-name-derivation)
- (override-grafts? drv-name-override-grafts?
- (default #f)))
-
-(define-gexp-compiler (drv-name-compiler (drv-name <drv-name>) system target)
- (let ((drv-name-store (derivation->drv-name (drv-name-derivation drv-name))))
- (if (drv-name-override-grafts? drv-name)
- (without-grafting drv-name-store)
- drv-name-store)))
+(define (non-grafted file)
+ (computed-file
+ "non-grafted"
+ #~(symlink
+ #$(with-parameters
+ ((%graft? #f))
+ file)
+ #$output)))
(define <operating-system> (@@ (gnu system) <operating-system>))
(define-gexp-compiler (os-compiler (os <operating-system>) system target)
(operating-system-derivation os))
-;; I don't know why the inputs aren't getting grafted here, but they aren't, that's good here.
-(define (make-non-grafted-package pkgs)
- (package
- (name "non-grafted-pkg")
- (version "0")
- (synopsis #f)
- (source #f)
- (description #f)
- (home-page #f)
- (license #f)
- (build-system (@ (guix build-system trivial) trivial-build-system))
- ;; (inputs pkgs)
- (arguments
- (list
- #:builder #~(begin
- (use-modules
- (srfi srfi-19))
-
- (mkdir #$output)
-
- (for-each (lambda (pkg)
- (symlink
- pkg
- (string-append #$output "/" (basename pkg))))
- '#$pkgs)
-
- (symlink #$guile-3.0:debug (string-append #$output "/" "guile-debug"))
- (symlink #$(libc-utf8-locales-for-target):static (string-append #$output "/" "guile-debug"))
-
- ;; (for-each (lambda (pkg)
- ;; (unless (file-exists? (string-append #$output "/" (basename pkg)))
- ;; (symlink
- ;; pkg
- ;; (string-append #$output "/" (basename pkg)))))
- ;; (map cdr %build-inputs))
- )))))
-
;; Takes an operating system and gc roots its derivation
(define (operating-system-with-build-inputs os)
(operating-system
(inherit os)
- (services (operating-system-user-services os))
(services
(cons*
(simple-service 'gc-root-system-derivation
gc-root-service-type
(list
- (drv-name (operating-system-derivation os) #t)
- (drv-name (operating-system-derivation os) #f)
- (non-grafted (operating-system-derivation os))
+ (non-grafted os)
(libc-utf8-locales-for-target)
guile-3.0
- (make-non-grafted-package
- (list
- guile-3.0
- ;; `(,guile-3.0 "debug")
- (libc-utf8-locales-for-target)
- texinfo))))
+ ;; (map
+ ;; non-grafted
+ ;; (list
+ ;; guile-3.0
+ ;; (libc-utf8-locales-for-target)
+ ;; texinfo))
+ ))
(operating-system-user-services os)))))
-(operating-system-with-build-inputs %ruther/base-laptop-os)
+;; (operating-system-with-build-inputs %ruther/base-laptop-os)
%ruther/base-laptop-os