(define-module (ruther environment)
  #:use-module (srfi srfi-1)
  #:use-module (ruther modules)
  #:use-module (guix profiles)
  #:use-module (gnu packages)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix packages)
  #:use-module (guix build-system trivial)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages python)
  #:use-module (gnu packages commencement)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages file)
  #:export (make-environment
             make-interpreted-environment
             make-python-environment
             make-guile-environment
             package->application-environment))

(define (manifest->packages manifest)
  "Return the list of packages in MANIFEST."
  (filter-map (lambda (entry)
                (let ((item (manifest-entry-item entry)))
                  (if (package? item) item #f)))
              (manifest-entries manifest)))

;; Makes a package that uses the given environment, and wraps the binaries in it.
;; TODO: replace the paths (only in text files!!! not in binaries...) in all extra-paths files,
;; so instead of symlinking some of the files might have to be just copied and substituted.
;; this also means it might come in handy to create all directories instead and symlink only the files.
(define* (make-environment manifest
                           #:key
                           (name "environment")
                           (binary-paths '("bin"))
                           (extra-paths '("share/info" "share/man" "share/doc" "share/applications"))
                           (rename-function #~identity)
                           (filter-function #~(const #t))
                           (replace-shell-wrappers? #f))
  "Takes a manifest, makes a package that will have all the binaries the profile has, wrapped to use etc/profile
"
  (let ((profile (profile (content manifest))))
    (package
     (name name)
     (version "0")
     (source #f)
     (build-system trivial-build-system)
     (native-inputs
      (cons* file
             (if replace-shell-wrappers?
                 (list gcc-toolchain)
                 '())))
     (inputs
      (cons* static-bash
            (manifest->packages manifest)))
     (arguments
      (list
       #:modules (source-module-closure
                  '((guix build utils)
                    (ruther build wrappers)
                    (ruther build environment))
                  #:select? ruther-module-name?)
       #:builder #~(begin
                     (use-modules (guix build utils)
                                  (ruther build environment)
                                  (ruther build wrappers)
                                  (ice-9 ftw)
                                  (srfi srfi-1))
                     (mkdir-p #$output)

                     ;; Iterate all binary-paths under profile and make scripts in output
                     (let* ((profile-path #$profile)
                            (not-directory? (lambda (base-path)
                                              (lambda (path)
                                                (let ((s (stat (string-append base-path "/" path))))
                                                  (not (eq? (stat:type s) 'directory))))))
                            (binary-folders (list #$@binary-paths))
                            (profile-binary-folders (map (lambda (folder)
                                                           (string-append profile-path "/" folder))
                                                    binary-folders))
                            (output-binary-folders (map (lambda (folder)
                                                           (string-append #$output "/" folder))
                                                    binary-folders))
                            (binaries (apply append (map (lambda (folder)
                                                           (map
                                                            (lambda (file)
                                                              (string-append folder "/" file))
                                                            (scandir (string-append profile-path "/" folder)
                                                                     (not-directory? (string-append profile-path "/" folder)))))
                                                         binary-folders)))
                            (profile-binaries (map (lambda (binary)
                                                     (string-append profile-path "/" binary))
                                                   binaries))
                            (output-binaries (map (lambda (binary)
                                                    (string-append
                                                     #$output "/" (dirname binary) "/" (#$rename-function (basename binary))))
                                                   binaries))
                            (profile-binaries-realpaths (map canonicalize-path profile-binaries))
                            (extra-folders (list #$@extra-paths)))

                       (set-path-environment-variable
                        "PATH" '("bin" "sbin")
                        (list
                         #$@(map (compose car cdr)
                                 (package-native-inputs this-package))))

                       (set-path-environment-variable
                        "TARGET" '("bin" "sbin")
                        (list
                         #$@(map (compose car cdr)
                                 (package-inputs this-package))))

                       (format #t "Copying binary files...~%")
                       (copy-binary-files
                        #$output
                        output-binary-folders
                        profile-path
                        binaries
                        #:filter-function #$filter-function
                        #:rename-function #$rename-function)

                       (when #$replace-shell-wrappers?
                         (format #f "Replacing shell wrappers...~%")
                         (replace-wrappers-with-binaries output-binaries))

                       ;; Iterate all extra-paths and symlink them to output.
                       (format #t "Copying extra files...~%")
                       (copy-extra-files #$output profile-path extra-folders)
                       (format #t "Patching extra files...~%")
                       (patch-extra-files #$output (zip profile-binaries-realpaths output-binaries))))))
     (synopsis #f)
     (description #f)
     (home-page #f)
     (license #f))))

(define* (make-interpreted-environment
          target-name
          interpreter-package
          interpreter-binary-name
          packages-specifications)
  (make-environment
    (concatenate-manifests
     (list (specifications->manifest packages-specifications)
           (packages->manifest (list interpreter-package))))
    #:name target-name
    #:extra-paths '()
    #:rename-function
    #~(lambda (file)
        #$target-name)
    #:filter-function
    #~(lambda (file)
        (string=? (string-append "bin/" #$interpreter-binary-name) file))))

(define* (make-python-environment
          target-name
          python-packages
          #:key (python python))
  (make-interpreted-environment
   target-name
   python
   "python3"
   python-packages))

(define* (make-guile-environment
          target-name
          guile-packages
          #:key (guile guile))
  (make-interpreted-environment
   target-name
   python
   "guile"
   guile-packages))

(define* (package->application-environment
          application)
  (make-environment
    (package->manifest application)
    #:name (string-append(package-name application) "environment")))