;;; Guix Home Manager.

;;;

;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>

;;;

;;; This program is free software: you can redistribute it and/or modify

;;; it under the terms of the GNU General Public License as published by

;;; the Free Software Foundation, either version 3 of the License, or

;;; (at your option) any later version.

;;;

;;; This program is distributed in the hope that it will be useful,

;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

;;; GNU General Public License for more details.

;;;

;;; You should have received a copy of the GNU General Public License

;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(define-module (home)

  #:use-module (guix build union)

  #:use-module (guix build utils)

  #:use-module (guix build-system trivial)

  #:use-module (guix gexp)

  #:use-module (guix licenses)

  #:use-module (guix packages)

  #:use-module (guix records)

  #:use-module (guix ui)

  #:use-module (guix utils)

  #:use-module (ice-9 match)

  #:use-module (ice-9 vlist)

  #:use-module (home build utils)

  #:use-module (srfi srfi-1)

  #:use-module (srfi srfi-9)

  #:use-module (srfi srfi-35)

  #:export (use-home-modules

            home

            home?

            home-data-directory

            home-guix-symlink

            home-guix-config-symlink

            home-local-symlink

            home-cache-symlink

            home->derivation

            user-home

            user-home-type

            user-home-value

            home-type

            home-type?

            home-type-name

            home-type-extensions

            home-type-extension-points

            home-type-default-value

            home-type-description

            home-type-location

            home-extension

            home-extension?

            home-extension-target

            home-extension-target-point

            home-extension-compute

            home-extension-point

            home-extension-point?

            home-extension-point-name

            home-extension-point-compose

            home-extension-point-extend

            root-home-type))

;;;

;;; Service-like home configuration mechanism

;;;

