Basic context highlighting and zooming implemented.

diff --git a/lurk.el b/lurk.el
index fb83892..347258e 100644 (file)
--- a/lurk.el
+++ b/lurk.el
@@ -65,10 +65,6 @@
   '((t :inherit font-lock-preprocessor-face))
   "Face used for Lurk text.")
 
   '((t :inherit font-lock-preprocessor-face))
   "Face used for Lurk text.")
 

-(defface lurk-your-nick
-  '((t :inherit font-lock-constant-face))
-  "Face used for highlighting your nick.")
-

 (defface lurk-prompt
   '((t :inherit org-level-2))
   "Face used for the prompt.")
 (defface lurk-prompt
   '((t :inherit org-level-2))
   "Face used for the prompt.")


@@ -94,17 +90,9 @@
 
 (defvar lurk-version "Lurk v0.1")
 
 
 (defvar lurk-version "Lurk v0.1")
 

-(defvar lurk-notice-prefix
-  (concat
-   (propertize
-    "-" 'face 'lurk-faded)
-   (propertize
-    "!" 'face 'lurk-bold)
-   (propertize
-    "-" 'face 'lurk-faded)))
+(defvar lurk-notice-prefix "-!-")

 
 

-(defvar lurk-error-prefix
-  (propertize "!!!" 'face 'lurk-error))
+(defvar lurk-error-prefix "!!!")

 
 (defvar lurk-prompt-string
   (propertize "> " 'face 'lurk-prompt))
 
 (defvar lurk-prompt-string
   (propertize "> " 'face 'lurk-prompt))


@@ -324,11 +312,13 @@ portion of the source component of the message, as LURK doesn't use this.")
 
 (defun lurk-cycle-contexts-forward ()
   (interactive)
 
 (defun lurk-cycle-contexts-forward ()
   (interactive)

-  (lurk-cycle-contexts))
+  (lurk-cycle-contexts)
+  (lurk-highlight-context lurk-current-context))

 
 (defun lurk-cycle-contexts-reverse ()
   (interactive)
 
 (defun lurk-cycle-contexts-reverse ()
   (interactive)

-  (lurk-cycle-contexts t))
+  (lurk-cycle-contexts t)
+  (lurk-highlight-context lurk-current-context))

 
 
 ;;; Buffer
 
 
 ;;; Buffer


@@ -382,7 +372,7 @@ portion of the source component of the message, as LURK doesn't use this.")
     (lurk-render-prompt)))
 
 
     (lurk-render-prompt)))
 
 

-;;; Output formatting
+;;; Output formatting and highlighting

 ;;
 
 ;; Partially-implemented idea: the face text property can be
 ;;
 
 ;; Partially-implemented idea: the face text property can be


@@ -396,6 +386,9 @@ portion of the source component of the message, as LURK doesn't use this.")
 ;; and for different elements of the context-specific text to have
 ;; different styling.
 
 ;; and for different elements of the context-specific text to have
 ;; different styling.
 

+;; Additionally, we can allow selective hiding of contexts via
+;; the buffer-invisibility-spec.
+

 (defvar lurk-context-facelists (make-hash-table :test 'equal)
   "List of seen contexts and associated face lists.")
 
 (defvar lurk-context-facelists (make-hash-table :test 'equal)
   "List of seen contexts and associated face lists.")
 


@@ -406,20 +399,28 @@ portion of the source component of the message, as LURK doesn't use this.")
       (puthash context facelist lurk-context-facelists))
     facelist))
 
       (puthash context facelist lurk-context-facelists))
     facelist))
 

