(use setup-api posix files utils irregex)

(define (usage code)
  (print #<#EOF
usage: git-eggtag [-n] RELEASE

  -h   -help                    Show this message
  -n   -no-update               No meta-file update

git-eggtag will tag an egg for release with the name RELEASE and add a
corresponding entry to the .release-info file.  It will also update
the .meta-file's FILES section to contain all the files, unless -n is
passed.

EOF
)
(exit code))

(define (call-with-input-pipe* cmd proc)
  (let* ([p (open-input-pipe cmd)]
         [res (proc p)])
    (unless (zero? (close-input-pipe p))
      (error "Got an error while executing command " cmd))
    res))

(define (git-exec cmd)
  (call-with-input-pipe* cmd read-lines ))

(define (irregex-grep irx lines)
  (map (lambda(line)
         (irregex-search irx line)) lines))

(define (find-egg-name)
  (let ((meta-file (glob "*.meta")))
    (cond ((null? meta-file)
           (fprintf (current-error-port)
                    "Error: No meta file found! Please create one first~%")
           (exit 1))
          ((> (length meta-file) 1)
           (fprintf (current-error-port)
                    "Error: ~A meta files found. Can only deal with one!~%"
                    (length meta-file))
           (exit 1))
          (else (pathname-file (car meta-file))))))

(define (ensure-clean-wc!)
  (let ((status (git-exec "git status --porcelain")))
    (when (any values (irregex-grep "^ M" status))
      (fprintf (current-error-port)
               (conc "Working copy is not clean. Please commit all outstanding "
                     "changes before tagging a release!~%"))
      (exit 1))))

(define (update-meta!)
  (system* "~A/bin/git-update-meta" chicken-prefix))

(define (update-release-info! release-version)
  (let* ((release-infos (glob "*.release-info")))
    (cond ((null? release-infos)
           (fprintf (current-error-port)
                    "Error: No release-info file found! Please create one first~%")
           (exit 1))
          ((> (length release-infos) 1)
           (fprintf (current-error-port)
                    "Error: ~A release-info files found. Can only deal with one!~%"
                    (length release-infos))
           (exit 1))
          (else
           ;; First check if this release already exists
           (let lp ((contents (with-input-from-file (car release-infos) read-file)))
             (cond ((null? contents) #f)
                   ((and (eq? (caar contents) 'release)
                         (string=? (cadar contents) release-version))
                    (fprintf (current-error-port)
                             "Release ~A already exists in release-info file!~%"
                             release-version)
                    (exit 1))
                   (else (lp (cdr contents)))))
           (with-output-to-file (car release-infos)
             (lambda () (write `(release ,release-version)) (newline))
             #:append)))))

(define (check-tag-does-not-exist! release-version)
  (when (any values (irregex-grep release-version (git-exec "git tag")))
    (fprintf (current-error-port)
             "There's already a tag that matches your release version ~S!~%"
             release-version)
    (exit 1)))

(define (commit-all! egg-name release-version)
  (system* "git commit -m ~A ~A ~A"
           (qs (sprintf "~A: Add release ~A" egg-name release-version))
           (qs (car (glob "*.release-info")))
           (if *update-meta-file* (qs (car (glob "*.meta"))) "")))

(define (tag! release-version)
  (system* "git tag ~A" release-version))

(define (push-tags!)
  (system* "git push --tags"))

(define (tag-egg release-version)
  (let* ((egg-name (find-egg-name)))
    (pp egg-name)
    (ensure-clean-wc!)
    (check-tag-does-not-exist! release-version)
    (update-release-info! release-version)
    (when *update-meta-file* (update-meta!))
    (commit-all! egg-name release-version)
    (tag! release-version)
    (push-tags!)))

(define *update-meta-file* #t)

(define *short-options* '(#\h #\n))

(define (main args)
  (let loop ((args args))
    (if (null? args)
        (usage 1)
        (let ((arg (car args)))
          (cond ((or (string=? arg "-help")
                     (string=? arg "-h")
                     (string=? arg "--help"))
                 (usage 0))
                ((or (string=? arg "-n") (string=? arg "-no-update"))
                 (set! *update-meta-file* #f)
                 (loop (cdr args)))
                ((and (positive? (string-length arg))
                      (char=? #\- (string-ref arg 0)))
                 (if (> (string-length arg) 2)
                     (let ((sos (string->list (substring arg 1))))
                       (if (null? (lset-intersection eq? *short-options* sos))
                           (loop (append (map (cut string #\- <>) sos) (cdr args)))
                           (usage 1)))
                     (usage 1)))
                ((= (length args) 1) (tag-egg (car args)))
                (else (usage 1)))))))

(main (command-line-arguments))