(define &no-default-value

  '(no default value))

(define-record-type* <home-extension> home-extension make-home-extension

  home-extension?

  (target home-extension-target ; home-type

          (default #f))

  (point  home-extension-target-point ; symbol

          (default #f))

  ;; A function that takes the user-home value as parameter and returns the

  ;; value to be passed to the extension point.

  (compute  home-extension-compute))

(define-record-type* <home-extension-point> home-extension-point

  make-home-extension-point home-extension-point?

  (name home-extension-point-name ; symbol

        (default #f))

  ;; A function that composes extensions. It is passed a list of extension values

  ;; and returns one extension value

  (compose home-extension-point-compose)

  ;; A function that extends the original service value with the result of

  ;; the composition.  It is passed two arguments: the user-home value and the

  ;; result of the composition.  It returns a new user-home value.

  (extend home-extension-point-extend)) ; any(value) -> any(compose) -> any(value)

(define-record-type* <home-type> home-type make-home-type

  home-type?

  (name             home-type-name) ; symbol

  (extensions       home-type-extensions ; list home-extension

                    (default #f))

  (extension-points home-type-extension-points ; list home-extension-point

                    (default #f))

  (default-value    home-type-default-value ; any

                    (default &no-default-value))

  (description      home-type-description ; string

                    (default #f))

  (location         home-type-location

                    (default (and=> (current-source-location)

                                    source-properties->location))

                    (innate)))

(define-record-type <user-home>

  (make-user-home type value)

  user-home?

  (type  user-home-type)

  (value user-home-value))

(define-syntax user-home

  (syntax-rules ()

    "Return a user-home instance of TYPE.  The user-home value is VALUE or, if

omitted, TYPE's default value."

    ((_ type value)

     (make-user-home type value))

    ((_ type)

     (%user-home-with-default-value (current-source-location)

                                    type))))

(define (%user-home-with-default-value location type)

  "Return an instance of user-home type TYPE with its default value, if any.  If

TYPE does not have a default value, an error is raised."

  ;; TODO: Currently this is a run-time error but with a little bit macrology

  ;; we could turn it into an expansion-time error.

  (let ((default (home-type-default-value type)))

    (if (eq? default &no-default-value)

        (let ((location (source-properties->location location)))

          (raise

           (condition

            (&missing-value-home-error (type type) (location location))

            (&message

             (message (format #f (G_ "~a: no value specified \

for home configuration of type '~a'")

                              (location->string location)

                              (home-type-name type)))))))

        (make-user-home type default))))

(define-condition-type &home-error &error

  home-error?)

(define-condition-type &missing-value-home-error &home-error

  missing-value-home-error?

  (type     missing-value-home-error-type)

  (location missing-value-home-error-location))

(define-condition-type &missing-target-home-error &home-error

   missing-target-home-error?

   (home         missing-target-home-error-home)

   (target-type  missing-target-home-error-target-type))

(define-condition-type &ambiguous-target-home-error &home-error

   ambiguous-target-home-error?

   (home         missing-target-home-error-home)

   (target-type  missing-target-home-error-target-type))

(define root-home-type

  (home-type

    (name 'root)

    (extension-points

      (list (home-extension-point

          (compose (lambda (l) (apply append l)))

          (extend (lambda (v l) (apply append v l))))))

    (default-value '())

    (description "The root home type")))

;;;

;;; Home composition

;;;

(define (missing-target-error home target-type)

  (raise

    (condition (&missing-target-home-error

                 (home home)

                 (target-type target-type))

               (&message

                 (message

                   (format #f (G_ "no target of type '~a' for home configuration '~a'")

                           (home-type-name target-type)

                           (home-type-name

                             (user-home-type home))))))))

(define (home-back-edges homes)

  "Return a procedure which, when passed a user-home from HOMES, returns the

list of <user-home> that extend it."

  (define (add-edges home edges)

    (define (add-edge extension edges)

      (define (add-extension-edge target edges)

        (vhash-consq target home edges))

      (let ((target-type (home-extension-target extension))

            (target-point (home-extension-target-point extension)))

        (match (filter

                 (lambda (home)

                   (if target-type

                       (eq? (user-home-type home) target-type)

                       (and target-point

                            (not (null? (filter

                                          (lambda (extension-point)

                                            (eq?

                                              (home-extension-point-name extension-point)

                                              target-point))

                                          (home-type-extension-points

                                            (user-home-type home))))))))

                 homes)

          ((target ...)

           (fold add-extension-edge edges target))

          (()

           (missing-target-error home target-type)))))

    (let ((extensions (home-type-extensions (user-home-type home))))

      (if extensions

        (fold add-edge edges (home-type-extensions (user-home-type home)))

        edges)))

  (let ((edges (fold add-edges vlist-null homes)))

    (lambda (node)

      (reverse (vhash-foldq* cons '() node edges)))))

(define (instantiate-missing-user-homes homes)

  "Return HOMES, a list of user-home, augmented with any user-home targeted by

extensions and missing from HOMES.  Only home types with a default value can

be instantiated; other missing user-homes lead to a '&missing-target-home-error'."

  (let loop ((homes homes))

    (define (not-present? target)

      (let ((target-type (home-extension-target target)))

        (and target-type

            (null? (filter (lambda (home)

                             (eq? (user-home-type home) target-type))

                           homes)))))

    (define additions

      (append-map

        (lambda (home)

          (let ((extensions (home-type-extensions (user-home-type home))))

            (if extensions

              (map (lambda (extension) (home-extension-target extension))

                   (filter not-present? extensions))

              '())))

        homes))

    (define (uniq lst)

      (let loop ((types lst) (result '()))

        (match types

          ((type types ...)

           (if (member type types)

               (loop types result)

               (loop types (cons type result))))

          (() result))))

    (define generated

      (map

        (lambda (type)

          (let ((default (home-type-default-value type)))

            (if (eq? default &no-default-value)

                (missing-target-error home target-type)

                (make-user-home type default))))

        (uniq additions)))

    (if (null? generated)

        homes

        (loop (append homes generated)))))

(define (fold-home target-type homes)

  "fold HOMES by successively resolving extension points, until we get only

one user-home of type TARGET-TYPE."

  (define dependents

    (home-back-edges homes))

  (define (apply-extension target)

    (define (update-extension extensions point home)

      (let* ((point-name (home-extension-point-name point))

             (matched-extensions

               (filter (lambda (extension)

                         (if point-name

                             (eq? (home-extension-target-point extension)

                                  point-name)

                             (eq? (home-extension-target extension)

                                  (user-home-type target))))

                       (home-type-extensions (user-home-type home)))))

        (if (null? matched-extensions)

            extensions

            (append

              (map

                (lambda (extension)

                  `(,point-name ,((home-extension-compute extension)

                                  (user-home-value home))))

                matched-extensions)

              extensions))))

    (lambda (home)

      (let loop ((extensions '()) (points (home-type-extension-points

                                            (user-home-type target))))

        (match points

          (() extensions)

          ((point points ...)

           (loop

             (update-extension extensions point home)

             points))))))

  (define (merge-extensions points extensions)

    (let loop ((points points) (extensions extensions))

      (match points

        (() extensions)

        (((point value) points ...)

         (loop points (acons point

                             (let ((v (assoc-ref extensions point)))

                               (if v (cons value v) (list value)))

                             extensions))))))

  (define (compose-extension target)

    (lambda (extension)

      (match extension

        ((point-name values ...)

         (match (filter

                  (lambda (extension-point)

                      (eq? (home-extension-point-name extension-point) point-name))

                    (home-type-extension-points (user-home-type target)))

           ((point)

            (list

              point-name

              ((home-extension-point-compose point)

               values))))))))

  (match (filter (lambda (home)

                   (eq? (user-home-type home) target-type))

                 homes)

    ((sink)

     (let loop ((sink sink))

       (let* ((dependents (map loop (dependents sink)))

              (extensions (map (apply-extension sink) dependents))

              (extensions (fold merge-extensions '() extensions))

              (extensions (map (compose-extension sink) extensions)))

         (user-home

           (user-home-type sink)

           (let ((extension-points (home-type-extension-points (user-home-type sink))))

             (if extension-points

               (fold (lambda (extension-point value)

                       (let* ((extend (home-extension-point-extend extension-point))

                              (name (home-extension-point-name extension-point))

                              (extension-value (assoc-ref extensions name)))

                         (if extension-value

                             (extend value extension-value)

                             value)))

                     (user-home-value sink)

                     (home-type-extension-points (user-home-type sink)))

               (user-home-value sink)))))))

    (()

     (raise

       (condition (&missing-target-home-error

                    (home #f)

                    (target-type target-type))

                  (&message

                    (message (format #f (G_ "home configuration of type '~a' not found")

                                     (home-type-name target-type)))))))

    (x

      (raise

        (condition (&ambiguous-target-home-error

                    (home #f)

                    (target-type target-type))

                   (&message

                    (message (format #f (G_ "home configuration of type '~a' not found")

                                     (home-type-name target-type)))))))))

;;;

;;; Home generation

;;;

(define-syntax use-home-modules

  (syntax-rules ()

    ((_ modules ...)

     (use-modules (home modules) ...))))

(define-record-type* <home> home

  make-home

  home?

  (data-directory home-data-directory)

  (base-configuration home-base-configuration (thunked)

    (default

      (base-home-configuration

        (guix-symlink

          (string-append (home-data-directory this-record) "/.guix-profile"))

        (guix-config-symlink

          (string-append (home-data-directory this-record) "/.config/guix"))

        (local-symlink

          (string-append (home-data-directory this-record) "/.local"))

        (cache-symlink

          (string-append (home-data-directory this-record) "/.cache")))))

  (configurations home-configurations

                  (default (list (user-home root-home-type)))))

(define-record-type* <base-home-configuration> base-home-configuration

  make-base-home-configuration

  base-home-configuration?

  (guix-symlink        base-home-configuration-guix-symlink)

  (guix-config-symlink base-home-configuration-guix-config-symlink)

  (local-symlink       base-home-configuration-local-symlink)

  (cache-symlink       base-home-configuration-cache-symlink))

(define base-home-type

  (home-type

    (name 'guix)

    (extensions

      (list

        (home-extension

          (target root-home-type)

          (compute (lambda (config)

                     `((".guix-profile"

                        ,(base-home-configuration-guix-symlink config))

                       (".config/guix"

                        ,(base-home-configuration-guix-config-symlink config))

                       (".local"

                        ,(base-home-configuration-local-symlink config))

                       (".cache"

                        ,(base-home-configuration-cache-symlink config))))))))))

(define (home->derivation home)

  (define builder

    (with-imported-modules

      '((guix build utils) (home build utils) (ice-9 match))

      #~(begin

          (use-modules (guix build utils) (home build utils) (ice-9 match))

          #$(let* ((homes (instantiate-missing-user-homes

                            (cons

                              (user-home base-home-type (home-base-configuration home))

                              (home-configurations home))))

                   (root (fold-home root-home-type homes))

                   (configs (user-home-value root)))

              #~(for-each

                  (lambda (config)

                    (match config

                      ((home-name target)

                       (mkdir-p (dirname (home-file #$output home-name)))

                       (symlink target (home-file #$output home-name)))))

                  '(#$@configs))))))

  (gexp->derivation "home" builder

                    #:substitutable? #f

                    #:local-build? #t))