180 lines
6.9 KiB
Scheme
180 lines
6.9 KiB
Scheme
(import (scheme base)
|
|
(scheme read)
|
|
(scheme write)
|
|
(scheme file)
|
|
(scheme process-context)
|
|
(retropikzel system)
|
|
(srfi 1)
|
|
(srfi 170))
|
|
|
|
(when (< (length (command-line)) 2)
|
|
(error "Pass the git repository list as first argument" (command-line)))
|
|
|
|
(define data
|
|
(with-input-from-file (list-ref (command-line) 1) (lambda () (read))))
|
|
|
|
(define (get ls check key)
|
|
(when (not (assq key ls))
|
|
(error (string-append "Could not find key: "
|
|
(symbol->string key)
|
|
" from data.")
|
|
ls))
|
|
(let ((value (car (cdr (assq key ls)))))
|
|
(when (not (apply check (list value)))
|
|
(error "Check failed on field value."
|
|
`((lib ,ls)
|
|
(check ,check)
|
|
(value ,value))))
|
|
value))
|
|
|
|
(define (rmdir-r path)
|
|
(if (not (file-info-directory? (file-info path #f)))
|
|
(delete-file path)
|
|
(let ((files (map (lambda (p)
|
|
(string-append path "/" p))
|
|
(directory-files path #t))))
|
|
(cond ((null? files) (delete-directory path))
|
|
(else (for-each rmdir-r (map real-path files))
|
|
(delete-directory path))))))
|
|
|
|
(define (shell->list command)
|
|
(call-with-temporary-filename
|
|
(lambda (file)
|
|
(system (string-append command " > " file))
|
|
(letrec* ((looper (lambda (result line)
|
|
(if (eof-object? line)
|
|
result
|
|
(looper (append result (list line)) (read-line))))))
|
|
(with-input-from-file
|
|
file
|
|
(lambda ()
|
|
(looper (list) (read-line))))))))
|
|
|
|
(define (get-created dir tag)
|
|
(let ((time (shell->list
|
|
(apply string-append
|
|
`("git -C "
|
|
,dir
|
|
" log -1 --format=%ai "
|
|
,tag
|
|
" | tr ' ' '\n'")))))
|
|
(string-append (list-ref time 0) "T" (list-ref time 1) (list-ref time 2))))
|
|
|
|
(define (collect ls key)
|
|
(let ((result (list)))
|
|
(for-each
|
|
(lambda (item)
|
|
(when (eq? (car item) key)
|
|
(set! result (append result (list item)))))
|
|
ls)
|
|
result))
|
|
|
|
(define (get-libraries dir lib)
|
|
(let ((result (list)))
|
|
(for-each
|
|
(lambda (item)
|
|
(when (equal? (car item) 'library)
|
|
|
|
(when (not (assq 'path (cdr item)))
|
|
(error "Library with no path" lib))
|
|
|
|
(when (not (string? (car (cdr (assq 'path (cdr item))))))
|
|
(error "Library with non string path" lib))
|
|
|
|
(let* ((file (car (cdr (assq 'path (cdr item)))))
|
|
(path (string-append dir "/" file)))
|
|
(if (not (file-exists? path))
|
|
(begin
|
|
(display "WARNING: Library with non existing path ignored")
|
|
(newline)
|
|
(display " ")
|
|
(write item)
|
|
(newline))
|
|
(let* ((data (with-input-from-file path (lambda () (read))))
|
|
(foreign-depends (if (assq 'foreign-depends (cdr item))
|
|
`((foreign-depends
|
|
,(car (cdr (assq 'foreign-depends
|
|
(cdr item))))))
|
|
'()))
|
|
(depends (map cdr (collect (cdr data) 'import)))
|
|
(cond-expands
|
|
(let ((raw (map cdr (collect (cdr data) 'cond-expand))))
|
|
(if (null? raw)
|
|
'()
|
|
(map
|
|
(lambda (item)
|
|
(let ((depends (map cdr
|
|
(collect (cdr item)
|
|
'import))))
|
|
(list (car item)
|
|
(if (null? depends)
|
|
'(depends)
|
|
`(depends ,@(car depends))))))
|
|
(car raw))))))
|
|
(set! result
|
|
(append result
|
|
(list (append `((name ,(list-ref data 1))
|
|
(path ,file))
|
|
foreign-depends
|
|
(if (null? depends)
|
|
'()
|
|
`((depends ,@(car depends))))
|
|
(if (null? cond-expands)
|
|
'()
|
|
`((cond-expand ,@cond-expands)))
|
|
)))))))))
|
|
lib)
|
|
result))
|
|
|
|
(display "(repository")
|
|
(newline)
|
|
(for-each
|
|
(lambda (lib)
|
|
(let ((description (get lib string? 'description))
|
|
(url (get lib string? 'url)))
|
|
(call-with-temporary-filename
|
|
(lambda (dir)
|
|
(let* ((git-command (apply string-append
|
|
`("git clone "
|
|
,url
|
|
" "
|
|
,dir
|
|
" 2> /tmp/null")))
|
|
(git-output (system git-command))
|
|
(files (map (lambda (i)
|
|
(real-path (string-append dir "/" i)))
|
|
(directory-files dir)))
|
|
(tags (shell->list (apply string-append
|
|
`("git -C "
|
|
,dir
|
|
" tag 2>&1 > "
|
|
,(string-append dir "/tags"))))))
|
|
(for-each
|
|
(lambda (tag)
|
|
(let* ((hash (car (shell->list
|
|
(apply string-append
|
|
`("git -C "
|
|
,dir
|
|
" rev-parse "
|
|
,tag
|
|
" > "
|
|
,(string-append dir "/hash"))))))
|
|
(created (get-created dir tag))
|
|
(updated (get-created dir tag))
|
|
(libraries (get-libraries dir lib))
|
|
(data `(package (git (url ,url)
|
|
(tag ,tag)
|
|
(hash ,hash))
|
|
(version ,tag)
|
|
(created ,created)
|
|
,@libraries)))
|
|
(display " ")
|
|
(write data)
|
|
(newline)))
|
|
tags)
|
|
(rmdir-r dir))))))
|
|
data)
|
|
(display ")")
|
|
(newline)
|
|
|