;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;;
;;; This script updates package definitions so they use the "simplified" style
;;; for input lists, as in:
;;;
;;;  (package
;;;    ;; ...
;;;    (inputs (list foo bar baz)))
;;;
;;; Code:

(use-modules (gnu packages)
             (guix packages)
             (guix utils)
             (guix i18n)
             (guix diagnostics)
             (ice-9 control)
             (ice-9 match)
             (ice-9 pretty-print)
             (srfi srfi-26))

(define (simplify-inputs location package str inputs)
  "Simplify the inputs field of PACKAGE (a string) at LOCATION; its current
value is INPUTS the corresponding source code is STR.  Return a string to
replace STR."
  (define (label-matches? label name)
    ;; Return true if LABEL matches NAME, a package name.
    (or (string=? label name)
        (and (string-prefix? "python-" label)
             (string-prefix? "python2-" name)
             (string=? (string-drop label (string-length "python-"))
                       (string-drop name (string-length "python2-"))))))

  (define (insert-margin-comments exp new-str)
    ;; Given NEW-STR, a pretty-printed representation of EXP, insert margin
    ;; comments that appeared in STR, the original source, when possible.
    (if (string-index str #\;)
        (let ((old-lines (string-split (string-trim-both str) #\newline))
              (new-lines (string-split new-str #\newline)))
          (match exp
            (('list symbols ...)
             (if (= (length old-lines) (length new-lines)
                    (length symbols))
                 (string-join
                  (map (lambda (symbol old-line new-line)
                         (match (string-index old-line #\;)
                           (#f new-line)
                           (index
                            (let ((comment (string-drop old-line index)))
                              (string-append new-line
                                             " "
                                             comment)))))
                       symbols old-lines new-lines)
                  "\n")
                 (begin
                   (warning location (G_ "~a: margin comment will be lost~%")
                            package)
                   new-str)))))
        new-str))

  (define (object->string obj)
    ;; Render OBJ as a string preserving surrounding indentation.  Trim extra
    ;; space on the first line and extra newline at the end.
    (insert-margin-comments
     obj
     (string-trim-both
      (call-with-output-string
        (lambda (port)
          (pretty-print obj port
                        #:width 80
                        #:per-line-prefix
                        (make-string (location-column location)
                                     #\space)))))))

  (let/ec return
    (object->string
     `(list ,@(map (lambda (exp input)
                     (define package* package)

                     (match input
                       ((or ((? string? label) (? package? package))
                            ((? string? label) (? package? package)
                             (? string?)))
                        ;; If LABEL doesn't match PACKAGE's name, then
                        ;; simplifying would incur a rebuild, and perhaps it
                        ;; would break build-side code relying on this
                        ;; specific label.
                        (if (label-matches? label (package-name package))
                            (match exp
                              ((label ('unquote symbol)) symbol)
                              ((label ('unquote symbol) output)
                               (list 'quasiquote
                                     (list (list 'unquote symbol)
                                           output)))
                              (_
                               ;; EXP doesn't look like INPUT.
                               (warning location (G_ "~a: complex expression, \
bailing out~%")
                                        package*)
                               (return str)))
                            (begin
                              (warning location (G_ "~a: input label \
'~a' does not match package name, bailing out~%")
                                       package* label)
                              (return str))))
                       (_
                        (warning location (G_ "~a: non-trivial input, \
bailing out~%")
                                 package*)
                        (return str))))
                   (match (call-with-input-string str read)
                     (('quasiquote (exp ...))
                      ;; If EXP and INPUTS have a different length, that means
                      ;; EXP is a non-trivial input list, for example with
                      ;; input-splicing, conditionals, etc.
                      (unless (= (length exp) (length inputs))
                        (warning location (G_ "~a: computed input list, \
bailing out~%")
                                 package)
                        (return str))
                      exp)
                     (('list _ ...)               ;already done
                      (return str))
                     (_
                      (warning location (G_ "~a: unsupported input style, \
bailing out~%")
                               package)
                      (return str)))
                   inputs)))))

(define (simplify-package-inputs package)
  "Edit the source code of PACKAGE to simplify its inputs field if needed."
  (for-each (lambda (field-name field)
              (match (field package)
                (()
                 #f)
                (inputs
                 (match (package-field-location package field-name)
                   (#f
                    ;; (unless (null? (field package))
                    ;;   (warning (package-location package)
                    ;;            (G_ "source location not found for '~a' of '~a'~%")
                    ;;            field-name (package-name package)))
                    #f)
                   (location
                    (edit-expression (location->source-properties location)
                                     (lambda (str)
                                       (simplify-inputs location
                                                        (package-name package)
                                                        str inputs))))))))
            '(inputs native-inputs propagated-inputs)
            (list package-inputs package-native-inputs
                  package-propagated-inputs)))


(define (package-location<? p1 p2)
  "Return true if P1's location is \"before\" P2's."
  (let ((loc1 (package-location p1))
        (loc2 (package-location p2)))
    (and loc1 loc2
         (if (string=? (location-file loc1) (location-file loc2))
             (< (location-line loc1) (location-line loc2))
             (string<? (location-file loc1) (location-file loc2))))))

(for-each simplify-package-inputs
          ;; Sort package by source code location so that we start editing
          ;; files from the bottom and going upward.  That way, the 'location'
          ;; field of <package> records is not invalidated as we modify files.
          (sort (map specification->package (cdr (command-line)))
                (negate package-location<?)))