mirror of https://codeberg.org/cage/tinmop/
694 lines
30 KiB
Common Lisp
694 lines
30 KiB
Common Lisp
(in-package :client-main-window)
|
|
|
|
(named-readtables:in-readtable nodgui.syntax:nodgui-syntax)
|
|
|
|
(a:define-constant +stream-status-streaming+ :streaming :test #'eq)
|
|
|
|
(a:define-constant +stream-status-canceled+ :canceled :test #'eq)
|
|
|
|
(a:define-constant +stream-status-downloading+ :downloading :test #'eq)
|
|
|
|
(defclass gemini-stream ()
|
|
((server-stream-handle
|
|
:initform nil
|
|
:initarg :server-stream-handle
|
|
:accessor server-stream-handle)
|
|
(status
|
|
:initform +stream-status-streaming+
|
|
:initarg :status
|
|
:accessor status)
|
|
(status-lock
|
|
:initform (bt:make-lock)
|
|
:reader status-lock)
|
|
(fetching-thread
|
|
:initform nil
|
|
:initarg :fetching-thread
|
|
:accessor fetching-thread)))
|
|
|
|
(defgeneric status (object))
|
|
|
|
(defmethod status ((object gemini-stream))
|
|
(misc:with-lock ((status-lock object))
|
|
(slot-value object 'status)))
|
|
|
|
(defmethod (setf status) ((object gemini-stream) val)
|
|
(misc:with-lock ((status-lock object))
|
|
(setf (slot-value object 'status) val)
|
|
val))
|
|
|
|
(defparameter *gemini-streams-db* ())
|
|
|
|
(defun push-db-stream (stream-object)
|
|
(pushnew stream-object
|
|
*gemini-streams-db*
|
|
:test (lambda (a b)
|
|
(string= (server-stream-handle a)
|
|
(server-stream-handle b))))
|
|
*gemini-streams-db*)
|
|
|
|
(defun remove-db-stream (stream-object)
|
|
(setf *gemini-streams-db*
|
|
(remove stream-object *gemini-streams-db*))
|
|
*gemini-streams-db*)
|
|
|
|
(defmethod abort-downloading ((object gemini-stream))
|
|
(setf (status object) +stream-status-canceled+))
|
|
|
|
(defun remove-all-db-stream ()
|
|
(map nil
|
|
(lambda (a) (abort-downloading a))
|
|
*gemini-streams-db*)
|
|
(setf *gemini-streams-db* ())
|
|
*gemini-streams-db*)
|
|
|
|
(defun find-db-stream-if (predicate)
|
|
(find-if predicate *gemini-streams-db*))
|
|
|
|
(defun find-db-stream-url (url)
|
|
(find-db-stream-if (lambda (a) (string= (server-stream-handle a) url))))
|
|
|
|
(defun find-streaming-stream-url ()
|
|
(find-db-stream-if (lambda (a) (eq (status a) +stream-status-streaming+))))
|
|
|
|
(defun notify-request-error (error)
|
|
(gui-goodies:error-dialog gui-goodies:*toplevel* error))
|
|
|
|
(defgeneric stop-stream-thread (object))
|
|
|
|
(defmethod stop-stream-thread ((object gemini-stream))
|
|
(with-accessors ((fetching-thread fetching-thread)) object
|
|
(abort-downloading object)
|
|
(when (bt:threadp fetching-thread)
|
|
(bt:join-thread fetching-thread)))
|
|
object)
|
|
|
|
(defmethod stop-stream-thread ((object string))
|
|
(let ((stream-wrapper (find-db-stream-url object)))
|
|
(stop-stream-thread stream-wrapper)))
|
|
|
|
(defun stop-steaming-stream-thread ()
|
|
(let ((stream-wrapper (find-streaming-stream-url)))
|
|
(stop-stream-thread stream-wrapper)))
|
|
|
|
(defun maybe-stop-steaming-stream-thread ()
|
|
(a:when-let ((stream-wrapper (find-streaming-stream-url)))
|
|
(stop-stream-thread stream-wrapper)))
|
|
|
|
(defmacro with-notify-errors (&body body)
|
|
`(handler-case
|
|
(progn ,@body)
|
|
(comm:rpc-error-response (e)
|
|
#+debug-mode (misc:dbg "backend comunication RPC error ~a" e)
|
|
(notify-request-error (format nil
|
|
(_ "~a: ~a")
|
|
(comm:code e)
|
|
(conditions:text e))))
|
|
(error (e)
|
|
#+debug-mode (misc:dbg "backend comunication error ~a" e)
|
|
(notify-request-error e))))
|
|
|
|
(defun enqueue-request-notify-error (method-name id &rest args)
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(with-notify-errors
|
|
(apply #'comm:make-request method-name id args))))
|
|
|
|
(defun slurp-gemini-stream (iri &key
|
|
(use-cache t)
|
|
(process-function #'identity)
|
|
(aborting-function (constantly nil)))
|
|
(enqueue-request-notify-error :gemini-request 1 iri use-cache)
|
|
(labels ((stream-exausted-p ()
|
|
(let ((status-completed (enqueue-request-notify-error :gemini-stream-completed-p
|
|
1
|
|
iri)))
|
|
|
|
status-completed))
|
|
(loop-fetch (&optional (last-lines-fetched-count 0))
|
|
(when (not (or (funcall aborting-function)
|
|
(stream-exausted-p)))
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(with-notify-errors
|
|
(let* ((last-lines-fetched (comm:make-request :gemini-stream-parsed-line-slice
|
|
1
|
|
iri
|
|
last-lines-fetched-count
|
|
nil))
|
|
(next-start-fetching (length last-lines-fetched)))
|
|
(when last-lines-fetched
|
|
(funcall process-function last-lines-fetched))
|
|
(loop-fetch (+ last-lines-fetched-count
|
|
next-start-fetching))))))))
|
|
(loop-fetch)))
|
|
|
|
(defun start-streaming-thread (iri &key
|
|
(use-cache t)
|
|
(process-function #'identity)
|
|
(status +stream-status-streaming+))
|
|
(let ((existing-stream (find-db-stream-url iri)))
|
|
(when existing-stream
|
|
(stop-stream-thread existing-stream)
|
|
(setf (status existing-stream) status))
|
|
(let ((stream-wrapper (or existing-stream
|
|
(make-instance 'gemini-stream
|
|
:server-stream-handle iri
|
|
:status status))))
|
|
(when (not existing-stream)
|
|
(push-db-stream stream-wrapper))
|
|
(flet ((aborting-function ()
|
|
(eq (status stream-wrapper) +stream-status-canceled+)))
|
|
(let ((stream-thread (bt:make-thread (lambda ()
|
|
(slurp-gemini-stream iri
|
|
:use-cache use-cache
|
|
:process-function
|
|
process-function
|
|
:aborting-function
|
|
#'aborting-function)))))
|
|
(setf (fetching-thread stream-wrapper) stream-thread)
|
|
stream-wrapper)))))
|
|
|
|
|
|
(defun initialize-menu (parent)
|
|
(with-accessors ((main-window main-window)) parent
|
|
(let* ((bar (gui:make-menubar parent))
|
|
(file (gui:make-menu bar (_ "File") :underline 0))
|
|
(help (gui:make-menu bar (_ "Help") :underline 0)))
|
|
(gui:make-menubutton file (_ "Quit") #'menu:quit :underline 0)
|
|
(gui:make-menubutton help (_ "About") #'menu:help-about :underline 0))))
|
|
|
|
(defclass tool-bar (gui:frame)
|
|
((iri-entry
|
|
:initform nil
|
|
:initarg :iri-entry
|
|
:accessor iri-entry)
|
|
(back-button
|
|
:initform nil
|
|
:initarg :back-button
|
|
:accessor back-button)
|
|
(reload-button
|
|
:initform nil
|
|
:initarg :reload-button
|
|
:accessor reload-button)
|
|
(up-button
|
|
:initform nil
|
|
:initarg :up-button
|
|
:accessor up-button)
|
|
(go-button
|
|
:initform nil
|
|
:initarg :go-button
|
|
:accessor go-button)))
|
|
|
|
(defun autocomplete-iri-clsr (toolbar)
|
|
(declare (ignore toolbar))
|
|
(lambda (hint)
|
|
(if (or (complete:expand-iri-as-local-path-p hint)
|
|
(> (length hint) 2))
|
|
(with-notify-errors
|
|
(let ((match-results (cev:enqueue-request-and-wait-results :complete-net-address
|
|
1
|
|
ev:+maximum-event-priority+
|
|
hint)))
|
|
(values (getf match-results :matches)
|
|
(getf match-results :indices))))
|
|
hint)))
|
|
|
|
(defmacro gen-ir-access (key)
|
|
`(defun ,(misc:format-fn-symbol t "ir-~a" key) (line)
|
|
(getf line ,(a:make-keyword key))))
|
|
|
|
(gen-ir-access type)
|
|
|
|
(gen-ir-access source-id)
|
|
|
|
(gen-ir-access header-group-id)
|
|
|
|
(gen-ir-access source-line)
|
|
|
|
(gen-ir-access line)
|
|
|
|
(gen-ir-access href)
|
|
|
|
(gen-ir-access pre-alt-text)
|
|
|
|
(defun link-click-mouse-1-callback-clsr (link-value main-window &key (use-cache t))
|
|
(lambda ()
|
|
(open-iri link-value main-window use-cache)))
|
|
|
|
(defun absolutize-link (request-iri link-value)
|
|
(let ((parsed-request-iri (iri:iri-parse request-iri)))
|
|
(multiple-value-bind (x host path query port y w z)
|
|
(gemini-client:displace-iri parsed-request-iri)
|
|
(declare (ignore x y w z))
|
|
(gemini-parser:absolutize-link link-value
|
|
host
|
|
port
|
|
path
|
|
query))))
|
|
|
|
(defun collect-ir-lines (request-iri main-window lines)
|
|
(with-accessors ((ir-lines ir-lines)
|
|
(ir-rendered-lines ir-rendered-lines)
|
|
(gemtext-widget gemtext-widget)) main-window
|
|
(labels ((push-prefixed (prefix ir)
|
|
(let ((raw-line (format nil "~a~a" prefix (ir-line ir))))
|
|
(vector-push-extend raw-line ir-rendered-lines)))
|
|
(key->font (key)
|
|
(ecase key
|
|
((:vertical-space :pre-end :text :li)
|
|
nil)
|
|
(:as-is
|
|
(gui-conf:gemini-preformatted-text-font-configuration))
|
|
(:h1
|
|
(gui-conf:gemini-h1-font-configuration))
|
|
(:h2
|
|
(gui-conf:gemini-h2-font-configuration))
|
|
(:h3
|
|
(gui-conf:gemini-h3-font-configuration))
|
|
(:quote
|
|
(gui-conf:gemini-quote-font-configuration))
|
|
(:pre
|
|
(gui-conf:gemini-preformatted-text-font-configuration))
|
|
(:a
|
|
(gui-conf:gemini-link-font-configuration))))
|
|
(key->colors (key)
|
|
(ecase key
|
|
((:vertical-space :pre-end :text :li)
|
|
nil)
|
|
(:as-is
|
|
(gui-conf:gemini-preformatted-text-colors))
|
|
(:h1
|
|
(gui-conf:gemini-h1-colors))
|
|
(:h2
|
|
(gui-conf:gemini-h2-colors))
|
|
(:h3
|
|
(gui-conf:gemini-h3-colors))
|
|
(:quote
|
|
(gui-conf:gemini-quote-colors))
|
|
(:pre
|
|
(gui-conf:gemini-preformatted-text-colors))
|
|
(:a
|
|
(gui-conf:gemini-link-colors))))
|
|
(key->justification (key)
|
|
(ecase key
|
|
((:vertical-space :text :pre-end :li :a)
|
|
nil)
|
|
(:as-is
|
|
(gui-conf:gemini-preformatted-text-justification))
|
|
(:h1
|
|
(gui-conf:gemini-h1-justification))
|
|
(:h2
|
|
(gui-conf:gemini-h2-justification))
|
|
(:h3
|
|
(gui-conf:gemini-h3-justification))
|
|
(:quote
|
|
(gui-conf:gemini-quote-justification))
|
|
(:pre
|
|
(gui-conf:gemini-preformatted-text-justification))))
|
|
(linkify (line line-number)
|
|
(multiple-value-bind (link-bg link-fg)
|
|
(gui-conf:gemini-link-colors)
|
|
(let* ((link-font (gui-conf:gemini-link-font-configuration))
|
|
(link-value (ir-href line))
|
|
(target-iri (absolutize-link request-iri link-value))
|
|
(link-name (or (ir-line line)
|
|
link-value))
|
|
(prefix-gemini (gui-conf:gemini-link-prefix-to-gemini))
|
|
(prefix-www (gui-conf:gemini-link-prefix-to-http))
|
|
(prefix-other (gui-conf:gemini-link-prefix-to-other))
|
|
(link-text (if (text-utils:starting-emoji link-name)
|
|
(format nil
|
|
"~a~a"
|
|
(trim-blanks prefix-other)
|
|
link-name)
|
|
(cond
|
|
((gemini-parser::gemini-link-iri-p link-value)
|
|
(format nil "~a~a" prefix-gemini link-name))
|
|
((html-utils::http-link-iri-p link-value)
|
|
(format nil "~a~a" prefix-www link-name))
|
|
(t
|
|
(format nil "~a~a" prefix-other link-name))))))
|
|
(vector-push-extend link-text ir-rendered-lines)
|
|
(let ((new-text-line-start `(:line ,line-number :char 0)))
|
|
(gui:append-text gemtext-widget (a:last-elt ir-rendered-lines))
|
|
(gui:make-link-button gemtext-widget
|
|
new-text-line-start
|
|
(gui:make-indices-end)
|
|
link-font
|
|
link-fg
|
|
link-bg
|
|
(link-click-mouse-1-callback-clsr target-iri
|
|
main-window)
|
|
:over-callback
|
|
(lambda () (print-info-message target-iri))
|
|
:leave-callback
|
|
(lambda () (print-info-message "")))
|
|
|
|
(gui:append-line gemtext-widget "")))))
|
|
(render-line (key text line-number)
|
|
(let ((font (key->font key))
|
|
(justification (key->justification key))
|
|
(start-index `(:line ,line-number :char 0)))
|
|
(gui:append-text gemtext-widget text)
|
|
(if font
|
|
(multiple-value-bind (background foreground)
|
|
(key->colors key)
|
|
(let ((tag (gui:tag-create gemtext-widget
|
|
(gui::create-tag-name)
|
|
start-index
|
|
(gui:make-indices-end))))
|
|
(gui:tag-configure gemtext-widget
|
|
tag
|
|
:font font
|
|
:foreground foreground
|
|
:background background
|
|
:justify justification)
|
|
(gui:append-line gemtext-widget "")
|
|
tag))
|
|
(progn
|
|
(gui:append-line gemtext-widget "")
|
|
nil)))))
|
|
(loop with render-line-count = 0
|
|
with starting-pre-block-line = -1
|
|
with ending-pre-block-line = -1
|
|
with current-pre-block-alt-text = nil
|
|
for line in lines do
|
|
(vector-push-extend line ir-lines)
|
|
(let ((type (ir-type line)))
|
|
(ecase (format-keyword type)
|
|
(:vertical-space
|
|
(vector-push-extend (format nil "") ir-rendered-lines)
|
|
(incf render-line-count)
|
|
(render-line :vertical-space (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:as-is
|
|
(vector-push-extend (ir-line line) ir-rendered-lines)
|
|
(incf render-line-count)
|
|
(render-line :as-is (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:text
|
|
(vector-push-extend (ir-line line) ir-rendered-lines)
|
|
(incf render-line-count)
|
|
(render-line :text (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:h1
|
|
(push-prefixed (gui-conf:gemini-h1-prefix) line)
|
|
(incf render-line-count)
|
|
(render-line :h1 (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:h2
|
|
(push-prefixed (gui-conf:gemini-h1-prefix) line)
|
|
(incf render-line-count)
|
|
(render-line :h2 (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:h3
|
|
(push-prefixed (gui-conf:gemini-h1-prefix) line)
|
|
(incf render-line-count)
|
|
(render-line :h3 (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:li
|
|
(push-prefixed (gui-conf:gemini-bullet-prefix) line)
|
|
(incf render-line-count)
|
|
(render-line :li (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:quote
|
|
(push-prefixed (gui-conf:gemini-quote-prefix) line)
|
|
(incf render-line-count)
|
|
(render-line :quote (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:pre
|
|
(vector-push-extend (format nil "") ir-rendered-lines)
|
|
(setf starting-pre-block-line (1+ render-line-count))
|
|
(setf current-pre-block-alt-text (ir-pre-alt-text line))
|
|
(render-line :pre (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:pre-end
|
|
(vector-push-extend (format nil "") ir-rendered-lines)
|
|
(setf ending-pre-block-line (1+ render-line-count))
|
|
(render-line :pre-end (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:a
|
|
(incf render-line-count)
|
|
(linkify line render-line-count))))))))
|
|
|
|
(defun displace-gemini-response (response)
|
|
(values (getf response :status)
|
|
(getf response :status-description)
|
|
(getf response :meta)
|
|
(getf response :cached)
|
|
(getf response :iri)))
|
|
|
|
(defun open-local-path (path main-window)
|
|
(cond
|
|
((fs:file-exists-p path)
|
|
(if (fs:has-extension path +gemini-file-extension+)
|
|
(let ((parsed-lines (cev:enqueue-request-and-wait-results :gemini-parse-local-file
|
|
1
|
|
ev:+standard-event-priority+
|
|
path)))
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(clean-gemtext main-window)
|
|
(collect-ir-lines path gui-goodies:*main-frame* parsed-lines)))
|
|
(let ((lines (cev:enqueue-request-and-wait-results :gemini-slurp-local-file
|
|
1
|
|
ev:+standard-event-priority+
|
|
path)))
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(clean-gemtext main-window)
|
|
(set-text-gemtext main-window lines)))))
|
|
((fs:directory-exists-p path)
|
|
(gui:choose-directory :initial-dir path :parent main-window :mustexist t))
|
|
(t
|
|
(notify-request-error (format nil (_ "No such file or directory: ~a") path)))))
|
|
|
|
(defun open-iri (iri main-window use-cache)
|
|
(handler-case
|
|
(let ((parsed-iri (iri:iri-parse iri)))
|
|
(if (iri:absolute-url-p iri)
|
|
(if (string= (uri:scheme parsed-iri)
|
|
gemini-constants:+gemini-scheme+)
|
|
(start-stream-iri iri main-window use-cache)
|
|
(client-os-utils:open-resource-with-external-program main-window iri))
|
|
(open-local-path iri main-window)))
|
|
(error (e)
|
|
(notify-request-error e))))
|
|
|
|
(defun start-stream-iri (iri main-window use-cache &optional (status +stream-status-streaming+))
|
|
(let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request
|
|
1
|
|
ev:+maximum-event-priority+
|
|
iri
|
|
use-cache)))
|
|
(multiple-value-bind (status-code
|
|
status-description
|
|
meta
|
|
cached
|
|
original-iri)
|
|
(displace-gemini-response connecting-response)
|
|
(cond
|
|
((= status-code comm:+tofu-error-status-code+)
|
|
(when (gui:ask-yesno meta
|
|
:title (_ "Server certificate error")
|
|
:parent main-window)
|
|
(cev:enqueue-request-and-wait-results :gemini-delete-certificate
|
|
1
|
|
ev:+maximum-event-priority+
|
|
iri)
|
|
(start-stream-iri iri main-window use-cache status)))
|
|
((or (gemini-client:header-temporary-failure-p status-code)
|
|
(gemini-client:header-permanent-failure-p status-code)
|
|
(gemini-client:header-certificate-failure-p status-code))
|
|
(error (_ "Error connecting to: ~a:~2%~a") iri status-description))
|
|
((gemini-client:header-redirect-p status-code)
|
|
(when (gui:ask-yesno (format nil (_ "Follow redirection to ~a?") meta)
|
|
:title (_ "Redirection")
|
|
:parent main-window)
|
|
(let ((redirect-iri (if (iri:absolute-url-p meta)
|
|
meta
|
|
(absolutize-link iri meta))))
|
|
(start-stream-iri redirect-iri main-window use-cache status))))
|
|
((gemini-client:header-success-p status-code)
|
|
(cond
|
|
((eq status +stream-status-streaming+)
|
|
(let ((stopped-stream (maybe-stop-steaming-stream-thread)))
|
|
(clean-gemtext main-window)
|
|
(start-streaming-thread iri
|
|
:use-cache nil
|
|
:process-function
|
|
(lambda (lines)
|
|
;; this test ensures that the
|
|
;; collecting events left on
|
|
;; the queue won't be actually
|
|
;; processed, just discarded
|
|
(when (and stopped-stream
|
|
(not (eq (status stopped-stream)
|
|
+stream-status-canceled+)))
|
|
(collect-ir-lines iri main-window lines)))
|
|
:status status)))
|
|
((eq status +stream-status-downloading+)
|
|
(when (not (find-db-stream-url iri))
|
|
(enqueue-request-notify-error :gemini-request 1 iri use-cache)))
|
|
(t
|
|
(error "Unrecognized stream status for address ~s: ~s" iri status))))))))
|
|
|
|
(defun open-iri-clsr (main-window use-cache)
|
|
(lambda ()
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
|
(let* ((iri (trim-blanks (gui:text iri-entry))))
|
|
(gui-mw::hide-candidates iri-entry)
|
|
(open-iri iri main-window use-cache))))))
|
|
|
|
(defun setup-main-window-events (main-window)
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
(with-accessors ((iri-entry iri-entry)
|
|
(back-button back-button)
|
|
(reload-button reload-button)
|
|
(up-button up-button)
|
|
(go-button go-button)) tool-bar
|
|
(let ((entry-autocomplete (gui-mw:autocomplete-entry-widget iri-entry)))
|
|
(gui:bind entry-autocomplete
|
|
#$<KeyPress-Return>$
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(funcall (open-iri-clsr main-window t)))
|
|
:append nil))
|
|
(setf (gui:command go-button) (open-iri-clsr main-window t)))))
|
|
|
|
(defmethod initialize-instance :after ((object tool-bar) &key &allow-other-keys)
|
|
(with-accessors ((iri-entry iri-entry)
|
|
(back-button back-button)
|
|
(reload-button reload-button)
|
|
(up-button up-button)
|
|
(go-button go-button)) object
|
|
(gui:configure object :relief :raised)
|
|
(setf iri-entry (make-instance 'gui-mw:autocomplete-entry
|
|
:master object
|
|
:autocomplete-function (autocomplete-iri-clsr object)))
|
|
(setf back-button (make-instance 'gui:button :master object :image icons:*back*))
|
|
(setf reload-button (make-instance 'gui:button :master object :image icons:*refresh*))
|
|
(setf go-button (make-instance 'gui:button :master object :image icons:*open-iri*))
|
|
(setf up-button (make-instance 'gui:button :master object :image icons:*up*))
|
|
(gui-goodies:attach-tooltips (back-button (_ "go back"))
|
|
(reload-button (_ "reload address"))
|
|
(go-button (_ "go to address"))
|
|
(up-button (_ "one level up")))
|
|
(gui:grid back-button 0 1 :sticky :nsw)
|
|
(gui:grid iri-entry 0 2 :sticky :we :padx +minimum-padding+)
|
|
(gui:grid go-button 0 3 :sticky :e)
|
|
(gui:grid reload-button 0 4 :sticky :e)
|
|
(gui:grid up-button 0 5 :sticky :e)
|
|
(gui:grid-columnconfigure object 2 :weight 2)
|
|
object))
|
|
|
|
(defclass toc-frame (gui:frame)
|
|
((toc-listbox
|
|
:initform nil
|
|
:initarg :toc-listbox
|
|
:accessor toc-listbox)
|
|
(toc-data
|
|
:initform nil
|
|
:initarg :toc-data
|
|
:accessor toc-data)))
|
|
|
|
(defmethod initialize-instance :after ((object toc-frame) &key &allow-other-keys)
|
|
(with-accessors ((toc-listbox toc-listbox)
|
|
(toc-data toc-data)) object
|
|
(setf toc-listbox (make-instance 'gui:scrolled-listbox
|
|
:master object
|
|
:name nil))
|
|
(gui:grid toc-listbox 0 0
|
|
:sticky :nswe
|
|
:ipadx +minimum-padding+
|
|
:ipady +minimum-padding+)
|
|
(gui-goodies:gui-resize-grid-all object)
|
|
))
|
|
|
|
|
|
(defclass main-frame (gui:frame)
|
|
((main-window
|
|
:initform nil
|
|
:initarg :main-window
|
|
:accessor main-window)
|
|
(gemtext-widget
|
|
:initform nil
|
|
:initarg :gemtext-widget
|
|
:accessor gemtext-widget)
|
|
(tool-bar
|
|
:initform nil
|
|
:initarg :tool-bar
|
|
:accessor tool-bar)
|
|
(toc-frame
|
|
:initform nil
|
|
:initarg :toc-frame
|
|
:accessor toc-frame)
|
|
(info-frame
|
|
:initform nil
|
|
:initarg :info-frame
|
|
:accessor info-frame)
|
|
(info-text
|
|
:initform nil
|
|
:initarg :info-text
|
|
:accessor info-text)
|
|
(ir-rendered-lines
|
|
:initform (misc:make-fresh-array 0)
|
|
:initarg :ir-rendered-lines
|
|
:accessor ir-rendered-lines)
|
|
(ir-lines
|
|
:initform (misc:make-fresh-array 0)
|
|
:initarg :ir-lines
|
|
:accessor ir-lines)))
|
|
|
|
(defmethod initialize-instance :after ((object main-frame) &key &allow-other-keys)
|
|
(with-accessors ((main-window main-window)
|
|
(tool-bar tool-bar)
|
|
(toc-frame toc-frame)
|
|
(info-frame info-frame)
|
|
(info-text info-text)
|
|
(gemtext-widget gemtext-widget)) object
|
|
(setf tool-bar (make-instance 'tool-bar :master object))
|
|
(setf toc-frame (make-instance 'toc-frame :master object))
|
|
(setf gemtext-widget (make-instance 'gui:scrolled-text :master object :read-only t))
|
|
(gui:configure gemtext-widget :wrap :word)
|
|
(setf info-frame (make-instance 'gui:frame :master object :relief :sunken :borderwidth 1))
|
|
(setf info-text (make-instance 'gui:text :height 1 :wrap :none :master info-frame))
|
|
(gui:configure info-text :font gui:+tk-small-caption-font+)
|
|
(gui:grid info-text 0 0 :sticky :news)
|
|
(gui-goodies:gui-resize-grid-all info-frame)
|
|
(gui:grid tool-bar 0 0 :sticky :new :columnspan 2)
|
|
(gui:grid toc-frame 1 0 :sticky :nsw)
|
|
(gui:grid gemtext-widget 1 1 :sticky :news)
|
|
(gui:grid info-frame 3 0 :sticky :news :columnspan 2)
|
|
(gui:grid-columnconfigure object 1 :weight 1)
|
|
(gui:grid-rowconfigure object 1 :weight 1)
|
|
(setup-main-window-events object)
|
|
(gui:focus (nodgui.mw:autocomplete-entry-widget (iri-entry (tool-bar object))))
|
|
object))
|
|
|
|
(defun print-info-message (message &key
|
|
(color (gui-goodies:parse-color "black"))
|
|
(bold nil))
|
|
(let ((info-widget (info-text gui-goodies:*main-frame*)))
|
|
(setf (gui:text info-widget) message)
|
|
(let ((color-tag (gui:tag-create info-widget
|
|
(nodgui.utils:create-tag-name)
|
|
(gui:make-indices-start)
|
|
(gui:make-indices-end))))
|
|
(if bold
|
|
(gui:tag-configure info-widget
|
|
color-tag
|
|
:foreground color
|
|
:font "bold")
|
|
(gui:tag-configure info-widget
|
|
color-tag
|
|
:foreground color)))))
|
|
|
|
(defun print-error-message (message)
|
|
(print-info-message message :color (gui-goodies:parse-color "red") :bold t))
|
|
|
|
(defun clean-gemtext (main-window)
|
|
(setf (gui:text (gemtext-widget main-window)) ""))
|
|
|
|
(defun set-text-gemtext (main-window text)
|
|
(setf (gui:text (gemtext-widget main-window)) text))
|
|
|
|
(defun init-main-window ()
|
|
(gui:with-nodgui (:title +program-name+)
|
|
(icons:load-icons)
|
|
(initialize-menu gui:*tk*)
|
|
(setf gui-goodies:*toplevel* gui:*tk*)
|
|
(setf gui-goodies:*gui-server* gui:*wish*)
|
|
(client-events:start-events-loop)
|
|
(let ((main-frame (make-instance 'main-frame)))
|
|
(setf gui-goodies:*main-frame* main-frame)
|
|
(gui:grid main-frame 0 0 :sticky :nswe)
|
|
(gui-goodies:gui-resize-grid-all gui-goodies:*toplevel*))))
|