Zander671/truth-table
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Finish port to asdf and make webserer template files

Browse Source
This commit is contained in:
Alexander Rosenberg 2024-09-04 03:49:47 -07:00
parent b09948d77c
commit d85f58adf2
Signed by: Zander671
GPG Key ID: 5FD0394ADBD72730
8 changed files with 252 additions and 149 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -1 +1,2 @@
truth-table
truth-table
truth-table-webserver

9
Makefile
View File

@ -2,14 +2,19 @@ LISP ?= sbcl
BASE_FILES=packages.lisp parse.lisp table.lisp typeset.lisp eval.lisp
CLI_FILES=cli.lisp
WEB_FILES=web.lisp
all: cli
all: cli web
cli: truth-table
truth-table: build.lisp truth-table.asd $(BASE_FILES) $(CLI_FILES)
$(LISP) --load build.lisp --eval '(cli)'
web: truth-table-webserver
truth-table-webserver: build.lisp truth-table.asd $(BASE_FILES) $(WEB_FILES)
$(LISP) --load build.lisp --eval '(web)'
clean:
rm -f truth-table
rm -f truth-table truth-table-webserver
.PHONY: all cli clean

158
arguments.lisp Normal file
View File

@ -0,0 +1,158 @@
;; arguments.lisp -- Command line option parsing
;; Copyright (C) 2024 Alexander Rosenberg
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(in-package :truth-table/args)
(define-condition command-line-error (error)
((message :initarg :message
:accessor command-line-error-message))
(:report (lambda (con stream)
(format stream "~a"
(command-line-error-message con))))
(:documentation "The parent condition of all command line errors."))
(define-condition cli-argument-error (command-line-error)
((opt :initarg :opt
:accessor cli-argument-error-opt))
(:report (lambda (con stream)
(with-slots (opt message) con
(format stream
"~a: ~:[--~a~;-~c~]" message (characterp opt) opt))))
(:documentation "Condition representing an error that occurred during
processing of command line arguments."))
(define-condition unknown-option-error (cli-argument-error)
((message :initform "unknown option"))
(:documentation "Condition representing an unknown command line option."))
(define-condition option-no-arg-error (cli-argument-error)
((message :initform "option requires an argument"))
(:documentation "Condition representing an error that occurred because a
command line option did not have its required argument."))
(define-condition no-input-error (command-line-error)
((message :initform "no propositions given"))
(:documentation "Condition representing no propositions given on the command
line."))
(defparameter *cli-parse-continue-string*
"Continue paring arguments normally."
"String to use for `cerror' during argument parsing.")
(defun parse-long-option (spec arg next-arg)
"Parse the long option ARG. Return a list of its symbol, its value (or t if
it did not have one), and weather it consumed NEXT-ARG or not."
(destructuring-bind (name &optional value)
(uiop:split-string (subseq arg 2)
:max 2
:separator "=")
(loop for (short long symbol has-arg-p dest) in spec
when (equal name long) do
(if has-arg-p
(cond
(value
(return (list symbol value nil)))
(next-arg
(return (list symbol next-arg t)))
(t
(cerror *cli-parse-continue-string*
'option-no-arg-error :opt name)
(return (list symbol nil nil))))
(return (list symbol t nil)))
finally
(cerror *cli-parse-continue-string*
'unknown-option-error :opt name)
(return (list symbol nil nil)))))
(defun parse-short-option (spec arg next-arg)
"Parse the short options in ARG according to SPEC. Return a list of options
with each entry being similar to the return value of `parse-long-option'."
(loop with output = '()
for i from 1 to (1- (length arg))
for char = (elt arg i)
for (short long symbol has-arg-p desc) = (assoc char spec) do
(cond
(has-arg-p
(cond
((< i (1- (length arg)))
(push (list symbol (subseq arg (1+ i)) nil) output)
(return output))
(next-arg
(push (list symbol next-arg t) output)
(return output))
(t
(cerror *cli-parse-continue-string*
'option-no-arg-error :opt char))))
(short
(push (list symbol t nil) output))
(t
(cerror *cli-parse-continue-string*
'unknown-option-error :opt char)))
finally (return output)))
(defun parse-command-line (spec argv)
"Parse command line arguments in ARGV according to SPEC. Return an alist with
the car being the option's symbol (as specified in SPEC), and the cdr being
the argument it had on the command line, or t if it had none. The rest of the
arguments will be placed in a list at the beginning of the alist."
(let ((output-opts '())
(output-other '()))
(loop for (arg . rest) = argv then rest
while (and arg (not (equal arg "--"))) do
(cond
((uiop:string-prefix-p "--" arg)
(destructuring-bind (symbol value skip-next-p)
(parse-long-option spec arg (car rest))
(push (cons symbol value) output-opts)
(when skip-next-p
(setq rest (cdr rest)))))
((uiop:string-prefix-p "-" arg)
(loop for (symbol value skip-next-p) in (parse-short-option
spec arg (car rest))
do
(push (cons symbol value) output-opts)
(when skip-next-p
(setq rest (cdr rest)))))
(t
(push arg output-other)))
finally (setf output-other (nconc (nreverse rest) output-other)))
(cons (nreverse output-other) output-opts)))
(defun print-usage (stream spec exec-name &optional general-args)
"Print the command line usage corresponding to SPEC to STREAM."
(format stream "usage: ~a [options]~@[ ~a~]~%~%" exec-name general-args)
(loop with longest-option
= (apply 'max (mapcar
(lambda (entry)
(destructuring-bind (short long sym has-arg-p &rest other)
entry
(declare (ignorable other sym))
(+ (if short 2 0)
(if long (+ 2 (length long)) 0)
(if (and short long) 2 0)
(if has-arg-p 6 0))))
spec))
for (short long symbol has-arg-p desc) in spec
do
(format stream " ~v@<~@[-~c~]~@[, ~*~]~@[--~a~]~@[=<arg>~*~]~> ~a~%"
longest-option
short (or short long) long has-arg-p desc))
(format stream "~%The choice surrounded by '*' is the default. Arguments to long
options are also required for their short variant.~%"))
(defun option-value (opt opts)
"Get the value of command line option OPT from OTPS, which is an alist as
returned as the second output of `parse-command-line'."
(cdr (assoc opt opts)))

10
build.lisp
View File

@ -17,3 +17,13 @@
:executable t
:save-runtime-options t
:toplevel (intern "TOPLEVEL" :truth-table/cli)))
(defun web ()
"Build the web server executable."
(asdf:load-system :truth-table/web)
(require :truth-table/web)
(sb-ext:save-lisp-and-die
"truth-table-webserver"
:executable t
:save-runtime-options t
:toplevel (intern "TOPLEVEL" :truth-table/web)))

145
cli.lisp
View File

@ -15,38 +15,6 @@
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(in-package :truth-table/cli)
(define-condition command-line-error (error)
((message :initarg :message
:accessor command-line-error-message))
(:report (lambda (con stream)
(format stream "~a"
(command-line-error-message con))))
(:documentation "The parent condition of all command line errors."))
(define-condition cli-argument-error (command-line-error)
((opt :initarg :opt
:accessor cli-argument-error-opt))
(:report (lambda (con stream)
(with-slots (opt message) con
(format stream
"~a: ~:[--~a~;-~c~]" message (characterp opt) opt))))
(:documentation "Condition representing an error that occurred during
processing of command line arguments."))
(define-condition unknown-option-error (cli-argument-error)
((message :initform "unknown option"))
(:documentation "Condition representing an unknown command line option."))
(define-condition option-no-arg-error (cli-argument-error)
((message :initform "option requires an argument"))
(:documentation "Condition representing an error that occurred because a
command line option did not have its required argument."))
(define-condition no-input-error (command-line-error)
((message :initform "no propositions given"))
(:documentation "Condition representing no propositions given on the command
line."))
(defun eval-and-typeset-propositions (prop-strs &key (format "unicode")
(implicit-and t)
multi-char-names
@ -83,116 +51,6 @@ functions involved in evaluating and typesetting."
"Specification for `parse-command-line'. This is of the format:
(short long symbol has-arg-p desc).")
(defparameter *cli-parse-continue-string*
"Continue paring arguments normally."
"String to use for `cerror' during argument parsing.")
(defun parse-long-option (spec arg next-arg)
"Parse the long option ARG. Return a list of its symbol, its value (or t if
it did not have one), and weather it consumed NEXT-ARG or not."
(destructuring-bind (name &optional value)
(uiop:split-string (subseq arg 2)
:max 2
:separator "=")
(loop for (short long symbol has-arg-p dest) in spec
when (equal name long) do
(if has-arg-p
(cond
(value
(return (list symbol value nil)))
(next-arg
(return (list symbol next-arg t)))
(t
(cerror *cli-parse-continue-string*
'option-no-arg-error :opt name)
(return (list symbol nil nil))))
(return (list symbol t nil)))
finally
(cerror *cli-parse-continue-string*
'unknown-option-error :opt name)
(return (list symbol nil nil)))))
(defun parse-short-option (spec arg next-arg)
"Parse the short options in ARG according to SPEC. Return a list of options
with each entry being similar to the return value of `parse-long-option'."
(loop with output = '()
for i from 1 to (1- (length arg))
for char = (elt arg i)
for (short long symbol has-arg-p desc) = (assoc char spec) do
(cond
(has-arg-p
(cond
((< i (1- (length arg)))
(push (list symbol (subseq arg (1+ i)) nil) output)
(return output))
(next-arg
(push (list symbol next-arg t) output)
(return output))
(t
(cerror *cli-parse-continue-string*
'option-no-arg-error :opt char))))
(short
(push (list symbol t nil) output))
(t
(cerror *cli-parse-continue-string*
'unknown-option-error :opt char)))
finally (return output)))
(defun parse-command-line (spec argv)
"Parse command line arguments in ARGV according to SPEC. Return an alist with
the car being the option's symbol (as specified in SPEC), and the cdr being
the argument it had on the command line, or t if it had none. The rest of the
arguments will be placed in a list at the beginning of the alist."
(let ((output-opts '())
(output-other '()))
(loop for (arg . rest) = argv then rest
while (and arg (not (equal arg "--"))) do
(cond
((uiop:string-prefix-p "--" arg)
(destructuring-bind (symbol value skip-next-p)
(parse-long-option spec arg (car rest))
(push (cons symbol value) output-opts)
(when skip-next-p
(setq rest (cdr rest)))))
((uiop:string-prefix-p "-" arg)
(loop for (symbol value skip-next-p) in (parse-short-option
spec arg (car rest))
do
(push (cons symbol value) output-opts)
(when skip-next-p
(setq rest (cdr rest)))))
(t
(push arg output-other)))
finally (setf output-other (nconc (nreverse rest) output-other)))
(cons (nreverse output-other) output-opts)))
(defun print-usage (stream spec)
"Print the command line usage corresponding to SPEC to STREAM."
(format stream "usage: truth-table [options] <propositions...>~%~%")
(loop with longest-option
= (apply 'max (mapcar
(lambda (entry)
(destructuring-bind (short long sym has-arg-p &rest other)
entry
(declare (ignorable other sym))
(+ (if short 2 0)
(if long (+ 2 (length long)) 0)
(if (and short long) 2 0)
(if has-arg-p 6 0))))
spec))
for (short long symbol has-arg-p desc) in spec
do
(format stream " ~v@<~@[-~c~]~@[, ~*~]~@[--~a~]~@[=<arg>~*~]~> ~a~%"
longest-option
short (or short long) long has-arg-p desc))
(format stream "~%The choice surrounded by '*' is the default. Arguments to long
options are also required for their short variant.~%"))
(defun option-value (opt opts)
"Get the value of command line option OPT from OTPS, which is an alist as
returned as the second output of `parse-command-line'."
(cdr (assoc opt opts)))
(defun main (argv)
"The main entry point to the program. ARGV is the list of command line
arguments."
@ -212,7 +70,8 @@ arguments."
(parse-command-line *command-line-spec* argv)
(cond
((option-value 'help opts)
(print-usage t *command-line-spec*)
(print-usage t *command-line-spec*
"truth-table" "<propositions...>")
(uiop:quit (if cmdline-error 1 0)))
((null prop-strs)
(cerror *cli-parse-continue-string* 'no-input-error))

21
packages.lisp
View File

@ -47,6 +47,25 @@
#:*known-formats*
#:typeset-table-to-format))
(defpackage #:truth-table/args
(:use #:common-lisp)
(:export
#:*cli-parse-continue-string*
#:command-line-error
#:cli-argument-error
#:unknown-option-error
#:option-no-arg-error
#:no-input-error
#:parse-command-line
#:print-usage
#:option-value))
(defpackage #:truth-table/cli
(:use #:common-lisp #:truth-table/base)
(:use #:common-lisp #:truth-table/base
#:truth-table/args)
(:export #:toplevel #:main))
(defpackage #:truth-table/web
(:use #:common-lisp #:truth-table/base
#:truth-table/args)
(:export #:toplevel #:main))

25
truth-table.asd
View File

@ -1,11 +1,12 @@
(defsystem #:truth-table
:version "0.0.1"
:description "Tools for working with logical propositions and truth tables"
:author "Alexander Rosenberg <zanderpkg@pm.me>"
:license "AGPL3"
:depends-on ())
(defsystem #:truth-table/base
:version "0.0.1"
:depends-on ()
:serial t
:components
((:file "packages")
@ -14,11 +15,31 @@
(:file "table")
(:file "typeset")))
(defsystem #:truth-table/args
:depends-on (#:uiop)
:serial t
:components
((:file "packages")
(:file "arguments")))
(defsystem #:truth-table/cli
:depends-on (#:uiop
#:with-user-abort
#:truth-table/base)
#:truth-table/base
#:truth-table/args)
:serial t
:components
((:file "packages")
(:file "cli")))
(defsystem #:truth-table/web
:depends-on (#:uiop
#:with-user-abort
#:reblocks
#:reblocks-ui
#:truth-table/base
#:truth-table/args)
:serial t
:components
((:file "packages")
(:file "web")))

30
web.lisp Normal file
View File

@ -0,0 +1,30 @@
;; web.lisp -- Website to allow users to make truth tables
;; Copyright (C) 2024 Alexander Rosenberg
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(in-package :truth-table/web)
(defun main (argv)
"The main entry point to the program. ARGV is the list of command line
arguments."
(format t "Hello World~%"))
(defun toplevel ()
"Top-level function to be passed to `save-lisp-and-die'."
(handler-case
(with-user-abort:with-user-abort
(main (uiop:command-line-arguments)))
(with-user-abort:user-abort ()
(format *error-output* "Keyboard interrupt~%")
(uiop:quit 1))))