etc: Add import helper script for RStudio.

* etc/rstudio-node-helper.scm: New file.

1 files changed, 99 insertions, 0 deletions

diff --git a/etc/rstudio-node-helper.sh b/etc/rstudio-node-helper.sh
new file mode 100755
index 0000000..a843289
--- /dev/null
+++ b/etc/rstudio-node-helper.sh
@@ -0,0 +1,99 @@
+#!/usr/bin/env bash
+exec guix repl -L . -- $0 $@
+!#
+
+;;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; Usage: ./rstudio-node-helper.sh /path/to/quarto/yarn.lock rstudio-node.scm
+
+(use-modules (ice-9 peg)
+             (ice-9 textual-ports)
+             (ice-9 match)
+             (srfi srfi-1)
+             (guix sets)
+             (guix scripts import))
+
+(define (parse-yarn.lock file)
+  (define-peg-pattern NL none "\n")
+  (define-peg-pattern colon none ":")
+  (define-peg-pattern comma none ",")
+  (define-peg-pattern WS none (or " " "\t" "\r"))
+  (define-peg-pattern comment all
+    (and (ignore "#") (* WS) (* (and (not-followed-by NL) peg-any))))
+  (define-peg-pattern EOL body (and (* WS) (? comment) NL))
+  (define-peg-pattern identifier body
+    (+ (and (not-followed-by (or NL WS comma colon)) peg-any)))
+  (define-peg-pattern string-quoted body
+    (and (ignore "\"")
+         (+ (or (and (ignore "\\") peg-any)
+                (and (not-followed-by "\"") peg-any)))
+         (ignore "\"")))
+  (define-peg-pattern string-or-ident body
+    (and (* WS) (or string-quoted identifier)))
+  (define-peg-pattern name all string-or-ident)
+  (define-peg-pattern names body
+    (and name (* (and comma WS name)) colon EOL))
+  (define-peg-pattern key all string-or-ident)
+  (define-peg-pattern value all string-or-ident)
+  (define-peg-pattern k+v body (and key WS value))
+  (define-peg-pattern indentation none (+ WS))
+  (define-peg-pattern indented-line body (and indentation k+v))
+  (define-peg-pattern indented-dict body (and indentation identifier colon EOL
+                                              (+ (and indented-line EOL))))
+  (define-peg-pattern block all (and names
+                                     (* (or (and indented-line EOL)
+                                            indented-dict))))
+  (define-peg-pattern yarn body (and (+ (or EOL NL block)) (* peg-any)))
+  (let ((content (call-with-input-file file get-string-all)))
+    (peg:tree (match-pattern yarn content))))
+
+(define (extract-dependencies tree)
+  (let ((deps (apply append
+                     (filter-map
+                      (match-lambda
+                        (('block ('name name) (entries ...))
+                         (let ((point (string-rindex name #\@)))
+                           (and point
+                                (let ((package-name (string-take name point))
+                                      (version-spec
+                                       (match (assoc-ref entries '(key "version"))
+                                         ((('value v)) v)
+                                         (_ #false))))
+                                  (if (and package-name (string-prefix? package-name "turbo"))
+                                      #false
+                                      (list (cons package-name version-spec)))))))
+                        (_ #false))
+                      tree))))
+    ;; Make sure the records are unique and don't contain weird
+    ;; records.
+    (set->list (fold (lambda (entry previous)
+                       (match entry
+                         ((name . version)
+                          (if (string-prefix? "npm:" version)
+                              previous
+                              (set-insert entry previous)))))
+                     (set)
+                     deps))))
+
+(define (import-from-file yarn-file target-file)
+  (let ((tree (parse-yarn.lock yarn-file)))
+    (use-modules (ice-9 pretty-print))
+    (pretty-print tree)
+    (for-each (match-lambda
+                ((name . version)
+                 (unless #false
+                   (pk 'importing name '- version)
+                   (let ((res (false-if-exception
+                               (guix-import "-i" target-file
+                                            "npm-binary" "-r"
+                                            (if (string=? "*" version)
+                                                name
+                                                (string-append name "@" version)) ))))
+                     (unless res
+                       (pk '---failed name '- version))))))
+              (extract-dependencies tree))))
+
+(match (command-line)
+  ((command source target . _)
+   (import-from-file source target))
+  (else (error "provide a yarn.lock file and a Scheme module target to append to.")))