git-to-snow-repo/git-to-snow-repo.scm

(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))))))
                                        '()))
                     (debug
                       (begin
                         ;(display "HERE: ")
                         ;(write (collect (cdr data) 'cond-expand))
                         ;(newline)
                         1

                         ))
                     (depends (map cdr (collect (cdr data) 'import))))
                (set! result
                  (append result
                          (list (append `((name ,(list-ref data 1))
                                          (path ,file))
                                        foreign-depends
                                        (if (null? depends)
                                          '()
                                          `((depends ,@(car depends))))
                                        )))))))))
      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)