git-ls.scm

#!/usr/bin/guile \
-e main -s
!#

(use-modules (srfi srfi-1)
             (srfi srfi-71)
             (ice-9 ftw)
             (ice-9 regex)
             (ice-9 popen))


(define cyan "0;36")
(define normal "")
(define error "1;31")

(define* (ansi-escape color #:optional (port #f))
  (format port "\x1b[~am" color))

(define dir-color
  (cond ((find (lambda (s) (string-match "^di=" s))
                (string-split (or (getenv "LS_COLORS") "") #\:))
         => (lambda (s) (string-drop s 3)))
        (else "01;34")))


(define-public (group list width)
  (unless (zero? (modulo (length list) width))
    (scm-error 'misc-error "group" "~a∤~a (~s)" `(,width ,(length list) ,list) '()))
  (let inner ((list list))
    (if (null? list)
        '()
        (let* ((row rest (split-at list width)))
          (cons row (inner rest))))))


(define (main args)

  (define cols  (read (open-input-pipe "tput cols")))
  (define dir
    (if (< 1 (length args))
        (cadr args)
        "."))

  (define items
    (map
     (lambda (pair)
       (case (car pair)
         ((module) (cons cyan (cdr pair)))
         ((regular)
          (catch 'system-error
            (lambda ()
              (case (stat:type (stat (string-append dir "/" (cdr pair))))
                ((regular symlink block-special char-special fifo socket
                          unknown)
                 (cons normal (cdr pair)))
                ((directory)
                 (cons dir-color (cdr pair)))))
            (const (cons error (cdr pair)))))))
     (map (lambda (file)
            (if (file-exists? (string-append dir "/" file "/.git"))
                (cons 'module file)
                (cons 'regular file)))
          (remove (lambda (filename)
                    (char=? #\. (string-ref filename 0)))
           (scandir dir)))))

  (let ()
    (define longest-string (apply max (map string-length (map cdr items))))
    (define items-per-line (floor (/ cols (+ 1 longest-string))))

    (let ((head tail-line (split-at items
                                    (- (length items)
                                       (modulo (length items) items-per-line)))))
      (for-each (lambda (group)
                  (for-each (lambda (item)
                              (format #t "~a~a~a"
                                      (ansi-escape (car item))
                                      (string-pad-right (cdr item) (1+ longest-string))
                                      (ansi-escape normal)))
                            group)
                  (newline))
                (group head items-per-line))
      (for-each (lambda (item)
                  (format #t "~a~a~a"
                          (ansi-escape (car item))
                          (string-pad-right (cdr item) (1+ longest-string))
                          (ansi-escape normal)))
                tail-line)
      (unless (null? tail-line)
        (newline)))))