text-filter.lisp

#!/usr/local/bin/sbcl --script

;; The exercise in http://d.hatena.ne.jp/eel3/20151102/1446476928

;; https://github.com/mrkkrp/unix-opts/blob/master/example/example.lisp
(load "unix-opts")      ; or (ql:quickload "unix-opts")

;;-------------------------------------------------------------------
;; Essential processing
;;   Similar to the following Haskell expression, but in somewhat eager:
;;   mapM_ putStrLn . transpose . take n . tails . unlines =<< getContents

(defun print-tuple (xs) (format t "~{~a~}~%" xs))
(defun transpose  (xss) (apply #'mapcar #'list xss))
(defun ntails    (n xs) (loop for i from 0 below n for ys on xs collect ys))
(defun unlines     (xs) (apply #'concatenate 'list xs))
(defun read-stream  (s) (loop for x = (read-line s nil nil) while x collect x))

(defun hcasl (n &key (stream *standard-input*))
  (mapc #'print-tuple (transpose (ntails n (unlines (read-stream stream))))))

;;-------------------------------------------------------------------
;; Tiny file I/O utilities (should be given by some library)

(defun call-with-input-files (fnames fn)
  (labels ((open-next (rest acc)
             (if (null rest)
                 (with-open-stream (st (apply #'make-concatenated-stream acc))
                   (funcall fn st))
                 (with-open-file (st (car rest) :direction :input)
                   (open-next (cdr rest) (cons st acc))))))
    (open-next (reverse fnames) '())))

(defmacro with-open-input-files ((var fnames) &body body)
  (let ((s (gensym)))
    `(call-with-input-files ,fnames
       (lambda (,s) (let ((,var ,s)) ,@body)))))

(defmacro with-open-input-stream ((var fnames) &body body)
  `(if (null ,fnames)
       (let ((,var *standard-input*)) ,@body)
       (with-open-input-files (,var ,fnames) ,@body)))

(defmacro with-open-output-stream ((var fname) &body body)
  `(if (null ,fname)
       (let ((,var *standard-output*)) ,@body)
       (with-open-file (,var ,fname :direction :output) ,@body)))

;;-------------------------------------------------------------------
;; Argument parsing utilities (hopefully given with "unix-opts" library)

(defmacro when-option ((options opt) &body body)
  `(let ((it (getf ,options ,opt)))
     (when it ,@body)))

(defun restart-on-unknown-option (condition)
  (format *error-output* "Warning: ~s option is unknown~%"
          (opts:option condition))
  (invoke-restart 'opts:skip-option))

;;-------------------------------------------------------------------
;; Command-line options, and main routine

;; Define-opts might be better off supporting "default value"
(opts:define-opts
    (:name :help
     :description "print this help text"
     :short #\h
     :long "help")
    (:name :chars
     :description "specify the number of characters in each column"
     :arg-parser #'parse-integer
     :short #\n
     :long "chars")
    (:name :output
     :description "redirect output to file FILE instead of stdout"
     :arg-parser #'identity
     :short #\o
     :long "output"
     :meta-var "FILE")
    (:name :version
     :description "print version"
     :short #\v
     :long "version"))

(defvar *prog-name*    "textfilter")
(defvar *prog-version* "0.1")

(defun usage ()
  (opts:describe
   :prefix   (format nil "~a -- a text filter" *prog-name*)
   :suffix   nil                 ; currently not used
   :usage-of *prog-name*
   :args     "[input-files..]"))

(defun main ()
  (multiple-value-bind (options free-args)
      (handler-case (handler-bind
                        ((opts:unknown-option #'restart-on-unknown-option))
                      (opts:get-opts))
        (opts:missing-arg (condition)
          (format *error-output* "Error: option ~s needs an argument~%"
                  (opts:option condition)))
        (opts:arg-parser-failed (condition)
          (format *error-output* "Error: cannot parse ~s as argument of ~s~%"
                  (opts:raw-arg condition)
                  (opts:option condition))))

    (let ((chars 5) (output nil) (files '()))
      (when-option (options :help)
        (usage)
        (sb-ext:exit :abort t))
      (when-option (options :version)
        (format *error-output* "~a version ~a~%" *prog-name* *prog-version*)
        (sb-ext:exit))
      (when-option (options :chars)
        (unless (plusp it)
          (format *error-output*
                  "Error: -n|--chars option should take a positive integer")
          (sb-ext:exit))
        (setq chars it))
      (when-option (options :output)
        ;; Currently probe-file is not used -- might be dangerous
        (setq output it))
      (setq files free-args)

      (with-open-input-stream (*standard-input* files)
          (with-open-output-stream (*standard-output* output)
              (hcasl chars)))

      #+sbcl (sb-ext:exit)
      )))

(main)