pkgs/tools/package-management/akku/parse-akku.scm

   1 (import (srfi 1)
   2         (srfi 28)
   3         (ice-9 pretty-print))
   4
   5
   6 (define-syntax anif
   7   (syntax-rules (:=)
   8     ((_ (bool := sym) x y)
   9      (let ((sym bool))
  10        (if sym x y)))
  11     ((_ b x)
  12      (anif b x #f))))
  13
  14 (define ref assoc-ref)
  15
  16 (define (sref alist key)
  17   ;; Used to reach b in pairs like (a . (b))
  18   (anif ((ref alist key) := t)
  19         (car t)
  20         #f))
  21
  22 (define (printf str . args)
  23   (display (apply format (cons str args))))
  24
  25 (define (->string x)
  26   (cond
  27     ((symbol? x) (symbol->string x))
  28     ((number? x) (number->string x))
  29     (else x)))
  30
  31 (define (module-name->string module)
  32   (if (pair? module)
  33     (string-join (map ->string module) "-")
  34     module))
  35
  36 (define (normalize-deps deps)
  37   (map (compose module-name->string car) deps))
  38
  39 (define (parse-license license)
  40   (let ((res (with-input-from-string license read)))
  41     (if (pair? res)
  42       (map (compose string-downcase ->string)
  43            (filter (lambda (sym) (not (eq? sym 'AND))) res))
  44       (string-downcase (->string res)))))
  45
  46 (define (parse-version-info alist)
  47   (let* ((lock (ref alist 'lock))
  48          (url (sref (ref lock 'location) 'url))
  49          (sha256 (sref (ref lock 'content) 'sha256))
  50          (depends (normalize-deps (ref alist 'depends)))
  51          (dev-depends
  52            (anif ((ref alist 'depends/dev) := t)
  53                  (normalize-deps t)
  54                  (list)))
  55          (license (parse-license (sref alist 'license))))
  56     (append `((license ,license)
  57               (url ,url)
  58               (sha256 ,sha256)
  59               (depends ,depends)
  60               (dev-depends ,dev-depends))
  61             alist)))
  62
  63 (define (format-list lst)
  64   (define (surround s)
  65     (format "~s" s))
  66   (string-append
  67     "["
  68     (apply string-join (list (map surround lst) ", "))
  69     "]"))
  70
  71 (define (write-package sexp)
  72   (let* ((latest (parse-version-info (last (ref sexp 'versions))))
  73          (license (sref latest 'license))
  74          (url (sref latest 'url)))
  75     (printf "[~a]\n" (module-name->string (sref sexp 'name)))
  76     (printf "dependencies = ~a\n" (format-list (sref latest 'depends)))
  77     (printf "dev-dependencies = ~a\n" (format-list (sref latest 'dev-depends)))
  78     (if (pair? license)
  79       (printf "license = ~a\n" (format-list license))
  80       (printf "license = ~s\n" license))
  81     (printf "url = ~s\n" url)
  82     (printf "sha256 = ~s\n" (sref latest 'sha256))
  83     (printf
  84       "source = ~s\n"
  85       (cond
  86         ;; because #f could be returned
  87         ((eqv? 0 (string-contains url "https://archive.akkuscm.org/")) "akku")
  88         ((eqv? 0 (string-contains url "http://snow-fort.org/")) "snow-fort")
  89         (else "UNKNOWN")))
  90     (anif ((sref latest 'synopsis) := t)
  91           (printf "synopsis = ~s\n" t))
  92     (printf "version = ~s\n" (sref latest 'version))
  93     (anif ((sref latest 'hompeage) := t)
  94           (printf "homepage = ~s\n" t))
  95     (newline)))
  96
  97 (define (main-deps)
  98   (let ((res (read)))
  99     (if (eof-object? res)
 100       (exit 0))
 101     (write-package (cdr res))
 102     (main-deps)))
 103
 104
 105 (define (read-meta meta)
 106   (with-input-from-file meta read))
 107
 108 (define (find-definition meta sym)
 109   ;; cddr for
 110   ;; (define sym definition ...)
 111   ;;             ^
 112   (cddr (find (lambda (a)
 113                 (and (pair? a)
 114                      (eq? (car a) 'define)
 115                      (eq? (cadr a) sym)))
 116               meta)))
 117
 118 (define (installed-libraries meta)
 119   ;; cadar for
 120   ;; ((quote ((chibi diff) (chibi diff-test))))
 121   ;;         ^
 122   (cadar (find-definition meta 'installed-libraries)))
 123
 124 (define (installed-assets meta)
 125   (cadar (find-definition meta 'installed-assets)))
 126
 127 (define (main-merge name version self-path . rest-paths)
 128   (let* ((self (read-meta self-path))
 129          (metas (map read-meta (cons self-path rest-paths)))
 130          (joined-libraries (append-map installed-libraries metas))
 131          (joined-assets (append-map installed-assets metas)))
 132     (set-car! (find-definition self 'installed-libraries)
 133               `',(delete-duplicates joined-libraries))
 134     (set-car! (find-definition self 'installed-assets)
 135               `',(delete-duplicates joined-assets))
 136     (set-car! (find-definition self 'main-package-name)
 137               `',name)
 138     (set-car! (find-definition self 'main-package-version)
 139               `',version)
 140     self))
 141
 142 (case (string->symbol (cadr (command-line)))
 143   ((deps)
 144    (read)
 145    (main-deps))
 146   ((merge)
 147    (pretty-print (apply main-merge (cddr (command-line)))))
 148   (else
 149     (display "mode not found")
 150     (newline)))
 151