#!/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.")))