snow-fort-guix-channel/build-repo

#!/usr/bin/env -S gosh -r7
; vi: ft=scheme

(import (scheme base)
        (scheme read)
        (scheme write)
        (scheme file)
        (scheme process-context)
        (srfi 1)
        (srfi 13)
        (srfi 14))

(include "licenses.data-scm")

(define tmpdir (list-ref (command-line) 1))
(if (not (file-exists? "repo.scm")) (error "No repo.scm found"))
(define repository (with-input-from-file "repo.scm" (lambda () (read))))
(define base-url "https://snow-fort.org")
(define module-file-path "snow-fort.scm")
(when (file-exists? module-file-path) (delete-file module-file-path))
(define module-file (open-output-file module-file-path))

(define snow-dependencies->guix-dependencies
  (lambda (dependencies)
    (map
      (lambda (dependency)
        (string->symbol
          (string-join (cons "snow" (map symbol->string dependency)) "-")))
      (filter
        (lambda (dependency)
          (and (not (equal? (car dependency) 'scheme))
               (not (equal? (car dependency) 'srfi))
               (not (equal? dependency '(chibi)))))
          dependencies))))

(define snow-license->guix-license
  (lambda (license-pair)
    (cond ((not license-pair) 'public-domain)
          ((assoc (cadr license-pair) license-connections)
           (cadr (assoc (cadr license-pair) license-connections)))
          (else (error "Unconnected license" license-pair)))))

(define to-string
  (lambda (item)
    (cond ((symbol? item)
           (symbol->string item))
          ((number? item)
           (number->string item)))))

(define module-definition
  '(define-module (snow-fort)
                  #:use-module (guix licenses)
                  #:use-module ((guix packages) #:select (package origin base32))
                  #:use-module (guix build-system copy)
                  #:use-module ((guix download) #:select (url-fetch))))

(define snow-library->guix-library
  (lambda (lib version url sha-256 license)
    (let* ((name (string-join (cons "snow" (map to-string (cadr (assoc 'name lib)))) "-"))
           (dependencies (snow-dependencies->guix-dependencies (cdr (assoc 'depends lib))))
           (source-path (string-append (symbol->string (car (cadr (assoc 'name lib)))) "/"))
           (target-path (string-append "share/snow/" source-path))
           (description (if (assoc 'description lib) (cadr (assoc 'description lib)) ""))
           (guix-package
                `(package
                  (name ,name)
                  (version ,version)
                  (source (origin
                            (method url-fetch)
                            (uri ,url)
                            (sha256 (base32 ,sha-256))))
                  (build-system copy-build-system)
                  (arguments (list #:install-plan ''((,source-path ,target-path))))
                  (synopsis ,description)
                  (description ,description)
                  (home-page "")
                  (license ,license))))
      (if (null? dependencies)
        (write `(define-public ,(string->symbol name) ,guix-package) module-file)
        (write `(define-public
                  ,(string->symbol name)
                  ,(append
                     guix-package
                     `((propagated-inputs ,(cons 'list dependencies)))))
               module-file))
          (newline module-file)
          (newline module-file))))

(define snow-package->guix-libraries
  (lambda (package)
    (let* ((version (cadr (assoc 'version package)))
           (license (snow-license->guix-license (assoc 'license package)))
           (url (string-append base-url (car (cdr (assoc 'url package)))))
           (filename (car (reverse (string-tokenize url (char-set-delete char-set:ascii #\/)))))
           (sha-256 (with-input-from-file
                      (string-append tmpdir "/hashes/" filename ".hash")
                      (lambda () (read-line)))))
      (for-each
        (lambda (item)
          (when (equal? (car item) 'library)
            (snow-library->guix-library (cdr item) version url sha-256 license)))
        package))))

(write module-definition module-file)
(newline module-file)
(newline module-file)

(for-each
  (lambda (item)
    (when (equal? (car item) 'package)
      (snow-package->guix-libraries (cdr item))))
  (cdr repository))