236 lines
8.0 KiB
Scheme
236 lines
8.0 KiB
Scheme
;; Copyright © 2024 Jaidyn Ann <jadedctrl@posteo.at>
|
||
;;
|
||
;; 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/>.
|
||
|
||
(import scheme
|
||
(chicken base)
|
||
(chicken condition)
|
||
(chicken file)
|
||
(chicken pathname)
|
||
(chicken process)
|
||
(chicken io)
|
||
(chicken repl)
|
||
(chicken process-context)
|
||
(chicken string)
|
||
(chicken time)
|
||
(srfi 1)
|
||
(srfi 13)
|
||
(srfi 18)
|
||
(prefix getopt-long getopt:)
|
||
(prefix nrepl nrepl:)
|
||
(prefix uri-common uri:)
|
||
(prefix vcarded vcard:)
|
||
qt-light)
|
||
|
||
|
||
(define qt-app #f) ;; The <qt-application> object.
|
||
(define qt-win #f) ;; The <qt-window> object.
|
||
|
||
|
||
;; Start & run the application.
|
||
(define (init)
|
||
(let [(cli-args (parse-cli-args (command-line-arguments)))]
|
||
;; If --help, then print a usage message and quit.
|
||
(if (alist-ref 'help cli-args)
|
||
(cli-usage))
|
||
;; Otherwise, let’s get our threads started!
|
||
(let [(qt-thread (init-qt cli-args))
|
||
(nrepl-thread (init-nrepl cli-args))
|
||
(repl-thread (thread-start! repl))]
|
||
;; Wait for the QT program, even after stdin is closed off.
|
||
(thread-join! qt-thread))))
|
||
|
||
|
||
;; Set up some global variables (for easier live REPL use), prepare the QT app.
|
||
(define (init-qt cli-args)
|
||
(set! qt-app (qt:init))
|
||
(set! qt-win (create-window))
|
||
(init-window qt-win)
|
||
;; Kick off the QT thread, then open the cli free-arg vCard file, if provided.
|
||
;; That is, like `$ contact freeArgFile.vcf`.
|
||
(let [(qt-thread (thread-start! qt-loop))
|
||
(last-free-arg (condition-case (last (car cli-args)) (var () #f)))]
|
||
(if (and last-free-arg (string? last-free-arg) (file-exists? last-free-arg))
|
||
(open-vcard-file qt-win last-free-arg))
|
||
qt-thread))
|
||
|
||
|
||
;; Kick off our remote TCP-accessible REPL, if the user enabled it at cli.
|
||
(define (init-nrepl cli-args)
|
||
(if (alist-ref 'repl cli-args)
|
||
(thread-start!
|
||
(lambda ()
|
||
(nrepl:nrepl (string->number (alist-ref 'repl cli-args)))))))
|
||
|
||
|
||
;; Print a “usage” help message, telling the user how to run the program.
|
||
(define (cli-usage)
|
||
(print "usage: " (pathname-file (program-name)) " [-h] [--repl PORT] [VCF_FILE]")
|
||
(print)
|
||
(print (pathname-file (program-name)) " is a simple contacts program for managing")
|
||
(print "vCard-format contacts.")
|
||
(print)
|
||
(print (getopt:usage cli-args-grammar))
|
||
(exit))
|
||
|
||
|
||
;; Parse out command-line args into an alist.
|
||
;; '("dad" "-h" "--repl=12" "mm") → '(("dad" "mm") (help #t) (repl 12))
|
||
(define (parse-cli-args args)
|
||
(handle-exceptions
|
||
exn
|
||
(and
|
||
(print ((condition-property-accessor 'exn 'message) exn))
|
||
'((help . #t)))
|
||
(getopt:getopt-long args cli-args-grammar)))
|
||
|
||
|
||
;; Definition of our command-line arguments, in getopt-long’s format.
|
||
(define cli-args-grammar
|
||
'((help "display this help message"
|
||
(single-char #\h))
|
||
(repl "start a TCP-accesible REPL at the given port"
|
||
(value #t))))
|
||
|
||
|
||
;; Loop through QT’s processing, again and again.
|
||
(define (qt-loop)
|
||
(qt:run #t)
|
||
(qt-loop))
|
||
|
||
|
||
;; Create the application window.
|
||
(define (create-window)
|
||
(qt:widget (window-contents)))
|
||
|
||
|
||
;; Return the UI’s XML, read from “contacts.ui”.
|
||
;; We could generate this XML ourselves, and write a nice s-expr front-end,
|
||
;; maybe… `o`
|
||
(define (window-contents)
|
||
(call-with-input-file
|
||
"contact.ui"
|
||
(lambda (in-port) (read-string #f in-port))))
|
||
|
||
|
||
;; Initialize the window.
|
||
(define (init-window window)
|
||
;; Set the profile-picture label to a default theme icon.
|
||
(let [(default-profile-pic
|
||
(or (qt:theme-icon "person") (qt:theme-icon "contact-new")))]
|
||
(if default-profile-pic
|
||
(set! (qt:property (qt:find window "avatarLabel") "pixmap")
|
||
(qt:icon->pixmap default-profile-pic 100 100))))
|
||
;; Now prepare callbacks and show the window.
|
||
(window-callbacks window)
|
||
(qt:show window))
|
||
|
||
|
||
;; Connect callback functions to widgets’ signals.
|
||
(define (window-callbacks window)
|
||
(menubar-callbacks window))
|
||
|
||
|
||
;; Connect callback functions to menubar items.
|
||
(define (menubar-callbacks window)
|
||
(let* [(menu-file-exit (qt:find window "actionQuit"))
|
||
(menu-file-save (qt:find window "actionSave"))
|
||
(menu-file-open (qt:find window "actionOpen"))
|
||
(menu-file-new (qt:find window "actionNew"))]
|
||
;; We connect to https://doc.qt.io/qt-6/qaction.html#triggered
|
||
;; Simply kill the program.
|
||
(if menu-file-exit
|
||
(qt:connect
|
||
menu-file-exit "triggered()"
|
||
(qt:receiver exit)))
|
||
;; If they try to Save, tell them it’s not supported.
|
||
(if menu-file-save
|
||
(qt:connect
|
||
menu-file-save "triggered()"
|
||
(qt:receiver
|
||
(lambda ()
|
||
(qt:message "Saving is not implemented.")))))
|
||
;; If they want a new contact, create a new, blank, window.
|
||
;; That is, a new process.
|
||
(if menu-file-new
|
||
(qt:connect
|
||
menu-file-new "triggered()"
|
||
(qt:receiver
|
||
(lambda ()
|
||
(let [(program-args
|
||
;; If we opened a pre-existing contact (last arg is a file),
|
||
;; remove that argument.
|
||
(drop-right (cdr (argv))
|
||
(if (file-exists? (last (argv)))
|
||
1
|
||
0)))]
|
||
(process-run (executable-pathname) program-args))))))
|
||
;; If they want to open a contact through the Open… dialogue, we should open
|
||
;; the contact in a new window.
|
||
(if menu-file-open
|
||
(qt:connect
|
||
menu-file-open "triggered()"
|
||
(qt:receiver
|
||
(lambda ()
|
||
(let* [(contacts-dir (conc (get-environment-variable "HOME")
|
||
"/Contacts"))
|
||
(selected-file (qt:get-open-filename
|
||
"Select a contact file to open…"
|
||
contacts-dir))
|
||
(program-args (append (cdr (argv)) (list selected-file)))]
|
||
(if (not (string-null? selected-file))
|
||
(process-run
|
||
(executable-pathname)
|
||
program-args)))))))))
|
||
|
||
|
||
;; Parse a vCard file and populate the window’s forms with its contents.
|
||
(define (open-vcard-file window file)
|
||
(if (and (file-exists? file)
|
||
(file-readable? file))
|
||
(thread-start! (lambda () (populate-with-vcard
|
||
window
|
||
(with-input-from-file file
|
||
vcard:read-vcard))))))
|
||
|
||
|
||
;; Simply map vCard property-names to their corresponding name in the window’s
|
||
;; fields.
|
||
(define property->formname-alist
|
||
'((FN . "name")
|
||
(ADR . "address")
|
||
(TEL . "homePhone")
|
||
(TEL . "workPhone")
|
||
(EMAIL . "eMail")
|
||
(URL . "url")
|
||
(NICKNAME . "nickname")))
|
||
|
||
|
||
;; Given a parsed vCard in vcarded’s alist format, populate the window’s fields.
|
||
;; Here’s the format:
|
||
;; ((PROPERTY (ATTRIBUTES) VALUE)
|
||
;; (FN () "A. Dmytryshyn")
|
||
;; (ADR ("TYPE=home") ("" "" "1234 Abc.", "", "", "", "")))
|
||
(define (populate-with-vcard window vcard-alist)
|
||
(map (lambda (property)
|
||
(let* [(formname (alist-ref (car property) property->formname-alist))
|
||
(lineEditName (conc formname "LineEdit"))
|
||
(lineEditWidget (if formname (qt:find window lineEditName) #f))]
|
||
(if lineEditWidget
|
||
(set! (qt:property lineEditWidget "text") (last property)))))
|
||
vcard-alist))
|
||
|
||
|
||
(init)
|