From 37005fca8385560b271216cce451c2449b5e6678 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Wed, 5 Jan 2022 18:24:23 +0100
Subject: [PATCH] Rewrote git-ls.

---
 Makefile   |  5 ++-
 git-ls     | 12 --------
 git-ls.scm | 90 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 94 insertions(+), 13 deletions(-)
 delete mode 100755 git-ls
 create mode 100755 git-ls.scm

diff --git a/Makefile b/Makefile
index 8d18be9..d0b417f 100644
--- a/Makefile
+++ b/Makefile
@@ -2,5 +2,8 @@
 
 PREFIX := /usr
 
-install:
+git-ls:
+	ln -s $(PWD)/git-ls.scm git-ls
+
+install: git-ls
 	cp git-* $(DESTDIR)$(PREFIX)/bin/
diff --git a/git-ls b/git-ls
deleted file mode 100755
index 935fd95..0000000
--- a/git-ls
+++ /dev/null
@@ -1,12 +0,0 @@
-#!/bin/bash
-
-Cyan='\e[0;36m'
-Normal="\e[m"
-
-for f in `ls`; do
-	if [ -f "$f/.git" ] || [ -d "$f/.git" ]; then
-		echo -e "$Cyan$f$Normal"
-	else
-		ls --color -d $f
-	fi
-done | column
diff --git a/git-ls.scm b/git-ls.scm
new file mode 100755
index 0000000..92b0bb7
--- /dev/null
+++ b/git-ls.scm
@@ -0,0 +1,90 @@
+#!/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)))))
-- 
GitLab