cleopter/example/example.lisp at master · aadcg/cleopter · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
;;;; SPDX-FileCopyrightText: 2025-2026 André A. Gomes
;;;; SPDX-License-Identifier: MIT

(defpackage :cleopter/example
  (:use :cl)
  (:export #:entry-point))

(in-package #:cleopter/example)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (cli:define-options
    (:name :help?
     :description "Display this help and exit."
     :long "help"
     :short #\h)
    (:name :verbose
     :description "Set the verbosity level."
     :short #\v
     :value-parser #'parse-integer
     :value-meta-var "<level>")
    (:name :eval
     :description "Read and evaluate the Common Lisp expression."
     :long "eval"
     :short #\e
     :value-parser #'read-from-string
     :value-meta-var "<expr>"
     :variadic? t)))

(defun entry-point ()
  (multiple-value-bind (options free-args) (handler-case (cli:parse)
                                             (cli:troublesome-token (c)
                                               (format t "~a~&" c)
                                               (cli:usage "example" :brief? t)
                                               (uiop:quit 1)))
    (handler-case (apply #'start :free-args free-args options)
      (#+sbcl sb-sys:interactive-interrupt
       #+ccl ccl:interrupt-signal-condition
       ()
        (format t "~%Aborted by the user.~%")
        (uiop:quit 130))
      (error (c) (format t "Unhandled condition: ~a~%" c)))))

(defmacro with-cli-options-defun (name lambda-list &body body)
  "Define a function whose lambda-list is augmented based on `cli:*options*'."
  (let ((cli-kwargs (mapcar (lambda (o) (intern (symbol-name (cli:name o))))
                            cli:*options*)))
    `(defun ,name ,(append lambda-list (if (find '&key lambda-list)
                                           cli-kwargs
                                           (cons '&key cli-kwargs)))
       (declare (ignorable ,@cli-kwargs))
       ,@body)))

(with-cli-options-defun start (&rest args &key free-args)
  ;; Handle non-variadic options.
  (when help? (return-from start (cli:usage "example" :brief? nil)))
  (when verbose (format t "Verbosity level set to ~a~%" verbose))
  ;; Variadic options can't be handled by their keyword argument.
  ;; CLHS(3.4.1.4): "If more than one such argument pair matches, the
  ;; leftmost argument pair is used."
  (loop :for (key value) :on args :by #'cddr
        :do (case key
              (:eval
               (format t "~&Evaluating expr '~a'~&" value)
               (handler-case (eval value)
                 (error (c) (format t "~&~a~&" c))))))
  ;; Handle free arguments.
  (when free-args (format t "Free args: ~{~a~^, ~}~%" free-args)))

;; Don't invoke the debugger on `ccl:interrupt-signal-condition'.
#+ccl
(ccl:advise ccl::cbreak-loop
            (when (typep (third ccl:arglist) 'ccl:interrupt-signal-condition)
              (signal (third ccl:arglist)))
            :when :before
            :name signal-interrupt-signal-condition)