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>

7 files changed, 519 insertions, 3 deletions

diff --git a/Makefile.am b/Makefile.am
index 9ca92c407c..5a42bb90b2 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -259,6 +259,7 @@ MODULES =					\
   guix/import/cran.scm				\
   guix/import/crate.scm				\
   guix/import/egg.scm   			\
+  guix/import/elm.scm				\
   guix/import/elpa.scm   			\
   guix/import/gem.scm				\
   guix/import/git.scm                           \
@@ -310,6 +311,7 @@ MODULES =					\
   guix/scripts/import/crate.scm			\
   guix/scripts/import/cran.scm			\
   guix/scripts/import/egg.scm   		\
+  guix/scripts/import/elm.scm			\
   guix/scripts/import/elpa.scm  		\
   guix/scripts/import/gem.scm			\
   guix/scripts/import/gnu.scm			\
diff --git a/doc/contributing.texi b/doc/contributing.texi
index 555b9bb961..2354874cb0 100644
--- a/doc/contributing.texi
+++ b/doc/contributing.texi
@@ -919,8 +919,8 @@ prefix unless the name would already begin with @code{elm-}.
 In many cases we can reconstruct an Elm package's upstream name heuristically,
 but, since conversion to a Guix-style name involves a loss of information,
 this is not always possible.  Care should be taken to add the
