;;; GNU Guix web site
;;; Initially written by sirgazil who waives all
;;; copyright interest on this file.

(define-module (apps packages templates components)
  #:use-module (apps aux lists)
  #:use-module (apps aux strings)
  #:use-module (apps aux web)
  #:use-module (apps base templates components)
  #:use-module (apps base utils)
  #:use-module (apps i18n)
  #:use-module (apps packages data)
  #:use-module (apps packages types)
  #:use-module (apps packages utils)
  #:use-module (guix licenses)
  #:use-module (guix packages)
  #:use-module ((guix i18n) #:select (P_))
  #:use-module (guix gnu-maintenance)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (texinfo)
  #:use-module (texinfo plain-text)
  #:export (detailed-package-preview
	    issue-count->shtml
	    letter-selector
	    license->shtml
	    lint-issue->shtml
	    location->shtml
	    package-preview
	    patches->shtml
	    sidebar
	    supported-systems->shtml))


;;;
;;; Components.
;;;

(define (detailed-package-preview package)
  "Return an SHTML div element representing the given PACKAGE object.

   PACKAGE (<package>)
     A package object as defined in the GNU Guix API reference."
  `(div
    (@ (class "package-preview"))
    (h3
     (@ (class "package-name"))
     ,(package-name package) " " ,(package-version package) " "
     ,(if (package-issues? package) '(span (@ (class "red-tag")) "") " ")
     (span
      (@ (class "package-synopsis"))
      " — "
      ,(package-synopsis-shtml package)))

    (div
     (@ (class "package-description"))

     ;; 'gnu-package?' might fetch stuff from the network.  Assume #f if that
     ;; doesn't work.
     ,(if (false-if-exception (gnu-package? package))
          `(p (i ,(G_ "This is a GNU package.  ")))
          "")

     ,(package-description-shtml package))

    (ul
     (@ (class "package-info"))
     ,(G_ `(li ,(G_ `(b "License:")) " "
               ,(license->shtml (package-license package))
               "."))

     ,(G_ `(li ,(G_ `(b "Website:")) " "
               ,(link-subtle #:label (package-home-page package)
                             #:url (package-home-page package)) "."))

     ,(G_ `(li ,(G_ `(b "Package source:")) " "
               ,(location->shtml (package-location package))
               "."))

     ,(G_ `(li ,(G_ `(b "Patches:")) " "
               ,(patches->shtml (package-patches package))
               "."))

     ,(G_ `(li ,(G_ `(b "Lint issues:")) " "
               ,(if (null? (package-lint-issues package))
                    (G_ "No")
                    (link-subtle #:label (G_ "Yes")
                                 #:url (guix-url "packages/issues/")))
               "."))

     ,(G_ `(li ,(G_ `(b "Builds:")) " "
               ,(supported-systems->shtml package) "."))
     "\n")))


