From 2db9a6bc019926ad495e8c369cf8cab1f9394235 Mon Sep 17 00:00:00 2001
From: Timo Wilken
Date: Sat, 7 Jan 2023 18:05:19 +0100
Subject: Extract ppscm to separate script

---
 tw/home/files/ppscm | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 53 insertions(+)
 create mode 100755 tw/home/files/ppscm

(limited to 'tw/home/files/ppscm')

diff --git a/tw/home/files/ppscm b/tw/home/files/ppscm
new file mode 100755
index 00000000..326ebbb6
--- /dev/null
+++ b/tw/home/files/ppscm
@@ -0,0 +1,53 @@
+#!/usr/bin/env -S guile --no-auto-compile
+!#
+(use-modules (ice-9 match)
+             (ice-9 popen)
+             (ice-9 pretty-print))
+
+(define (main input-file)
+  (call-with-input-file input-file
+    (lambda (iport)
+      (let ((highlighter (open-output-pipe "source-highlight -s scheme -f esc | $PAGER")))
+        (with-exception-handler
+            (lambda (exn)
+              (close-pipe highlighter)   ; make sure $PAGER doesn't mess up the terminal
+              (raise-exception exn))     ; re-raise exception
+          (lambda ()
+            (let loop ((thing (read iport)))
+              (cond
+               ((eof-object? thing)
+                (close-pipe highlighter))
+               (#t
+                (pretty-print thing highlighter)
+                (newline highlighter)
+                (loop (read iport)))))))))))
+
+(define (help-message program-name)
+  (string-append "\
+usage: " (basename program-name) " [-h] FILENAME
+
+This utility reads a Guile scheme file and pretty-prints it, throwing
+away any original formatting and comments.
+
+arguments:
+  -h, --help   show this message and exit
+  FILENAME     the scheme file name to pretty-print; required
+"))
+
+(match (program-arguments)
+  ((program-name
+    . (? (lambda (args)
+           (or (member "-h" args)
+               (member "--help" args)))
+         _))
+   (display (help-message program-name)))
+
+  ((_ input-file)
+   (main input-file))
+
+  ((program-name . _)
+   (display "error: invalid number of arguments\n\n"
+            (current-error-port))
+   (display (help-message program-name)
+            (current-error-port))
+   (exit 1)))
-- 
cgit v1.2.3