-@code{'upstream-name} property when necessary so that tools
-will work correctly. The most notable scenarios
+@code{'upstream-name} property when necessary so that @samp{guix import elm}
+will work correctly (@pxref{Invoking guix import}). The most notable scenarios
 when explicitly specifying the upstream name is necessary are:
 
 @enumerate
diff --git a/doc/guix.texi b/doc/guix.texi
index 3eff660f0e..5a07c995b9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -13157,6 +13157,31 @@ and generate package expressions for all those packages that are not yet
 in Guix.
 @end table
 
+@item elm
+@cindex elm
+Import metadata from the Elm package repository
+@uref{https://package.elm-lang.org, package.elm-lang.org}, as in this example:
+
+@example
+guix import elm elm-explorations/webgl
+@end example
+
+The Elm importer also allows you to specify a version string:
+
+@example
+guix import elm elm-explorations/webgl@@1.1.3
+@end example
+
+Additional options include:
+
+@table @code
+@item --recursive
+@itemx -r
+Traverse the dependency graph of the given upstream package recursively
+and generate package expressions for all those packages that are not yet
+in Guix.
+@end table
+
 @item opam
 @cindex OPAM
 @cindex OCaml
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~%"))))))
diff --git a/tests/elm.scm b/tests/elm.scm
index 96f958f060..c30623da03 100644
--- a/tests/elm.scm
+++ b/tests/elm.scm
@@ -18,6 +18,13 @@
 
 (define-module (test-elm)
   #:use-module (guix build-system elm)
+  #:use-module (guix import elm)
+  #:use-module (guix base32)
+  #:use-module (guix hash)
+  #:use-module (guix utils)
+  #:autoload   (gcrypt hash) (hash-algorithm sha256)
+  #:use-module (json)
+  #:use-module (ice-9 match)
   #:use-module (srfi srfi-64))
 
 (test-begin "elm")
@@ -94,4 +101,168 @@
     (test-not-inferred "gcc-toolchain")
     (test-not-inferred "font-adobe-source-sans-pro")))
 
+(define test-package-registry-json
+  ;; we intentionally list versions in different orders here
+  "{
+    \"elm/core\": [\"1.0.0\", \"1.0.1\", \"1.0.2\", \"1.0.3\", \"1.0.4\"],
+    \"elm-guix/demo\": [\"2.0.0\", \"3.0.0\", \"1.0.0\"]
+}")
+
+(define test-elm-core-json
+  "{
+    \"type\": \"package\",
+    \"name\": \"elm/core\",
+    \"summary\": \"Elm's standard libraries\",
+    \"license\": \"BSD-3-Clause\",
+    \"version\": \"1.0.4\",
+    \"exposed-modules\": {
+        \"Primitives\": [
+            \"Basics\",
+            \"String\",
+            \"Char\",
+            \"Bitwise\",
+            \"Tuple\"
+        ],
+        \"Collections\": [
+            \"List\",
+            \"Dict\",
+            \"Set\",
+            \"Array\"
+        ],
+        \"Error Handling\": [
+            \"Maybe\",
+            \"Result\"
+        ],
+        \"Debug\": [
+            \"Debug\"
+        ],
+        \"Effects\": [
+            \"Platform.Cmd\",
+            \"Platform.Sub\",
+            \"Platform\",
+            \"Process\",
+            \"Task\"
+        ]
+    },
+    \"elm-version\": \"0.19.0 <= v < 0.20.0\",
+    \"dependencies\": {},
+    \"test-dependencies\": {}
+}")
+
+(define test-elm-core-readme
+  "# Core Libraries
+
+Every Elm project needs this package!
+
+It provides **basic functionality** like addition and subtraction as well as
+**data structures** like lists, dictionaries, and sets.")
+
+(define test-elm-guix-demo-json
+  "{
+    \"type\": \"package\",
+    \"name\": \"elm-guix/demo\",
+    \"summary\": \"A test for `(guix import elm)`\",
+    \"license\": \"GPL-3.0-or-later\",
+    \"version\": \"3.0.0\",
+    \"exposed-modules\": [
+        \"Guix.Demo\"
+    ],
+    \"elm-version\": \"0.19.0 <= v < 0.20.0\",
+    \"dependencies\": {
+        \"elm/core\": \"1.0.0 <= v < 2.0.0\"
+    },
+    \"test-dependencies\": {
+        \"elm/json\": \"1.0.0 <= v < 2.0.0\"
+    }
+}")
+
+(define test-elm-guix-demo-readme
+  ;; intentionally left blank
+  "")
+
+(define (directory-sha256 directory)
+  "Returns the string representing the hash of DIRECTORY as would be used in a
+package definition."
+  (bytevector->nix-base32-string
+   (file-hash* directory
+               #:algorithm (hash-algorithm sha256)
+               #:recursive? #t)))
+
+(test-group "(guix import elm)"
+  (call-with-temporary-directory
+   (lambda (dir)
+     ;; Initialize our fake git checkouts.
+     (define elm-core-dir
+       (string-append dir "/test-elm-core-1.0.4"))
+     (define elm-guix-demo-dir
+       (string-append dir "/test-elm-guix-demo-3.0.0"))
+     (for-each (match-lambda
+                 ((dir json readme)
+                  (mkdir dir)
+                  (with-output-to-file (string-append dir "/elm.json")
+                    (lambda ()
+                      (display json)))
+                  (with-output-to-file (string-append dir "/README.md")
+                    (lambda ()
+                      (display readme)))))
+               `((,elm-core-dir ,test-elm-core-json ,test-elm-core-readme)
+                 (,elm-guix-demo-dir
+                  ,test-elm-guix-demo-json
+                  ,test-elm-guix-demo-readme)))
+     ;; Replace network resources with sample data.
+     (parameterize ((%elm-package-registry
+                     (lambda ()
+                       (json-string->scm test-package-registry-json)))
+                    (%current-elm-checkout
+                     (lambda (name version)
+                       (match (list name version)
+                         (("elm/core" "1.0.4")
+                          elm-core-dir)
+                         (("elm-guix/demo" "3.0.0")
+                          elm-guix-demo-dir)))))
+       (test-assert "(elm->guix-package \"elm/core\")"
+         (match (elm->guix-package "elm/core")
+           (`(package
+               (name "elm-core")
+               (version "1.0.4")
+               (source (elm-package-origin
+                        "elm/core"
+                        version
+                        (base32 ,(? string? hash))))
+               (build-system elm-build-system)
+               (home-page
+                "https://package.elm-lang.org/packages/elm/core/1.0.4")
+               (synopsis "Elm's standard libraries")
+               (description "Every Elm project needs this package!")
+               (license license:bsd-3))
+            (equal? (directory-sha256 elm-core-dir)
+                    hash))
+           (x
+            (raise-exception x))))
+       (test-assert "(elm-recursive-import \"elm-guix/demo\")"
+         (match (elm-recursive-import "elm-guix/demo")
+           (`((package
+                (name "elm-guix-demo")
+                (version "3.0.0")
+                (source (elm-package-origin
+                         "elm-guix/demo"
+                         version
+                         (base32 ,(? string? hash))))
+                (build-system elm-build-system)
+                (propagated-inputs
+                 ,'`(("elm-core" ,elm-core)))
+                (inputs
+                 ,'`(("elm-json" ,elm-json)))
+                (home-page
+                 "https://package.elm-lang.org/packages/elm-guix/demo/3.0.0")
+                (synopsis "A test for `(guix import elm)`")
+                (description
+                 "This package provides a test for `(guix import elm)`")
+                (properties '((upstream-name . "elm-guix/demo")))
+                (license license:gpl3+)))
+            (equal? (directory-sha256 elm-guix-demo-dir)
+                    hash))
+           (x
+            (raise-exception x))))))))
+
 (test-end "elm")