Index: sbbs.el
==================================================================
--- sbbs.el
+++ sbbs.el
@@ -24,10 +24,11 @@
 
 (require 'tabulated-list)
 (require 'button)
 (require 'url)
 (require 'hl-line)
+(require 'rx)
 
  ;; CUSTOMIZABLE DATA
 
 (defgroup sbbs nil
   "SchemeBBS client."
@@ -38,10 +39,14 @@
   '(("textboard.org" ("sol" "prog") nil))
   "List of SchemeBBS sites and boards."
   :type '(repeat (list (string :tag "Board Domain")
                        (repeat (string :tag "Board Name"))
                        (boolean :tag "Use TLS?"))))
+
+(defcustom sbbs-jump-to-link t
+  "Jump to first link after narrowing posts."
+  :type 'boolean)
 
 (defface sbbs--spoiler-face
   '((((background light)) :background "black" :foreground "black")
     (((background dark)) :background "white" :foreground "white"))
   "Face for spoiler text in threads.")
@@ -60,10 +65,13 @@
 
 (defvar-local sbbs--thread-id nil
   "Buffer local reference to current thread id.
 
 Used in thread and reply buffers.")
+
+(defvar-local sbbs--limit-stack nil
+  "Stack of last limit specs.")
 
  ;; BOARD OBJECT AND FUNCTIONS
 
 (defun sbbs-make-board (domain name &optional tls)
   "Create board object, using DOMAIN, NAME and TLS flag."
@@ -90,22 +98,31 @@
             (sbbs--board-protocol board)
             (sbbs--board-domain board)
             (if api-p "sexp/" "")
             (sbbs--board-name board)
             (or path ""))))
+
+(defun sbbs--list-boards ()
+  (let (boards)
+    (dolist (ent sbbs-boards)
+      (dolist (board (cadr ent))
+        (push (sbbs-make-board (car ent) board (caddr ent))
+              boards)))
+    boards))
 
 (defun sbbs-read-board ()
   "Read in a board using `completing-read'.
 
 The list will be generated using `sbbs-boards', and the result
 will be a board object generated with `sbbs-make-board'."
   (let (boards)
-    (dolist (ent sbbs-boards)
-      (dolist (board (cadr ent))
-        (push (cons (format "/%s/ (%s)" board (car ent))
-                    (sbbs-make-board (car ent) board (caddr ent)))
-              boards)))
+    (dolist (b (sbbs--list-boards))
+      (push (cons (format "/%s/ (%s)"
+                          (sbbs--board-name b)
+                          (sbbs--board-domain b))
+                  b)
+            boards))
     (cdr (assoc (completing-read "Board: " boards nil t) boards))))
 
  ;; UTILITY FUNCTIONS
 
 (defun sbbs--reload-thread (&optional _ignore-auto _noconfirm)
@@ -116,51 +133,125 @@
   "Function to regenerate thread index.
 
 Called by `tabulated-list-mode' hooks."
   (when sbbs--board (sbbs-browse sbbs--board t)))
 
+(defun sbbs--parse-number-range (desc limit)
+  "Generate list of numbers, as specified by DESC.
+
+To avoid memory overflows, limit number of entries to LIMIT."
+  (save-match-data
+    (apply #'nconc
+		   (mapcar
+		    (lambda (range)
+			  (cond ((string-match "\\`\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\'" range)
+				     (number-sequence (string-to-number (match-string 1 range))
+                                      (min limit (string-to-number (match-string 2 range)))))
+				    ((string-match "\\`\\([[:digit:]]+\\)\\'" range)
+				     (list (string-to-number (match-string 1 range))))
+				    (t (error "invalid range"))))
+		    (split-string desc ",")))))
+
+(defun sbbs--read-jump-to (nr)
+  "Set point to first character of post with number NR."
+  (let ((up (point-min)) (down (point-max)) current)
+    (while (progn
+             (goto-char (+ up (/ (- down up) 2)))
+             (setq current (get-text-property (point) 'sbbs-thread-nr))
+             (/= nr current))
+      (cond ((< nr current) (setq down (point)))
+            ((> nr current) (setq up (point))))))
+  (unless (and (eq 'highlight (get-text-property (point) 'face))
+               (looking-at-p "\\`#[[:digit:]]+"))
+    ;; in case we are on the first character of a post, we shouldn't
+    ;; jump back, since that would mean setting to point to NR-1.
+    (sbbs-read-previous 1)))
+
  ;; UI GENERATOR
 
+(defconst sbbs--link-regexp
+  (rx-to-string
+   `(: bos
+       (or (: "/" (group-n 2 (+ alnum))
+              "/" (group-n 3 (+ digit))
+              "/" (group-n 4 (: (+ digit) (? "-" (+ digit)))
+                           (* "," (+ digit) (? "-" (+ digit)))))
+           (: "http" (? "s") "://"
+              (group-n 1 (or ,@(mapcar #'sbbs--board-domain
+                                       (sbbs--list-boards))))
+              "/" (group-n 2 (+ alnum))
+              "/" (group-n 3 (+ digit))
+              (? "#t" (backref 3)
+                 "p" (group-n 4 (+ digit)))))
+       eos))
+  "Regular expression to destruct internal links.")
+
+(defun sbbs--limit-to-range (spec &optional no-push-p)
+  "Hide all posts in the current thread, that aren't in SPEC.
+
+Unless NO-PUSH-P is non-nil, SPEC will be pushed onto
+`sbbs--limit-stack', as to be popped off again by
+`sbbs-show-pop'."
+  (let ((inhibit-read-only t))
+    (remove-list-of-text-properties
+     (point-min) (point-max) '(invisible intangible))
+    (when spec
+      (unless no-push-p
+        (push (cons (point) spec) sbbs--limit-stack))
+      (save-excursion
+        (let ((last (point-max)))
+          (goto-char last)
+          (while (not (bobp))
+            (sbbs-read-previous 1)
+            (unless (memq (get-text-property (point) 'sbbs-thread-nr)
+                          spec)
+              (add-text-properties
+               (point) last '(invisible t intangible t)))
+            (setq last (point)))))
+      (goto-char (point-min))
+      (when spec
+        (sbbs--read-jump-to (car spec)))
+      (let ((point (point)))
+        (when sbbs-jump-to-link
+          (forward-button 1)
+          (when (invisible-p (point))
+            (goto-char point)))))))
+
 (defun sbbs--insert-link (text link)
   "Insert link to LINK as TEXT into buffer.
 
 If LINK is a (board, thread or site) local link, modify opening
 behaviour accordingly."
-  (let ((domain (sbbs--board-domain sbbs--board))
-        (name (sbbs--board-name sbbs--board))
-        (id sbbs--thread-id)
-        (local-re "\\`/%s/%d/\\([[:digit:]]+\\)")
-        (thread-re "\\`/%s/\\([[:digit:]]+\\)")
-        (board-re "\\`http\\(s?\\)://\\([-._[:alnum:]]+\\)/sexp/\\([[:alnum:]]+\\)/\\([[:digit:]]+\\)"))
-    (save-match-data
-      (cond ((string-match (format local-re name id) link)
-             (insert-button
-              text
-              'action (lambda (x)
-                        (goto-char (point-min))
-                        (sbbs-read-next (1- (button-get x 'sbbs-post-id))))
-              'sbbs-post-id (string-to-number (match-string 1 link))))
-            ((string-match (format thread-re name id) link)
-             (insert-button
-              text
-              'action (lambda (x)
-                        (sbbs-view-open (button-get x 'sbbs-link-id)))
-              'sbbs-link-id (string-to-number (match-string 1 link))))
-            ((string-match (format board-re domain name) link)
-             (insert-button
-              text
-              'action (lambda (x)
-                        (let ((sbbs--board (button-get x 'sbbs-board)))
-                          (sbbs-view-open (button-get x 'sbbs-link-id))))
-              'sbbs-board (sbbs-make-board (match-string 2 link)
-                                           (match-string 3 link)
-                                           (string= (match-string 1 link) "s"))
-              'sbbs-link-id (string-to-number (match-string 3 link))))
-            (t (insert-button
-                text
-                'action (lambda (x) (browse-url (button-get x 'url)))
-                'url link))))))
+  (save-match-data
+    (let ((match (string-match sbbs--link-regexp link))
+          range id)
+      (when match
+        (when (match-string 4 link)
+          (setq range (sbbs--parse-number-range (match-string 4 link) 300)))
+        (setq id (string-to-number (match-string 3 link))))
+      (let* ((board sbbs--board)
+             (domain (sbbs--board-domain board))
+             (name (sbbs--board-name board))
+             (other (sbbs-make-board (match-string 1 link)
+                                     (match-string 2 link)
+                                     (string-match-p "\\`https://" link)))
+             (func (lambda (&optional _)
+                     (cond ((not match) (browse-url link))
+                           ;; other supported board
+                           ((or (and (sbbs--board-domain other)
+                                     (not (string= (sbbs--board-domain other)
+                                                   domain)))
+                                (not (string= name (sbbs--board-name other))))
+                            (let ((sbbs--board other))
+                              (sbbs-view-open id range)))
+                           ;; other thread
+                           ((/= id sbbs--thread-id)
+                            (let ((sbbs--board board))
+                              (sbbs-view-open id range)))
+                           ;; this thread
+                           (range (sbbs--limit-to-range range))))))
+        (insert-button text 'action func)))))
 
 (defun sbbs--insert-sxml-par (sxml)
   "Insert paragraph contents SXML at point."
   (dolist (it sxml)
     (cond ((stringp it)
@@ -225,12 +316,12 @@
 errors."
   (when (buffer-live-p buf)
     (when (plist-get status :error)
       (error "Error while loading: %s"
              (cdr (plist-get status :error))))
-    (forward-paragraph)
     (decode-coding-region (point-min) (point-max) 'utf-8)
+    (forward-paragraph)
     (let ((list (read (current-buffer))))
       (kill-buffer)
       (with-current-buffer buf
         (let (ent)
           (dolist (thread list)
@@ -245,11 +336,11 @@
                   ent))
           (setq-local tabulated-list-entries ent)
           (tabulated-list-print t t)
           (hl-line-highlight))))))
 
-(defun sbbs--thread-loader (status id buf)
+(defun sbbs--thread-loader (status id buf range)
   "Callback function for `url-retrieve' when loading thread.
 
 The attribute ID determines what thread from board BOARD to
 load. STATUS is used to check for errors."
   (when (buffer-live-p buf)
@@ -278,15 +369,34 @@
                 (format "Thread %d: %s" id
                         (cdr (assq 'headline thread))))
           (dolist (post (cadr (assq 'posts thread)))
             (sbbs--thread-insert-post post))
           (delete-blank-lines)
+          (when range
+            (sbbs--limit-to-range range))
           (goto-char (point-min)))))))
 
  ;; INTERACTIVE FUNCTIONS
 
-(defun sbbs-view-open (id)
+(defun sbbs-show-all ()
+  "Show all hidden posts."
+  (interactive)
+  (sbbs-show-pop -1))
+
+(defun sbbs-show-pop (&optional n)
+  "Show all hidden posts.
+
+A prefix argument N, repeats this N times. If negative or zero,
+pop all the way up."
+  (interactive "P")
+  (let ((n (or n 1)))
+    (dotimes (_ (if (> n 0) n (length sbbs--limit-stack)))
+      (let ((point (car (pop sbbs--limit-stack))))
+        (sbbs--limit-to-range (cdar sbbs--limit-stack) t)
+        (when point (goto-char point))))))
+
+(defun sbbs-view-open (id &optional range)
   "Open thread ID in new buffer."
   (interactive (list (tabulated-list-get-id)))
   (let ((url (sbbs--board-url (format "/%d" id) t))
         (headline (or (and (not (tabulated-list-get-entry))
                            header-line-format)
@@ -301,11 +411,11 @@
       (sbbs-read-mode)
       (when headline
         (setq header-line-format (format "Thread %d: %s" id headline)))
       (setq sbbs--board board
             sbbs--thread-id id))
-    (url-retrieve url #'sbbs--thread-loader (list id buf))
+    (url-retrieve url #'sbbs--thread-loader (list id buf range))
     (switch-to-buffer buf)))
 
 (defun sbbs-view-compose ()
   "Create buffer to start a new thread."
   (interactive)
@@ -365,21 +475,23 @@
   (interactive "p")
   (dotimes (_ arg)
     (end-of-line)
     (catch 'found
       (while (search-forward-regexp "^#" nil t)
-        (when (eq 'highlight (get-text-property (point) 'face))
+        (when (and (eq 'highlight (get-text-property (point) 'face))
+                   (not (get-text-property (point) 'invisible)))
           (throw 'found t)))))
   (beginning-of-line))
 
 (defun sbbs-read-previous (arg)
   "Move point ARG posts backwards."
   (interactive "p")
   (dotimes (_ arg)
     (catch 'found
       (while (search-backward-regexp "^#" nil t)
-        (when (eq 'highlight (get-text-property (point) 'face))
+        (when (and (eq 'highlight (get-text-property (point) 'face))
+                   (not (get-text-property (point) 'invisible)))
           (throw 'found t)))))
   (beginning-of-line))
 
 ;;;###autoload
 (defun sbbs-browse (board reload)
@@ -428,10 +540,12 @@
     (define-key map (kbd "<tab>") #'forward-button)
     (define-key map (kbd "<backtab>") #'backward-button)
     (define-key map (kbd "r") #'sbbs-read-reply)
     (define-key map (kbd "n") #'sbbs-read-next)
     (define-key map (kbd "p") #'sbbs-read-previous)
+    (define-key map (kbd "a") #'sbbs-show-pop)
+    (define-key map (kbd "A") #'sbbs-show-all)
     map))
 
 (define-derived-mode sbbs-read-mode special-mode "SchemeBBS Read"
   "Major mode for reading a thread."
   (buffer-disable-undo)