Some crap that doesn't work right because Qt sucks balls

editor.lisp

@@ -25,6 +25,9 @@
 (define-subwidget (highlighter code) (q+:make-qtextcharformat)
   (setf (q+:foreground code) (q+:make-qbrush (q+:make-qcolor 250 160 40))))
 
+(define-subwidget (highlighter url) (q+:make-qtextcharformat)
+  (setf (q+:font-underline url) T))
+
 (define-override (highlighter highlight-block) (text)
   (cond ((< (q+:previous-block-state highlighter) 2)
          (cl-ppcre:do-scans (s e rs re "(^(\\[ |- |\\d+\\.|#+ |;+ ))|(\\*\\*|//|__|<-|->|\\\\)" text)
@@ -42,7 +45,9 @@
            (setf (q+:format highlighter) (values s (- e s) embed)))
          (cl-ppcre:do-scans (s e rs re "^(::+).*" text)
            (setf (q+:format highlighter) (values s (- e s) keywords))
-           (setf (q+:current-block-state highlighter) (print (- (aref re 0) (aref rs 0))))))
+           (setf (q+:current-block-state highlighter) (print (- (aref re 0) (aref rs 0)))))
+         (cl-ppcre:do-scans (s e rs re "\\w[\\d\\w+\\-.]*://[\\d\\w$\\-_.+!*'()&,/:;=?@%#\\\\]+" text)
+           (setf (q+:format highlighter) (values s (- e s) url))))
         ((and (= (q+:previous-block-state highlighter) (length text))
               (every (lambda (c) (char= #\: c)) text))
          (setf (q+:format highlighter) (values 0 (length text) keywords))

keychords.lisp

@@ -0,0 +1,154 @@
+#|
+ This file is a part of markless-studio
+ (c) 2019 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
+ Author: Nicolas Hafner <shinmera@tymoon.eu>
+|#
+
+(in-package #:org.shirakumo.markless.studio)
+
+(defun parse-key (key)
+  (etypecase key
+    (character
+     (case key
+       (#\C :ctrl)
+       (#\M :meta)
+       (#\S :shift)
+       (#\A :alt)
+       (#\H :hyper)
+       (T key)))
+    (string
+     (cond ((string-equal key "ctrl") :ctrl)
+           ((string-equal key "meta") :meta)
+           ((string-equal key "shift") :shift)
+           ((string-equal key "alt") :alt)
+           ((string-equal key "hyper") :hyper)
+           ((string-equal key "super") :super)
+           ((string-equal key "spc") :space)
+           ((string-equal key "space") :space)
+           ((string-equal key "pgup") :pgup)
+           ((string-equal key "pgdn") :pgdn)
+           ((string-equal key "tab") :tab)
+           ((string-equal key "caps") :capslk)
+           ((string-equal key "capslk") :capslk)
+           ((string-equal key "esc") :escape)
+           ((string-equal key "escape") :escape)
+           ((string-equal key "ret") :return)
+           ((string-equal key "return") :return)
+           ((string-equal key "enter" :return))
+           (T (restart-case (progn (warn "Unknown key sequence ~s" key) :?)
+                (use-value (value)
+                  :report "Supply a key value."
+                  :interactive (lambda () (read *query-io*))
+                  value)))))))
+
+(defun print-key (key stream)
+  (case key
+    (:ctrl (write-char #\C stream))
+    (:meta (write-char #\M stream))
+    (:shift (write-char #\S stream))
+    (:alt (write-char #\A stream))
+    (:hyper (write-char #\H stream))
+    (#\C (write-string "\\C" stream))
+    (#\M (write-string "\\M" stream))
+    (#\S (write-string "\\S" stream))
+    (#\A (write-string "\\A" stream))
+    (#\H (write-string "\\H" stream))
+    (T (etypecase key
+         (keyword (format stream "<~(~a~)>" key))
+         (character (write-char key stream))))))
+
+(defun parse-keychord (chord)
+  (with-input-from-string (stream chord)
+    (let ((ast (make-array 0 :adjustable T :fill-pointer T))
+          (group ())
+          (buffer (make-string-output-stream)))
+      (flet ((commit-key (string)
+               (push (parse-key string) group))
+             (commit-group ()
+               (when group
+                 (vector-push-extend (nreverse group) ast)
+                 (setf group NIL))))
+        (loop for char = (read-char stream NIL)
+              while char
+              do (case char
+                   (#\<
+                    (loop for char = (read-char stream)
+                          until (char= char #\>)
+                          do (write-char char buffer))
+                    (commit-key (get-output-stream-string buffer)))
+                   (#\ 
+                    (commit-group))
+                   (#\-
+                    (commit-key (read-char stream)))
+                   (#\\
+                    (push (string (read-char stream)) group))
+                   (T
+                    (commit-group)
+                    (commit-key char))))
+        (commit-group)
+        ast))))
+
+(defun print-keychord (keychord stream)
+  (loop for i from 0 below (length keychord)
+        do (loop for (key . rest) on (aref keychord i)
+                 do (print-key key stream)
+                    (when rest (write-char #\- stream)))
+           (when (< (1+ i) (length keychord))
+             (write-char #\  stream))))
+
+(defclass keychord ()
+  ((keychord :initform #() :reader keychord)
+   (action :initarg :action :reader action)))
+
+(defmethod initialize-instance :after ((keychord keychord) &key chord)
+  (setf (slot-value keychord 'keychord) (etypecase chord
+                                          (string (parse-keychord chord))
+                                          (vector chord))))
+
+(defmethod print-object ((keychord keychord) stream)
+  (print-unreadable-object (keychord stream :type T)
+    (print-keychord (keychord keychord) stream)))
+
+(defun make-keychord (chord action)
+  (make-instance 'keychord :chord chord :action action))
+
+(defmethod process ((keychord keychord) pressed index dir)
+  (let* ((keychord (keychord keychord))
+         (group (aref keychord index)))
+    (flet ((advance ()
+             (cond ((<= (length keychord) (1+ index))
+                    (funcall (action keychord))
+                    0)
+                   (T
+                    (1+ index)))))
+      (if (rest group)
+          (if (and (eq :up dir)
+                   (loop for key in group
+                         always (find key pressed)))
+              (advance)
+              0)
+          (if (eq :dn dir)
+              (if (find (first group) pressed)
+                  (advance)
+                  0)
+              index)))))
+
+(defclass keychord-table ()
+  ((keychords :initarg :keychords :initform () :accessor keychords)
+   (pressed :initform () :accessor pressed)))
+
+(defmethod update ((table keychord-table) key dir)
+  (when (eq dir :dn)
+    (pushnew key (pressed table)))
+  (loop for cons in (keychords table)
+        for (index . keychord) = cons
+        do (setf (car cons) (process keychord (pressed table) index dir)))
+  (when (eq dir :up)
+    (setf (pressed table) (delete key (pressed table)))))
+
+(defmethod install ((keychord keychord) (table keychord-table))
+  ;; FIXME: check for collisions
+  (push (cons 0 keychord) (keychords table)))
+
+(defmethod uninstall ((keychord keychord) (table keychord-table))
+  (setf (keychords table) (delete keychord (keychords table) :key #'cdr)))

main.lisp

@@ -16,7 +16,14 @@
       (setf *error-format* format))))
 
 (define-widget main (QMainWindow)
-  ())
+  ((keytable :initform (make-instance 'keychord-table) :accessor keytable)))
+
+(define-initializer (main setup)
+  (q+:install-event-filter *qapplication* main)
+  (make-emacs-keytable main (keytable main)))
+
+(define-finalizer (main teardown)
+  (q+:remove-event-filter *qapplication* main))
 
 (define-subwidget (main split) (q+:make-qsplitter (q+:qt.horizontal) main)
   (setf (q+:central-widget main) split)
@@ -28,6 +35,9 @@
 (define-subwidget (main viewer) (make-instance 'viewer)
   (q+:add-widget split viewer))
 
+(define-subwidget (main status) (make-instance 'status)
+  (setf (q+:status-bar main) status))
+
 (define-slot (main update) ()
   (declare (connected editor (text-changed)))
   (multiple-value-bind (ast conditions) (parse-safely (q+:to-plain-text editor))
@@ -37,6 +47,36 @@
     (dolist (condition conditions)
       (markup-condition editor condition))))
 
+(define-override (main event-filter) (_ ev)
+  (declare (ignore _))
+  (qtenumcase (q+:type ev)
+    ((q+:qevent.key-press)
+     (let ((ev (cast "QKeyEvent" ev)))
+       (unless (q+:is-auto-repeat ev)
+         (update keytable (key-event->key ev) :dn))))
+    ((q+:qevent.key-release)
+     (let ((ev (cast "QKeyEvent" ev)))
+       (unless (q+:is-auto-repeat ev)
+         (update keytable (key-event->key ev) :up)))))
+  NIL)
+
+(defun key-event->key (ev)
+  (qtenumcase (q+:key ev)
+    ((q+:qt.key_escape) :escape)
+    ((q+:qt.key_tab) :tab)
+    ((q+:qt.key_backspace) :backspace)
+    ((q+:qt.key_return) :return)
+    ((q+:qt.key_enter) :return)
+    ((q+:qt.key_shift) :shift)
+    ((q+:qt.key_control) :control)
+    ((q+:qt.key_meta) :meta)
+    ((q+:qt.key_alt) :alt)
+    ((q+:qt.key_caps-lock) :capslk)
+    ((q+:qt.key_g) #\g)
+    (T (if (= 1 (length (q+:text ev)))
+           (char (q+:text ev) 0)
+           :?))))
+
 (defun parse-safely (text)
   (let ((conditions ()))
     (handler-case
@@ -48,19 +88,59 @@
         (push condition conditions)
         (values NIL (nreverse conditions))))))
 
-(define-menu (main file)
-  (:item ("&Open..." (ctrl o)))
-  (:item ("&Save" (ctrl s)))
-  (:item ("Save &As..." (ctrl alt s)))
+;; FIXME: this
+
+(defmethod open-mess ((main main) (target (eql NIL))))
+
+(defmethod open-mess ((main main) (target (eql T))))
+
+(defmethod open-mess ((main main) (pathname pathname)))
+
+(defmethod save-mess ((main main) (target (eql NIL))))
+
+(defmethod save-mess ((main main) (target (eql T))))
+
+(defmethod save-mess ((main main) (pathname pathname)))
+
+(defmethod export-mess ((main main) (profile (eql NIL))))
+
+(defmethod export-mess ((main main) (profile (eql T))))
+
+;;(defmethod export ((main main) (profile profile)))
+
+(define-menu (main file "&File")
+  (:item "&Open..."
+    (open-mess main NIL))
+  (:item "&Save"
+    (save-mess main T))
+  (:item "Save &As..."
+    (save-mess main NIL))
   (:separator)
-  (:item ("&Export" (ctrl e)))
-  (:item ("Export As..." (ctrl alt e)))
+  (:item "&Export"
+    (export-mess main T))
+  (:item "Export As..."
+    (export-mess main NIL))
   (:separator)
-  (:item ("&Quit" (ctrl q))
+  (:item "&Quit"
     (q+:close main)))
 
-(define-menu (main help)
-  (:item ("&About" (ctrl h))
+(define-menu (main edit "&Edit")
+  (:item "&Undo"
+    (q+:undo editor))
+  (:item "&Redo"
+    (q+:redo editor))
+  (:separator)
+  (:item "&Copy"
+    (q+:copy editor))
+  (:item "Cu&t"
+    (q+:cut editor))
+  (:item "&Paste"
+    (q+:paste editor))
+  (:separator)
+  (:item "&Settings"))
+
+(define-menu (main help "&Help")
+  (:item "&About"
     (let ((studio (asdf:find-system :markless-studio))
           (implementation (asdf:find-system :cl-markless)))
       (with-finalizing ((box (q+:make-qmessagebox main)))
@@ -84,3 +164,21 @@ Lisp Implementation: ~a ~a"
                                     (lisp-implementation-type)
                                     (lisp-implementation-version)))
         (#_exec box)))))
+
+(defun make-emacs-keytable (main &optional (table (make-instance 'keychord-table)))
+  (with-slots-bound (main main)
+    (macrolet ((def (chord &body body)
+                 `(install (make-keychord ,chord (lambda () ,@body)) table)))
+      (def "C-g" (message status "Abort."))
+      (def "C-x C-f" (open-mess main NIL))
+      (def "C-x C-s" (save-mess main T))
+      (def "C-x C-w" (save-mess main NIL))
+      (def "C-x C-c" (q+:close main))
+      (def "C-_" (q+:undo editor))
+      (def "M-:" (prompt status (lambda (string)
+                                  (eval (read-from-string string)))
+                         "Eval:"))
+      (def "C-y" (q+:paste editor))
+      (def "C-w" (q+:cut editor))
+      (def "M-w" (q+:copy editor))
+      )))

markless-studio.asd

@@ -15,8 +15,10 @@
   :source-control (:git "https://github.com/Shinmera/markless-studio.git")
   :serial T
   :components ((:file "package")
+               (:file "keychords")
                (:file "viewer")
                (:file "editor")
+               (:file "status")
                (:file "main"))
   :depends-on (:qtools
                :qtcore

status.lisp

@@ -0,0 +1,35 @@
+#|
+ This file is a part of markless-studio
+ (c) 2019 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
+ Author: Nicolas Hafner <shinmera@tymoon.eu>
+|#
+
+(in-package #:org.shirakumo.markless.studio)
+(in-readtable :qtools)
+
+(define-widget status (QStatusBar)
+  ((action :initform NIL :accessor action)))
+
+(define-subwidget (status input) (q+:make-qlineedit status)
+  (q+:hide input))
+
+(define-slot (status input-done) ()
+  (declare (connected input (return-pressed)))
+  (let ((text (q+:text input)))
+    (q+:clear input)
+    (when action
+      (funcall action text)
+      (setf (action status) NIL))))
+
+(defmethod (setf action) ((null null) (status status))
+  (q+:clear (slot-value status 'input))
+  (q+:remove-widget status (slot-value status 'input)))
+
+(defmethod (setf action) :after (action (status status))
+  (q+:add-widget status (slot-value status 'input) 1))
+
+(defmethod message ((status status) control &rest args)
+  (q+:show-message status (apply #'format NIL control args)))
+
+(defmethod prompt ((status status) action control &rest args)
+  (setf (action status) action))