;;; 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 #f 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))