blob: 4ea0c5a1f58959778eccedd3bc722fb33d479e85 (
plain) (
blame)
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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
(import (srfi 1)
(srfi 28)
(ice-9 pretty-print))
(define-syntax anif
(syntax-rules (:=)
((_ (bool := sym) x y)
(let ((sym bool))
(if sym x y)))
((_ b x)
(anif b x #f))))
(define ref assoc-ref)
(define (sref alist key)
;; Used to reach b in pairs like (a . (b))
(anif ((ref alist key) := t)
(car t)
#f))
(define (printf str . args)
(display (apply format (cons str args))))
(define (->string x)
(cond
((symbol? x) (symbol->string x))
((number? x) (number->string x))
(else x)))
(define (module-name->string module)
(if (pair? module)
(string-join (map ->string module) "-")
module))
(define (normalize-deps deps)
(map (compose module-name->string car) deps))
(define (parse-license license)
(let ((res (with-input-from-string license read)))
(if (pair? res)
(map (compose string-downcase ->string)
(filter (lambda (sym) (not (eq? sym 'AND))) res))
(string-downcase (->string res)))))
(define (parse-version-info alist)
(let* ((lock (ref alist 'lock))
(url (sref (ref lock 'location) 'url))
(sha256 (sref (ref lock 'content) 'sha256))
(depends (normalize-deps (ref alist 'depends)))
(dev-depends
(anif ((ref alist 'depends/dev) := t)
(normalize-deps t)
(list)))
(license (parse-license (sref alist 'license))))
(append `((license ,license)
(url ,url)
(sha256 ,sha256)
(depends ,depends)
(dev-depends ,dev-depends))
alist)))
(define (format-list lst)
(define (surround s)
(format "~s" s))
(string-append
"["
(apply string-join (list (map surround lst) ", "))
"]"))
(define (write-package sexp)
(let* ((latest (parse-version-info (last (ref sexp 'versions))))
(license (sref latest 'license))
(url (sref latest 'url)))
(printf "[~a]\n" (module-name->string (sref sexp 'name)))
(printf "dependencies = ~a\n" (format-list (sref latest 'depends)))
(printf "dev-dependencies = ~a\n" (format-list (sref latest 'dev-depends)))
(if (pair? license)
(printf "license = ~a\n" (format-list license))
(printf "license = ~s\n" license))
(printf "url = ~s\n" url)
(printf "sha256 = ~s\n" (sref latest 'sha256))
(printf
"source = ~s\n"
(cond
;; because #f could be returned
((eqv? 0 (string-contains url "https://archive.akkuscm.org/")) "akku")
((eqv? 0 (string-contains url "http://snow-fort.org/")) "snow-fort")
(else "UNKNOWN")))
(anif ((sref latest 'synopsis) := t)
(printf "synopsis = ~s\n" t))
(printf "version = ~s\n" (sref latest 'version))
(anif ((sref latest 'hompeage) := t)
(printf "homepage = ~s\n" t))
(newline)))
(define (main-deps)
(let ((res (read)))
(if (eof-object? res)
(exit 0))
(write-package (cdr res))
(main-deps)))
(define (read-meta meta)
(with-input-from-file meta read))
(define (find-definition meta sym)
;; cddr for
;; (define sym definition ...)
;; ^
(cddr (find (lambda (a)
(and (pair? a)
(eq? (car a) 'define)
(eq? (cadr a) sym)))
meta)))
(define (installed-libraries meta)
;; cadar for
;; ((quote ((chibi diff) (chibi diff-test))))
;; ^
(cadar (find-definition meta 'installed-libraries)))
(define (installed-assets meta)
(cadar (find-definition meta 'installed-assets)))
(define (main-merge name version self-path . rest-paths)
(let* ((self (read-meta self-path))
(metas (map read-meta (cons self-path rest-paths)))
(joined-libraries (append-map installed-libraries metas))
(joined-assets (append-map installed-assets metas)))
(set-car! (find-definition self 'installed-libraries)
`',(delete-duplicates joined-libraries))
(set-car! (find-definition self 'installed-assets)
`',(delete-duplicates joined-assets))
(set-car! (find-definition self 'main-package-name)
`',name)
(set-car! (find-definition self 'main-package-version)
`',version)
self))
(case (string->symbol (cadr (command-line)))
((deps)
(read)
(main-deps))
((merge)
(pretty-print (apply main-merge (cddr (command-line)))))
(else
(display "mode not found")
(newline)))
|
