import: Add Elm importer.

* guix/import/elm.scm, guix/scripts/import/elm.scm: New files.
* Makefile.am (MODULES): Add them.
* guix/scripts/import.scm (importers): Add "elm".
* doc/guix.texi (Invoking guix import): Document Elm importer.
* doc/contributing.texi (Elm Packages): Mention it.
* tests/elm.scm ("(guix import elm)"): New test group.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

3 files changed, 319 insertions, 1 deletions

diff --git a/guix/import/elm.scm b/guix/import/elm.scm
new file mode 100644
index 0000000000..74902b8617
--- /dev/null
+++ b/guix/import/elm.scm
@@ -0,0 +1,210 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com>
+;;;
+;;; 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/>.
+
+(define-module (guix import elm)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 vlist)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (guix utils)
+  #:use-module (guix base32)
+  #:use-module (guix hash)
+  #:use-module (guix http-client)
+  #:use-module (guix memoization)
+  #:use-module (guix diagnostics)
+  #:use-module (guix i18n)
+  #:use-module ((guix ui) #:select (display-hint))
+  #:use-module ((guix build utils)
+                #:select ((package-name->name+version
+                           . hyphen-package-name->name+version)
+                          find-files
+                          invoke))
+  #:use-module (guix import utils)
+  #:use-module (guix git)
+  #:use-module (guix import json)
+  #:autoload   (gcrypt hash) (hash-algorithm sha256)
+  #:use-module (json)
+  #:use-module (guix packages)
+  #:use-module (guix upstream)
+  #:use-module ((guix licenses) #:prefix license:)
+  #:use-module (guix build-system elm)
+  #:export (elm-recursive-import
+            %elm-package-registry
+            %current-elm-checkout
+            elm->guix-package))
+
+(define %registry-url
+  ;; It is much nicer to fetch this small (< 40 KB gzipped)
+  ;; file once than to do many HTTP requests.
+  "https://package.elm-lang.org/all-packages")
+
+(define %elm-package-registry
+  ;; This is a parameter to support both testing and memoization.
+  ;; In pseudo-code, it has the contract:
+  ;;     (parameter/c (-> json/c)
+  ;;                  (promise/c (vhash/c string? (listof string?))))
+  ;; To set the parameter, provide a thunk that returns a value suitable
+  ;; as an argument to 'json->registry-vhash'.  Accessing the parameter
+  ;; returns a promise wrapping the resulting vhash.
+  (make-parameter
+   (lambda ()
+     (cond
+      ((json-fetch %registry-url #:http-fetch http-fetch/cached))
+      (else
+       (raise (formatted-message
+               (G_ "error downloading Elm package registry from ~a")
+               %registry-url)))))
+   (lambda (thunk)
+     (delay (json->registry-vhash (thunk))))))
+
+(define (json->registry-vhash jsobject)
+  "Parse the '(json)' module's representation of the Elm package registry to a
+vhash mapping package names to lists of available versions, sorted from latest
+to oldest."
+  (fold (lambda (entry vh)
+          (match entry
+            ((name . vec)
+             (vhash-cons name
+                         (sort (vector->list vec) version>?)
+                         vh))))
+        vlist-null
+        jsobject))
+
+(define (json->direct-dependencies jsobject)
+  "Parse the '(json)' module's representation of an 'elm.json' file's
+'dependencies' or 'test-dependencies' field to a list of strings naming direct
+dependencies, handling both the 'package' and 'application' grammars."
+  (cond
+   ;; *unspecified*
+   ((not (pair? jsobject))
+    '())
+   ;; {"type":"application"}
+   ((every (match-lambda
+             (((or "direct" "indirect") (_ . _) ...)
+              #t)
+             (_
+              #f))
+           jsobject)
+    (map car (or (assoc-ref jsobject "direct") '())))
+   ;; {"type":"package"}
+   (else
+    (map car jsobject))))
+
+;; <project-info> handles both {"type":"package"} and {"type":"application"}
+(define-json-mapping <project-info> make-project-info project-info?
+  json->project-info
+  (dependencies project-info-dependencies
+                "dependencies" json->direct-dependencies)
+  (test-dependencies project-info-test-dependencies
+                     "test-dependencies" json->direct-dependencies)
+  ;; "synopsis" and "license" may be missing for {"type":"application"}
+  (synopsis project-info-synopsis
+            "summary" (lambda (x)
+                        (if (string? x)
+                            x
+                            "")))
+  (license project-info-license
+           "license" (lambda (x)
+                       (if (string? x)
+                           (spdx-string->license x)
+                           #f))))
+
+(define %current-elm-checkout
+  ;; This is a parameter for testing purposes.
+  (make-parameter
+   (lambda (name version)
+     (define-values (checkout _commit _relation)
+       ;; Elm requires that packages use this very specific format
+       (update-cached-checkout (string-append "https://github.com/" name)
+                               #:ref `(tag . ,version)))
+     checkout)))
+
+(define (make-elm-package-sexp name version)
+  "Return two values: the `package' s-expression for the Elm package with the
+given NAME and VERSION, and a list of Elm packages it depends on."
+  (define checkout
+    ((%current-elm-checkout) name version))
+  (define info
+    (call-with-input-file (string-append checkout "/elm.json")
+      json->project-info))
+  (define dependencies
+    (project-info-dependencies info))
+  (define test-dependencies
+    (project-info-test-dependencies info))
+  (define guix-name
+    (elm->package-name name))
+  (values
+   `(package
+      (name ,guix-name)
+      (version ,version)
+      (source (elm-package-origin
+               ,name
+               version ;; no ,
+               (base32
+                ,(bytevector->nix-base32-string
+                  (file-hash* checkout
+                              #:algorithm (hash-algorithm sha256)
+                              #:recursive? #t)))))
+      (build-system elm-build-system)
+      ,@(maybe-propagated-inputs (map elm->package-name dependencies))
+      ,@(maybe-inputs (map elm->package-name test-dependencies))
+      (home-page ,(string-append "https://package.elm-lang.org/packages/"
+                                 name "/" version))
+      (synopsis ,(project-info-synopsis info))
+      (description
+       ;; Try to use the first paragraph of README.md (which Elm requires),
+       ;; or fall back to synopsis otherwise.
+       ,(beautify-description
+         (match (chunk-lines (call-with-input-file
+                                 (string-append checkout "/README.md")
+                               read-lines))
+           ((_ par . _)
+            (string-join par " "))
+           (_
+            (project-info-synopsis info)))))
+      ,@(let ((inferred-name (infer-elm-package-name guix-name)))
+          (if (equal? inferred-name name)
+              '()
+              `((properties '((upstream-name . ,name))))))
+      (license ,(project-info-license info)))
+   (append dependencies test-dependencies)))
+
+(define elm->guix-package
+  (memoize
+   (lambda* (package-name #:key repo version)
+     "Fetch the metadata for PACKAGE-NAME, an Elm package registered at
+package.elm.org, and return two values: the `package' s-expression
+corresponding to that package (or #f on failure) and a list of Elm
+dependencies."
+     (cond
+      ((vhash-assoc package-name (force (%elm-package-registry)))
+       => (match-lambda
+            ((_found latest . _versions)
+             (make-elm-package-sexp package-name (or version latest)))))
+      (else
+       (values #f '()))))))
+
+(define* (elm-recursive-import package-name #:optional version)
+  (recursive-import package-name
+                    #:version version
+                    #:repo->guix-package elm->guix-package
+                    #:guix-name elm->package-name))
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 40fa6759ae..fa79f3211e 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -80,7 +81,7 @@ rather than \\n."
 
 (define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa"
                     "gem" "go" "cran" "crate" "texlive" "json" "opam"
-                    "minetest"))
+                    "minetest" "elm"))
 
 (define (resolve-importer name)
   (let ((module (resolve-interface
diff --git a/guix/scripts/import/elm.scm b/guix/scripts/import/elm.scm
new file mode 100644
index 0000000000..68dcbf1070
--- /dev/null
+++ b/guix/scripts/import/elm.scm
@@ -0,0 +1,107 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com>
+;;;
+;;; 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/>.
+
+(define-module (guix scripts import elm)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix scripts)
+  #:use-module (guix import elm)
+  #:use-module (guix scripts import)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-37)
+  #:use-module (srfi srfi-71)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:export (guix-import-elm))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+  '())
+
+(define (show-help)
+  (display (G_ "Usage: guix import elm PACKAGE-NAME
+
+Import and convert the Elm package PACKAGE-NAME.  Optionally, a version
+can be specified after the arobas (@) character.\n"))
+  (display (G_ "
+  -h, --help             display this help and exit"))
+  (display (G_ "
+  -r, --recursive        import packages recursively"))
+  (display (G_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specification of the command-line options.
+  (cons* (option '(#\h "help") #f #f
+                 (lambda args
+                   (show-help)
+                   (exit 0)))
+         (option '(#\V "version") #f #f
+                 (lambda args
+                   (show-version-and-exit "guix import elm")))
+         (option '(#\r "recursive") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'recursive #t result)))
+         %standard-import-options))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import-elm . args)
+  (define (parse-options)
+    ;; Return the alist of option values.
+    (parse-command-line args %options (list %default-options)
+                        #:build-options? #f))
+
+  (let* ((opts (parse-options))
+         (args (filter-map (match-lambda
+                             (('argument . value)
+                              value)
+                             (_ #f))
+                           (reverse opts))))
+    (match args
+      ((spec)
+       (with-error-handling
+         (let ((name version (package-name->name+version spec)))
+           (if (assoc-ref opts 'recursive)
+               ;; Recursive import
+               (map (match-lambda
+                      ((and ('package ('name name) . rest) pkg)
+                       `(define-public ,(string->symbol name)
+                          ,pkg))
+                      (_ #f))
+                    (elm-recursive-import name version))
+               ;; Single import
+               (let ((sexp (elm->guix-package name #:version version)))
+                 (unless sexp
+                   (leave (G_ "failed to download meta-data for package '~a'~%")
+                          name))
+                 sexp)))))
+      (()
+       (leave (G_ "too few arguments~%")))
+      ((many ...)
+       (leave (G_ "too many arguments~%"))))))