(define (issue-count->shtml count)
  "Return an SHTML representation of COUNT in the form 'X issue(s)'.

   COUNT (natural)
     A natural number.

   RETURN (shtml)
     A span element if the count is 0. A mark element otherwise."
  `(,(if (> count 0) 'mark 'span)
    ,(number->string count)
    ,(N_ " issue" " issues" count)))


(define* (letter-selector #:optional (active-letter ""))
  "Return an SHTML section element representing a widget to list
   packages by initial.

   ACTIVE-LETTER (string)
     The letter that should be displayed as active."
  `(section
    (@ (class "letter-selector"))
    ,(G_ `(h3 (@ (class "a11y-offset")) "Packages menu: "))

    ,(G_ `(h4 (@ (class "selector-title selector-title-top"))
              "Browse alphabetically"))
    (div
     (@ (class "selector-box-padded"))
     ,@(map
	(lambda (letter)
	  (list
	   (button-little
	    #:label letter
	    #:url (guix-url (url-path-join "packages" letter ""))
	    #:active (string=? letter active-letter))
	   " ")) ; NOTE: Force space for readability in non-CSS browsers.
	alphabet))))


(define (license->shtml license)
  "Return an SHTML representation of the LICENSE.

   LICENSE (itemization)
     One of two types of object:
     — A <license> object as defined in the (apps packages types)
       module.
     — A list of <license> objects.

   RETURN (shtml)
     One or more links to the licenses."
  (cond ((license? license)
	 (link-subtle #:label (license-name license)
		      #:url (license-uri license)))
	(else
	 (separate
	  (map (lambda (l) ; a license object.
		 (link-subtle #:label (license-name l)
			      #:url (license-uri l)))
	       license)
	  ", "))))


(define (lint-issue->shtml issue)
  "Return an SHTML div element representing the given ISSUE object.

   ISSUE (<lint-issue>)
     A lint issue object as defined in the (apps packages types) module."
  `(div
    (@ (class "lint-issue"))
    (p (@ (class "lint-issue-type")) ,(lint-issue-type issue) ":")
    (pre ,(lint-issue-description issue))))


(define (location->shtml loc)
  "Return an SHTML a element representing the given location LOC.

   LOC (<location>)
     A location object as defined in the GNU Guix API reference."
  (let ((ilink (location->ilink loc)))
    (link-subtle #:label (ilink-name ilink)
		 #:url (ilink-url ilink))))


(define (package-preview package)
  "Return an SHTML a element representing the given PACKAGE object.

   PACKAGE (<package>)
     A package object as defined in the GNU Guix API reference."
  `(a
    (@ (class "item-preview")
       (href ,(guix-url (url-path-join (package-url-path package) ""))))
    (h3 ,(package-name package) " " ,(package-version package))
    (p
     (@ (class "item-summary"))
     ,(string-summarize
       (stexi->plain-text
         (texi-fragment->stexi (P_ (package-description package))))
       30)
     "…")))


(define (patches->shtml patches)
  "Return an SHTML representation of PATCHES.

   PATCHES (list)
     A list of <link> objects as defined in (apps packages types)
     module.

   RETURN (shtml)
     If the list of patches is empty, return the string 'None'.
     Otherwise, return a list of links to patches."
  (if (null? patches)
      (C_ "patches" "None")
      (separate
       (map (lambda (patch)
	      (link-subtle #:label (ilink-name patch)
			   #:url (ilink-url patch)))
	    patches)
       ", ")))


(define* (sidebar #:optional (active-letter ""))
  "Return an SHTML section element representing the sidebar of the
   package list.

   ACTIVE-LETTER (string)
     The letter in which the current packages are listed."
  `(section
    (@ (class "side-bar"))
    ,(G_ `(h3 (@ (class "a11y-offset")) "Packages menu: "))

    ,(G_ `(h4 (@ (class "bar-title bar-title-top")) "Browse alphabetically"))
    (div
     (@ (class "bar-box-padded"))
     ,@(map
	(lambda (letter)
	  (list
	   (button-little
	    #:label letter
	    #:url (guix-url (url-path-join "packages" letter ""))
	    #:active (string=? letter active-letter))
	   " ")) ; NOTE: Force space for readability in non-CSS browsers.
	alphabet))

    ;; FIXME: This is currently too costly to produce so we just disable it.

    ;; ,(G_ `(h4 (@ (class "bar-title")) "Packages Issues"))
    ;; (ul
    ;;  (@ (class "bar-list"))
    ;;  (li (@ (class "bar-item"))
    ;;      ,(G_ `(a (@ (class "bar-link")
    ;;                  (href ,(guix-url "packages/issues/lint/"))) "Lint")))
    ;;  (li (@ (class "bar-item"))
    ;;      ,(G_ `(a (@ (class "bar-link")
    ;;                  (href ,(guix-url "packages/issues/reproducibility/")))
    ;;               "Reproducibility"))))
    ))


(define (supported-systems->shtml package)
  "Return a list of SHTML a links to SYSTEMS builds.

   SYSTEMS (<package>)
     A package object as defined in Guix API.

   RETURN (shtml)
     If the list of supported systems of the package is empty, return
     the string 'None'. Otherwise, return a list of links to systems
     builds in hydra."
  (let ((build-url "https://ci.guix.gnu.org/job/gnu/master/")
	(package-id (string-append (package-name package)
				   "-"
				   (package-version package)))
	(systems (filter (cut supported-package? package <>)
                         %cuirass-supported-systems)))
    (if (null? systems)
        (C_ "systems" "None")
        ;; TODO: There's currently no way to refer to a job like
        ;; 'coreutils-8.32' in the Cuirass web UI.  Add such a link once it's
        ;; become available.
	(separate systems ", "))))
