From: plugd <plugd@thelambdalab.xyz>
Date: Sat, 10 Jul 2021 08:54:12 +0000 (+0200)
Subject: Added basic formatting code support.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=b48c2617b0dace85c5a16dcd8fe081c336878d0c;p=lurk.git

Added basic formatting code support.
---

diff --git a/lurk.el b/lurk.el
index 2f7e15a..e2d175e 100644
--- a/lurk.el
+++ b/lurk.el
@@ -1,4 +1,4 @@
-;;; lurk.el --- Little Uni-buffer iRc Klient -*- lexical-binding:t -*-
+;;; lurk.el --- Little Unibuffer iRc Klient -*- lexical-binding:t -*-
 
 ;; Copyright (C) 2021 Tim Vaughan
 
@@ -35,7 +35,7 @@
 ;;
 
 (defgroup lurk nil
-  "Little Uni-buffer iRc Klient."
+  "Little Unibuffer iRc Klient."
   :group 'network)
 
 (defcustom lurk-nick "plugd"
@@ -404,11 +404,11 @@ portion of the source component of the message, as LURK doesn't use this.")
 ;;; Output formatting and highlighting
 ;;
 
-;; Partially-implemented idea: the face text property can be
-;; a list of faces, applied in order.  By assigning each context
-;; a unique list and keeping track of these in a hash table, we can
-;; easily switch the face corresponding to a particular context
-;; by modifying the elements of this list.
+;; Idea: the face text property can be a list of faces, applied in
+;; order.  By assigning each context a unique list and keeping track
+;; of these in a hash table, we can easily switch the face
+;; corresponding to a particular context by modifying the elements of
+;; this list.
 ;;
 ;; More subtly, we make only the cdrs of this list shared among
 ;; all text of a given context, allowing the cars to be different
@@ -460,11 +460,12 @@ portion of the source component of the message, as LURK doesn't use this.")
                       'read-only t
                       'context context
                       'invisible context-atom)
-          (propertize (concat (lurk-buttonify-urls (apply #'concat strings)) "\n")
-                      'face (lurk-get-context-facelist context)
-                      'read-only t
-                      'context context
-                      'invisible context-atom)))))))
+          (lurk-add-formatting
+           (propertize (concat (apply #'lurk-buttonify-urls strings) "\n")
+                       'face (lurk-get-context-facelist context)
+                       'read-only t
+                       'context context
+                       'invisible context-atom))))))))
 
 (defun lurk-display-message (from to text)
   (let ((context (if (eq 'channel (lurk-get-context-type to))
@@ -543,17 +544,17 @@ portion of the source component of the message, as LURK doesn't use this.")
        (opt (group (: ":" (+ digit))))
        (opt (group (: "/"
                       (opt
-                       (* (any alnum "-/.,#:%=&_?~"))
-                       (any alnum "-/#:%=&_~")))))))
+                       (* (any alnum "-/.,#:%=&_?~@"))
+                       (any alnum "-/#:%=&_~@")))))))
   "Imperfect regex used to find URLs in plain text.")
 
 (defun lurk-click-url (button)
   (browse-url (button-get button 'url)))
 
-(defun lurk-buttonify-urls (string)
+(defun lurk-buttonify-urls (&rest strings)
   "Turn substrings which look like urls in STRING into clickable buttons."
   (with-temp-buffer
-    (insert string)
+    (apply #'insert strings)
     (goto-char (point-min))
     (while (re-search-forward lurk-url-regex nil t)
       (let ((url (match-string 0)))
@@ -566,6 +567,34 @@ portion of the source component of the message, as LURK doesn't use this.")
                           'help-echo "Open URL in browser.")))
     (buffer-string)))
 
+(defun lurk-add-formatting (string)
+  (with-temp-buffer
+    (insert string)
+    (goto-char (point-min))
+    (let ((bold nil)
+          (italics nil)
+          (underline nil)
+          (strikethrough nil)
+          (prev-point (point)))
+      (while (re-search-forward (rx (any "\x02\x1D\x1F\x1E")) nil t)
+        (let ((beg (+ (match-beginning 0) 1)))
+          (if bold
+              (add-face-text-property prev-point beg '(:weight bold)))
+          (if italics
+              (add-face-text-property prev-point beg '(:slant italic)))
+          (if underline
+              (add-face-text-property prev-point beg '(:underline t)))
+          (if strikethrough
+              (add-face-text-property prev-point beg '(:strike-through t)))
+          (pcase (match-string 0)
+            ("\x02" (setq bold (not bold)))
+            ("\x1D" (setq italics (not italics)))
+            ("\x1F" (setq underline (not underline)))
+            ("\x1E" (setq strikethrough (not strikethrough))))
+          (delete-region (match-beginning 0) (match-end 0))
+          (setq prev-point (point)))))
+    (buffer-string)))
+
 
 ;;; Message evaluation
 ;;