1 files changed, 176 insertions(+), 0 deletions(-)

A modules/cross-shells/cross-profile.scm

@@ 0,0 1,176 @@
+(define-module (cross-shells cross-profile)
+  #:use-module (srfi srfi-1)
+  #:use-module (cross-shells cross-packages)
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+  #:use-module (guix records)
+  #:use-module (guix search-paths)
+  #:use-module (gnu packages commencement)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix build-system trivial)
+  #:export (make-cross-profile
+            cross-profile
+            cross-profile?
+            cross-profile-name
+            cross-profile-host-system
+            cross-profile-target-system
+            cross-profile-native-inputs
+            cross-profile-inputs
+            cross-profile-inputs-from
+
+            %cross-profile-default-base-native-inputs
+            %cross-profile-default-base-inputs
+
+            make-cross-profile-package
+            collect-cross-profile-native-inputs
+            collect-cross-profile-target-inputs
+            collect-cross-profile-search-paths))
+
+;; TODO: allow procedure in native-inputs and inputs
+;;    takes system and target
+
+(define (%cross-profile-default-base-native-inputs system target)
+  (append
+   (standard-packages system)
+   (standard-cross-packages target 'host)))
+
+(define (%cross-profile-default-base-inputs system target)
+  (list))
+
+(define (%cross-profile-default-base-target-inputs system target)
+  (standard-cross-packages target 'target))
+
+(define-record-type* <cross-profile> cross-profile make-cross-profile
+  cross-profile?
+  (name cross-profile-name (default "default"))
+  (host-system cross-profile-host-system (default (%current-system)))
+  (target-system cross-profile-target-system)
+  ;; The default native inputs and inputs. Those are
+  ;; taken out of the gnu-build-system.
+  (base-native-inputs cross-profile-base-native-inputs (default %cross-profile-default-base-native-inputs))
+  (base-target-inputs cross-profile-base-target-inputs (default %cross-profile-default-base-target-inputs))
+  (base-inputs cross-profile-base-inputs (default %cross-profile-default-base-inputs))
+  ;; The inputs that are runnable on the host system
+  (native-inputs cross-profile-native-inputs (default '()))
+  ;; The packages to get for the target system, like libraries.
+  (inputs cross-profile-inputs (default '()))
+  ;; The packages to get for the target system, like libraries.
+  (target-inputs cross-profile-target-inputs (default '()))
+  ;; Take inputs/native-inputs from the given packages.
+  (inputs-from cross-profile-inputs-from (default '())))
+
+(define transitive-inputs
+  (@@ (guix packages) transitive-inputs))
+
+(define (collect-cross-profile-target-inputs cross-profile)
+  ;; Get all inputs (merged inputs and inputs-from inputs)
+  ;; Also collect propagated inputs. Make sure only unique packages.
+  ;; NOTE look how profiles work
+  (match-record
+      cross-profile <cross-profile>
+      (target-inputs base-target-inputs host-system target-system)
+    (map (lambda (input)
+           (car (cdr input)))
+         (transitive-inputs
+              (append
+               (base-target-inputs host-system target-system)
+               target-inputs)))))
+
+(define (collect-cross-profile-inputs cross-profile)
+  ;; Get all inputs (merged inputs and inputs-from inputs)
+  ;; Also collect propagated inputs. Make sure only unique packages.
+  ;; NOTE look how profiles work
+  (match-record
+      cross-profile <cross-profile>
+      (inputs inputs-from base-inputs host-system target-system)
+      (map (lambda (input)
+             (if (package? input)
+                 input
+                 (car (cdr input))))
+         (transitive-inputs
+              (append
+               (base-inputs host-system target-system)
+               (apply append (map package-inputs inputs-from))
+               inputs)))))
+
+(define (collect-cross-profile-native-inputs cross-profile)
+  ;; Get all nativeinputs (merged native-inputs and inputs-from native-inputs)
+  (match-record
+      cross-profile <cross-profile>
+      (native-inputs inputs-from base-native-inputs host-system target-system)
+    (map (lambda (input)
+           (car (cdr input)))
+         (transitive-inputs
+          (append
+           (base-native-inputs host-system target-system)
+           (apply append (map package-native-inputs inputs-from))
+           native-inputs)))))
+
+(define (collect-cross-profile-search-paths cross-profile)
+  (match-record
+   cross-profile <cross-profile>
+   (name target-system)
+   (apply append
+         (append
+          (append (map package-native-search-paths
+                       (collect-cross-profile-native-inputs cross-profile)))
+          (append (map (lambda (package)
+                         (map
+                          (lambda (search-path)
+                            (search-path-specification
+                             (inherit search-path)
+                             (files (map
+                                     (lambda (file)
+                                       (string-append "cross/" target-system "/" name "/" file))
+                                     (search-path-specification-files search-path)))))
+                          (package-search-paths package)))
+                       (append
+                        (collect-cross-profile-target-inputs cross-profile)
+                        (collect-cross-profile-inputs cross-profile))))))))
+
+
+;; output is a package.
+;; but this package is sort of like a profile.
+;; it will have all files under cross/{target}.
+;; it will put all accumulated search-paths to native-search-paths
+;; Takes a cross-profile, and outputs a package that represents the cross profile
+(define (make-cross-profile-package cross-profile)
+  (match-record
+      cross-profile <cross-profile>
+      (name host-system target-system native-inputs inputs inputs-from)
+    (let ((cross-profile-name name))
+      (package
+        (name (string-append "cross-profile-" name))
+        (source #f)
+        (version "0")
+        (build-system trivial-build-system)
+        (native-search-paths ;; collect search paths of all inputs
+         (collect-cross-profile-search-paths cross-profile))
+        (arguments
+         (list
+          #:modules '((guix build utils)
+                      (guix build union))
+          #:builder #~(begin
+                        (use-modules
+                         (guix build utils)
+                         (guix build union))
+                        (let ((inputs-paths
+                               (list #$@(collect-cross-profile-target-inputs cross-profile)
+                                     #$@(map (lambda (package)
+                                               (cross-package-job
+                                                (package package)
+                                                (target target-system)
+                                                (system host-system)))
+                                             (collect-cross-profile-inputs cross-profile))))
+                              (cross-profile-path
+                               (string-append #$output "/cross/" #$target-system "/" #$cross-profile-name))
+                              (native-inputs-paths
+                               (list #$@(collect-cross-profile-native-inputs cross-profile))))
+
+                          (union-build #$output native-inputs-paths)
+                          (mkdir-p (dirname cross-profile-path))
+                          (union-build cross-profile-path inputs-paths)))))
+        (synopsis "A cross profile package")
+        (description "A cross profile package")
+        (home-page #f)
+        (license #f)))))