+(defun murk-connect (network)
+ (if (assoc network murk-connection-table)
+ (murk-display-error "Already connected to this network")
+ (if (not (assoc network murk-networks))
+ (murk-display-error "Network '" network "' is unknown.")
+ (let ((proc (murk-start-process network)))
+ (murk-connection-new network proc murk-default-nick))
+ (murk-send-msg network (murk-msg nil nil "USER" murk-default-nick 0 "*" murk-default-nick))
+ (murk-send-msg network (murk-msg nil nil "NICK" murk-default-nick))
+ (murk-add-context (list network))
+ (murk-highlight-current-context)
+ (murk-render-prompt))))
+
+(defun murk-send-msg (network msg)
+ (if murk-debug
+ (murk-display-string nil nil (murk-msg->string msg)))
+ (let ((proc (murk-connection-process network)))
+ (if (and proc (eq (process-status proc) 'open))
+ (process-send-string proc (concat (murk-msg->string msg) "\r\n"))
+ (murk-display-error "No network connection established"))))
+
+
+;;; network messages
+;;
+
+(defun murk-msg (tags src cmd &rest params)
+ (list (murk--as-string tags)
+ (murk--as-string src)
+ (upcase (murk--as-string cmd))
+ (mapcar #'murk--as-string
+ (if (and params (listp (elt params 0)))
+ (elt params 0)
+ params))))
+
+(defun murk-msg-tags (msg) (elt msg 0))
+(defun murk-msg-src (msg) (elt msg 1))
+(defun murk-msg-cmd (msg) (elt msg 2))
+(defun murk-msg-params (msg) (elt msg 3))
+(defun murk-msg-trail (msg)
+ (let ((params (murk-msg-params msg)))
+ (if params
+ (elt params (- (length params) 1)))))
+
+(defvar murk-msg-regex
+ (rx
+ (opt (: "@" (group (* (not (or "\n" "\r" ";" " ")))))
+ (* whitespace))
+ (opt (: ":" (: (group (* (not (any space "!" "@"))))
+ (* (not (any space)))))
+ (* whitespace))
+ (group (: (* (not whitespace))))
+ (* whitespace)
+ (opt (group (+ not-newline))))
+ "Regex used to parse IRC messages.
+Note that this regex is incomplete. Noteably, we discard the non-nick
+portion of the source component of the message, as mURK doesn't use this.")
+
+(defun murk-string->msg (string)
+ (if (string-match murk-msg-regex string)
+ (let* ((tags (match-string 1 string))
+ (src (match-string 2 string))
+ (cmd (upcase (match-string 3 string)))
+ (params-str (match-string 4 string))
+ (params
+ (if params-str
+ (let* ((idx (seq-position params-str ?:))
+ (l (split-string (string-trim (substring params-str 0 idx))))
+ (r (if idx (list (substring params-str (+ 1 idx))) nil)))
+ (append l r))
+ nil)))
+ (apply #'murk-msg (append (list tags src cmd) params)))
+ (error "Failed to parse string %s" string)))
+
+(defun murk-msg->string (msg)
+ (let ((tags (murk-msg-tags msg))
+ (src (murk-msg-src msg))
+ (cmd (murk-msg-cmd msg))
+ (params (murk-msg-params msg)))
+ (murk--filtered-join
+ (if tags (concat "@" tags) nil)
+ (if src (concat ":" src) nil)
+ cmd
+ (if (> (length params) 1)
+ (string-join (seq-take params (- (length params) 1)) " ")
+ nil)
+ (if (> (length params) 0)
+ (concat ":" (elt params (- (length params) 1)))
+ nil))))
+
+
+;;; Contexts
+;;
+
+;; A context is a list (network channel users) identifying the network
+;; and channel. The tail of the list contains the nicks of users
+;; present in the channel.
+;;
+;; Each network has a special context (network) used for messages
+;; to/from the network itself.
+
+(defvar murk-contexts nil
+ "List of currently-available contexts.
+The head of this list is always the current context.")
+
+(defun murk-current-context ()
+ "Return the current context."
+ (if murk-contexts
+ (car murk-contexts)
+ nil))
+
+(defun murk-contexts-equal (c1 c2)
+ (if (murk-network-context-p c1)
+ (and (murk-network-context-p c2)
+ (equal (murk-context-network c1)
+ (murk-context-network c2)))
+ (and (not (murk-network-context-p c2))
+ (equal (seq-take c1 2)
+ (seq-take c2 2)))))
+
+(defun murk-context-network (ctx)
+ (elt ctx 0))
+
+(defun murk-context-channel (ctx)
+ (elt ctx 1))
+
+(defun murk-context-users (ctx)
+ (elt ctx 2))
+
+(defun murk-set-context-users (ctx users)
+ (setcar (cddr ctx) users))
+
+(defun murk-network-context-p (ctx)
+ (not (cdr ctx)))
+
+(defun murk-add-context (ctx)
+ (add-to-list 'murk-contexts ctx))
+
+(defun murk-remove-context (ctx)
+ (setq murk-contexts
+ (seq-remove
+ (lambda (this-ctx)
+ (murk-contexts-equal this-ctx ctx))
+ murk-contexts)))
+
+(defun murk-remove-network-contexts (network)
+ (setq murk-contexts
+ (seq-remove (lambda (row) (equal (car row) network))
+ murk-contexts)))
+
+(defun murk-context->string (ctx)
+ (if (murk-network-context-p ctx)
+ (concat "[" (murk-context-network ctx) "]")
+ (concat (murk-context-channel ctx) "@"
+ (murk-context-network ctx))))
+
+(defun murk-string->context (string)
+ (if (not (string-prefix-p "#" string))
+ (murk-get-context string)
+ (let* ((parts (string-split string "@"))
+ (channel (elt parts 0))
+ (network (elt parts 1)))
+ (murk-get-context network channel))))
+
+(defun murk-get-context (network &optional channel)
+ (if (and channel (string-prefix-p "#" channel))
+ (let ((test-ctx (list network channel)))
+ (seq-find (lambda (ctx)
+ (equal (seq-take ctx 2) test-ctx))
+ murk-contexts))
+ (car (member (list network) murk-contexts))))
+
+(defun murk-cycle-contexts (&optional reverse)
+ (setq murk-contexts
+ (if reverse
+ (let ((nminus1 (- (length murk-contexts) 1)))
+ (cons
+ (elt murk-contexts nminus1)
+ (seq-take murk-contexts nminus1)))
+ (append (cdr murk-contexts) (list (car murk-contexts))))))
+
+(defun murk-switch-to-context (ctx)
+ (setq murk-contexts
+ (let* ((new-head (memq ctx murk-contexts))
+ (new-tail (take (- (length murk-contexts)
+ (length new-head)))))
+ (append new-head new-tail))))
+
+(defun murk-add-context-users (ctx users)
+ (murk-set-context-users
+ ctx
+ (cl-union users (murk-context-users ctx))))
+
+(defun murk-del-context-user (ctx user)
+ (murk-set-context-users
+ ctx
+ (delete user (murk-context-users ctx))))
+
+(defun murk-del-network-user (network user)
+ (dolist (ctx murk-contexts)
+ (if (and (equal (murk-context-network ctx) network)
+ (not (murk-network-context-p ctx)))
+ (murk-del-context-user ctx user))))
+
+(defun murk-rename-network-user (network old-nick new-nick)
+ (dolist (ctx murk-contexts)
+ (when (and (equal (murk-context-network ctx) network)
+ (member old-nick (murk-context-users ctx)))
+ (murk-del-context-user ctx old-nick)
+ (murk-add-context-users ctx (list new-nick)))))
+
+;;; Buffer
+;;
+
+(defvar murk-prompt-marker nil
+ "Marker for prompt position in murk buffer.")
+
+(defvar murk-input-marker nil
+ "Marker for prompt position in murk buffer.")
+
+(defun murk-render-prompt ()
+ (with-current-buffer "*murk*"
+ (let ((update-point (= murk-input-marker (point)))
+ (update-window-points (mapcar (lambda (w)
+ (list (= (window-point w) murk-input-marker)
+ w))
+ (get-buffer-window-list nil nil t))))
+ (save-excursion
+ (set-marker-insertion-type murk-prompt-marker nil)
+ (set-marker-insertion-type murk-input-marker t)
+ (let ((inhibit-read-only t))
+ (delete-region murk-prompt-marker murk-input-marker)
+ (goto-char murk-prompt-marker)
+ (insert
+ (propertize (let ((ctx (murk-current-context)))
+ (if ctx
+ (murk-context->string ctx)
+ ""))
+ 'face 'murk-context
+ 'read-only t)
+ (propertize murk-prompt-string
+ 'face 'murk-prompt
+ 'read-only t)
+ (propertize " " ; Need this to be separate to mark it as rear-nonsticky
+ 'read-only t
+ 'rear-nonsticky t)))
+ (set-marker-insertion-type murk-input-marker nil))
+ (if update-point
+ (goto-char murk-input-marker))
+ (dolist (v update-window-points)
+ (if (car v)
+ (set-window-point (cadr v) murk-input-marker))))))
+
+(defun murk-setup-header ()
+ (with-current-buffer "*murk*"
+ (setq-local header-line-format
+ '((:eval
+ (let* ((ctx (murk-current-context)))
+ (if ctx
+ (let ((network (murk-context-network ctx)))
+ (concat
+ "Network: " network ", "
+ (if (murk-network-context-p ctx)
+ "network"
+ (concat
+ "Channel: "
+ (murk-context-channel ctx)
+ " ("
+ (number-to-string
+ (length (murk-context-users ctx)))
+ ")"))))
+ "No connection")))))))
+
+(defun murk-setup-buffer ()
+ (with-current-buffer (get-buffer-create "*murk*")
+ (setq-local scroll-conservatively 1)
+ (setq-local buffer-invisibility-spec nil)
+ (if (markerp murk-prompt-marker)
+ (set-marker murk-prompt-marker (point-max))
+ (setq murk-prompt-marker (point-max-marker)))
+ (if (markerp murk-input-marker)
+ (set-marker murk-input-marker (point-max))
+ (setq murk-input-marker (point-max-marker)))
+ (goto-char (point-max))
+ (murk-highlight-current-context)
+ (murk-render-prompt)
+ (if murk-display-header
+ (murk-setup-header))))
+
+(defun murk-clear-buffer ()
+ "Completely erase all non-prompt and non-input text from murk buffer."
+ (with-current-buffer "*murk*"
+ (let ((inhibit-read-only t))
+ (delete-region (point-min) murk-prompt-marker))))
+
+
+;;; Output formatting and highlighting
+;;
+
+;; 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
+;; and for different elements of the context-specific text to have
+;; different styling.
+
+;; Additionally, we allow selective hiding of contexts via
+;; the buffer-invisibility-spec.
+
+(defvar murk-context-facelists (make-hash-table :test 'equal)
+ "List of seen contexts and associated face lists.")
+
+(defun murk-get-context-facelist (context)
+ (let* ((short-ctx (take 2 context))
+ (facelist (gethash short-ctx murk-context-facelists)))
+ (unless facelist
+ (setq facelist (list 'murk-text))
+ (puthash short-ctx facelist murk-context-facelists))
+ facelist))
+
+(defun murk--fill-strings (col indent &rest strings)
+ (with-temp-buffer
+ (setq buffer-invisibility-spec nil)
+ (let ((fill-column col)
+ (adaptive-fill-regexp (rx-to-string `(= ,indent anychar))))
+ (apply #'insert strings)
+ (fill-region (point-min) (point-max) nil t)
+ (buffer-string))))
+
+(defun murk-display-string (context prefix &rest strings)
+ (with-current-buffer "*murk*"
+ (save-excursion
+ (goto-char murk-prompt-marker)
+ (let* ((inhibit-read-only t)
+ (old-pos (marker-position murk-prompt-marker))
+ (padded-timestamp (concat (format-time-string "%H:%M ")))
+ (padded-prefix (if prefix (concat prefix " ") ""))
+ (short-ctx (take 2 context))
+ (context-atom (if short-ctx
+ (intern (murk-context->string short-ctx))
+ nil))
+ (context-face (murk-get-context-facelist short-ctx)))
+ (insert-before-markers
+ (murk--fill-strings
+ 80
+ (+ (length padded-timestamp)
+ (length padded-prefix))
+ (propertize padded-timestamp
+ 'face 'murk-timestamp
+ 'read-only t
+ 'context short-ctx
+ 'invisible context-atom)
+ (propertize padded-prefix
+ 'read-only t
+ 'context short-ctx
+ 'invisible context-atom)
+ (murk-add-formatting
+ (propertize (concat (apply #'murk-buttonify-urls strings) "\n")
+ 'face context-face
+ 'read-only t
+ 'context short-ctx
+ 'invisible context-atom)))))))
+ (murk-scroll-windows-to-last-line))
+
+(defun murk-display-message (network from to text)
+ (let ((context (if (string-prefix-p "#" to)
+ (murk-get-context network to)
+ (murk-get-context network))))
+ (murk-display-string
+ context
+ (propertize
+ (if (murk-network-context-p context)
+ (concat "[" from "->" to "]")
+ (concat (murk-context->string context) " <" from ">"))
+ 'face (murk-get-context-facelist context))
+ text)))
+
+(defun murk-display-action (network from to action-text)
+ (let ((context (if (string-prefix-p "#" to)
+ (murk-get-context network to)
+ (murk-get-context network))))
+ (murk-display-string
+ context
+ (propertize
+ (concat (murk-context->string context) " *")
+ 'face (murk-get-context-facelist context))
+ from " " action-text)))
+
+(defun murk-display-notice (context &rest notices)
+ (murk-display-string
+ context
+ (propertize murk-notice-prefix 'face 'murk-notice)
+ (apply #'concat notices)))
+
+(defun murk-display-error (&rest messages)
+ (murk-display-string
+ nil
+ (propertize murk-error-prefix 'face 'murk-error)
+ (apply #'concat messages)))
+
+(defun murk-highlight-current-context ()
+ (maphash
+ (lambda (this-context facelist)
+ (if (equal (take 2 this-context) (take 2 (murk-current-context)))
+ (setcar facelist 'murk-text)
+ (setcar facelist 'murk-faded)))
+ murk-context-facelists)
+ (force-window-update "*murk*"))
+
+(defun murk-zoom-in (context)
+ (with-current-buffer "*murk*"
+ (maphash
+ (lambda (this-context _)
+ (when this-context
+ (let ((this-context-atom
+ (intern (murk-context->string this-context))))
+ (if (equal this-context (take 2 context))
+ (remove-from-invisibility-spec this-context-atom)
+ (add-to-invisibility-spec this-context-atom)))))
+ murk-context-facelists)
+ (force-window-update "*murk*"))
+ (murk-scroll-windows-to-last-line))
+
+(defun murk-zoom-out ()
+ (with-current-buffer "*murk*"
+ (maphash
+ (lambda (this-context _)
+ (let ((this-context-atom
+ (if this-context
+ (intern (murk-context->string this-context))
+ nil)))
+ (remove-from-invisibility-spec this-context-atom)))
+ murk-context-facelists)
+ (force-window-update "*murk*"))
+ (murk-scroll-windows-to-last-line))