blob: a843289f1f68a1811fd0c8f8e949e4c60eaccd5b (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
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.")))
|
