tvl-depot/users/sterni/mblog/cli.lisp

72 lines
2.5 KiB
Common Lisp
Raw Normal View History

(in-package :cli)
(declaim (optimize (safety 3)))
;; TODO(sterni): nicer messages for various errors signaled?
(defun partition-by (f seq)
"Split SEQ into two lists, returned as multiple values. The first list
contains all elements for which F returns T, the second one the remaining
elements."
(loop for x in seq
if (funcall f x)
collecting x into yes
else
collecting x into no
finally (return (values yes no))))
(defparameter +help+ '(("mnote-html" . "FILE [FILE [ ... ]]")
("mblog" . "MAILDIR OUT")))
(defun mnote-html (name flags &rest args)
"Convert all note mime messages given as ARGS to HTML fragments."
(declare (ignore name flags))
(loop for arg in args
do (note:apple-note-html-fragment
(note:make-apple-note (mime:mime-message (pathname arg)))
*standard-output*)))
(defun mblog (name flags maildir outdir)
"Read a MAILDIR and build an mblog in OUTDIR "
(declare (ignore name flags))
(build-mblog (pathname maildir) (pathname outdir)))
(defun display-help (name flags &rest args)
"Print help message for current executable."
(declare (ignore args flags))
(format *error-output* "Usage: ~A ~A~%"
name
(or (cdr (assoc name +help+ :test #'string=))
(concatenate 'string "Unknown executable: " name))))
(defun usage-error (name flags &rest args)
"Print help and exit with a non-zero exit code."
(format *error-output* "~A: usage error~%" name)
(display-help name args flags)
(uiop:quit 100))
(defun main ()
"Dispatch to correct main function based on arguments and UIOP:ARGV0."
(multiple-value-bind (flags args)
(partition-by (lambda (x) (starts-with #\- x))
(uiop:command-line-arguments))
(let ((prog-name (pathname-name (pathname (uiop:argv0))))
(help-requested-p (find-if (lambda (x)
(member x '("-h" "--help" "--usage")
:test #'string=))
args)))
(apply
(if help-requested-p
#'display-help
(cond
((and (string= prog-name "mnote-html")
(null flags))
#'mnote-html)
((and (string= prog-name "mblog")
(null flags)
(= 2 (length args)))
#'mblog)
(t #'usage-error)))
(append (list prog-name flags)
args)))))