-(defun lurk-display-string (&rest strings)
+(defun lurk-display-string (context &rest strings)

   (with-current-buffer (get-buffer-create "*lurk*")
     (save-excursion
       (goto-char lurk-prompt-marker)
       (let ((inhibit-read-only t)
             (old-pos (marker-position lurk-prompt-marker))
             (adaptive-fill-regexp (rx (= 6 anychar)))
   (with-current-buffer (get-buffer-create "*lurk*")
     (save-excursion
       (goto-char lurk-prompt-marker)
       (let ((inhibit-read-only t)
             (old-pos (marker-position lurk-prompt-marker))
             (adaptive-fill-regexp (rx (= 6 anychar)))

-            (fill-column 80))
+            (fill-column 80)
+            (context-atom (if context (intern context) nil)))

         (insert-before-markers
          (propertize (concat (format-time-string "%H:%M") " ")
         (insert-before-markers
          (propertize (concat (format-time-string "%H:%M") " ")

-                     'face 'lurk-text
-                     'read-only t)
+                     'face (lurk-get-context-facelist context)
+                     'read-only t
+                     'context context
+                     'invisible context-atom
+                     'help-echo (concat "Context: " (or context "none")))

          (propertize (concat (apply #'concat strings) "\n")
          (propertize (concat (apply #'concat strings) "\n")

-                     'read-only t))
+                     'face (lurk-get-context-facelist context)
+                     'read-only t
+                     'context context
+                     'invisible context-atom
+                     'help-echo (concat "Context: " (or context "none"))))

         (fill-region old-pos lurk-prompt-marker nil t)))))
 
 (defun lurk-display-message (from to text)
         (fill-region old-pos lurk-prompt-marker nil t)))))
 
 (defun lurk-display-message (from to text)


@@ -427,53 +428,59 @@ portion of the source component of the message, as LURK doesn't use this.")
                      to
                    (if (equal to lurk-nick) from to))))
     (lurk-display-string
                      to
                    (if (equal to lurk-nick) from to))))
     (lurk-display-string

-     (propertize
-      (pcase (lurk-get-context-type to)
-        ('channel (concat to " <" from "> " text))
-        ('nick (concat "[" from " -> " to "] " text))
-        (_
-         (error "Unsupported context type")))
-      'face (lurk-get-context-facelist context)
-      'help-echo (concat "Context: " context)
-      'context context))))
+     context
+     (pcase (lurk-get-context-type to)
+       ('channel (concat to " <" from "> " text))
+       ('nick (concat "[" from " -> " to "] " text))
+       (_
+        (error "Unsupported context type"))))))

 
 (defun lurk-display-notice (context &rest notices)
   (lurk-display-string
 
 (defun lurk-display-notice (context &rest notices)
   (lurk-display-string

-   (propertize
-    (concat lurk-notice-prefix " " (apply #'concat notices))
-    'help-echo (concat "Context: " (or context "none"))
-    'context context)))
+   context
+   lurk-notice-prefix " "
+   (apply #'concat notices)))

 
 (defun lurk-display-error (&rest messages)
   (lurk-display-string
 
 (defun lurk-display-error (&rest messages)
   (lurk-display-string

-   (concat lurk-error-prefix " "
-           (propertize (apply #'concat messages)
-                       'face 'lurk-error))))
+   nil
+   lurk-error-prefix " "
+   (apply #'concat messages)))

 
 (defun lurk-highlight-context (context)
 
 (defun lurk-highlight-context (context)

+  (maphash
+   (lambda (this-context facelist)
+     (if (equal this-context context)
+         (setcar facelist 'lurk-bold)
+       (setcar facelist 'lurk-faded)))
+   lurk-context-facelists)
+  (force-window-update "*lurk*"))
+
+(defun lurk-zoom-in (context)
+  (with-current-buffer "*lurk*"
+    (maphash
+     (lambda (this-context _)
+       (let ((this-context-atom (if this-context (intern this-context) nil)))
+         (if (equal this-context context)
+             (remove-from-invisibility-spec this-context-atom)
+           (add-to-invisibility-spec this-context-atom))))
+     lurk-context-facelists)
+    (force-window-update "*lurk*")))
+
+(defun lurk-zoom-out ()

   (with-current-buffer "*lurk*"
   (with-current-buffer "*lurk*"

-    (let* ((pos lurk-prompt-marker)
-           (nextpos (previous-single-property-change pos 'context))
-           (inhibit-read-only t))
-      (while (> pos nextpos)
-        (let ((thiscontext (get-text-property nextpos 'context)))
-          (if thiscontext
-              (if (equal context thiscontext)
-                  (add-text-properties nextpos pos
-                                       '(face (foreground-color . "green")))
-                (add-text-properties nextpos pos
-                                     '(face (foreground-color . "blue"))))
-            (add-text-properties nextpos pos
-                                 '(face lurk-text)))
-          thiscontext
-          (setq pos nextpos)
-          (setq nextpos (previous-single-property-change pos 'context nil 1)))))))
+    (maphash
+     (lambda (this-context _)
+       (let ((this-context-atom (if this-context (intern this-context) nil)))
+         (remove-from-invisibility-spec this-context-atom)))
+     lurk-context-facelists)
+    (force-window-update "*lurk*")))

 
 ;;; Message evaluation
 ;;
 
 (defun lurk-eval-msg-string (string)
 
 ;;; Message evaluation
 ;;
 
 (defun lurk-eval-msg-string (string)

-  ;; (lurk-display-string string)
+  ;; (lurk-display-string nil string)

   (let* ((msg (lurk-string->msg string)))
     ;; (message (pp msg))
     (pcase (lurk-msg-cmd msg)
   (let* ((msg (lurk-string->msg string)))
     ;; (message (pp msg))
     (pcase (lurk-msg-cmd msg)


@@ -592,6 +599,10 @@ portion of the source component of the message, as LURK doesn't use this.")
             (lurk-display-notice "CTCP userinfo request from " from " (no response sent)"))
 
            (_
             (lurk-display-notice "CTCP userinfo request from " from " (no response sent)"))
 
            (_

+            (if (and (equal from "BitBot")
+                     (equal to "##moshpit")
+                     (cl-search "\\_o< QUACK!" text))
+              (lurk-send-msg (lurk-msg nil nil "PRIVMSG" to ",bef")))

             (lurk-display-message from to text)))))
       (_
        (lurk-display-notice nil (lurk-msg->string msg))))))
             (lurk-display-message from to text)))))
       (_
        (lurk-display-notice nil (lurk-msg->string msg))))))