#!/usr/bin/chicken-csi -s
(import chicken.irregex
        (only chicken.port call-with-input-string)
        (only chicken.pretty-print pp)
        (only chicken.io read-string)
        (only chicken.process process-execute call-with-input-pipe)
        (only chicken.string string-split)
        (only chicken.format printf)
        (only srfi-1 filter filter-map last lset-difference)
        (only srfi-13 string-join string-pad-right)
        (only fmt fmt dsp fmt-join tabular)
        (only fmt-color fmt-bold)
        fmt-unicode
        (prefix http-client hc:)
        (prefix uri-common uc:))

(define pinned-packages
  '("csl" "yaml"))

(define upstream-eggs
  (let* ((upstream
          (hc:call-with-input-request
           (uc:uri-reference "http://eggs.call-cc.org/5/")
           #f
           (cut read-string #f <>)))
         (raw-eggs (irregex-extract  "<tr>(.|\n)+?</tr>"
                                     upstream)))
    (filter-map (lambda (x)
                  (let ((match (irregex-search "<a.*?>(.*?)</a>" x)))
                    (if match
                        (cons
                         (irregex-match-substring match 1)
                         (cadr
                          (irregex-split "(<|>)"
                                         (last (irregex-extract "<td>(.*?)</td>" x)))))
                        #f)))
                raw-eggs)))

(define local-eggs
  (let ((raw-eggs (string-split
                   (call-with-input-pipe "chicken-status"
                                         (cut read-string #f <>))
                   "\n")))
    (map (lambda (x)
           (let ((match-name (irregex-search "(.*?) " x))
                 (match-ver (irregex-search "version: (.*?)$" x)))
             (cons
              (irregex-match-substring match-name 1)
              (irregex-match-substring match-ver 1))))
         raw-eggs)))

(define to-update
  (filter (lambda (x)
            (not (irregex-match (string-join pinned-packages "|") (car x))))
          (lset-difference equal? local-eggs upstream-eggs)))

(if (null? to-update)
    (print "Nothing to update.")
    (let* ((eggs (map car to-update))
           (old-versions (map cdr to-update))
           (new-versions (map (lambda (x)
                                (cdr (assoc (car x) upstream-eggs)))
                              to-update)))
      (fmt-unicode #t
                   (tabular (fmt-join dsp (cons (fmt-bold "Egg") eggs) "\n")
                            "  "
                            (fmt-join dsp (cons "Old Version" old-versions) "\n")
                            "  "
                            (fmt-join dsp (cons "New Version" new-versions) "\n")))
      (display "Proceed? [y/n]: ")
      (when (string=? (read-string 1) "y")
        (process-execute "chicken-install" (cons "-s" eggs)))))

plain