1 files changed, 151 insertions, 0 deletions
diff --git a/pkgs/tools/package-management/akku/parse-akku.scm b/pkgs/tools/package-management/akku/parse-akku.scm
new file mode 100644
index 0000000000000..4ea0c5a1f5895
--- /dev/null
+++ b/pkgs/tools/package-management/akku/parse-akku.scm
@@ -0,0 +1,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)))
+