initial commit

1 files changed, 215 insertions, 0 deletions

diff --git a/moar.el b/moar.el
new file mode 100644
index 0000000..b832320
--- /dev/null
+++ b/moar.el
@@ -0,0 +1,215 @@
+;;; moar.el --- a very simple single-file hypertext system
+
+;; Author: Leah Neukirchen <leah@vuxu.org>
+;; To the extent possible under law, the creator of this work has waived
+;; all copyright and related or neighboring rights to this work.
+;; https://creativecommons.org/publicdomain/zero/1.0/
+
+(require 'seq)
+(require 'pcase)
+(eval-when-compile (require 'subr-x))
+
+(defface moar-title-face
+  '((t (:bold t :underline t)))
+  "Face to use for Moar titles."
+  :group 'font-lock-highlighting-faces)
+
+(defface moar-link-face
+  '((t))
+  "Face to use for Moar links."
+  :group 'font-lock-highlighting-faces)
+
+(defface moar-page-break-face
+  '((t (:foreground "grey50")))
+  "Face to use for Moar page breaks."
+  :group 'font-lock-highlighting-faces)
+
+(defvar-local moar-history nil)
+
+(defun moar-add-page (title)
+  (goto-char (point-max))
+  (unless (= (preceding-char) ?\n)
+    (insert "\n"))
+  (insert "\C-l\n" text "\n\n"))
+
+(defun moar-visit-link (text)
+  (if (string-match "#" text)
+      (progn
+        (let ((file (substring text 0 (match-beginning 0)))
+              (target (substring text (match-end 0))))
+          (find-file file)
+          (when (equal major-mode 'fundamental-mode)
+            (moar-mode))
+          (moar-visit-link target)))
+    (let ((old-point (point))
+          (narrowed (buffer-narrowed-p)))
+      (widen)
+      (goto-char (point-min))
+      (if (re-search-forward (concat "\C-l\n[^\n]*" (regexp-quote text))
+                             nil t)
+          (move-beginning-of-line 1)
+        (goto-char old-point)
+        (when (y-or-n-p (concat "Link `" text "' not found, create?"))
+          (moar-add-page text)))
+      (when narrowed
+        (narrow-to-page)))))
+
+(defun moar-visit-today ()
+  (interactive)
+  (moar-visit-link (format-time-string "%Y-%m-%d" (current-time))))
+
+(defun moar-visit-yesterday ()
+  (interactive)
+  (moar-visit-link (format-time-string "%Y-%m-%d"
+                                       (time-subtract (current-time)
+                                                      (* 24 3600)))))
+
+(defun moar-go-back ()
+  (interactive)
+  (if (null moar-history)
+      (progn
+        (widen)
+        (goto-char (point-min)))
+    (let ((n (pop moar-history)))
+      (widen)
+      (goto-char n))))
+
+(defun moar-link-at-point ()
+  (let (link-start 
+        link-end)
+    (if (and (looking-back "\\[.*?")
+             (setq link-start (1+ (match-beginning 0)))
+             (looking-at ".*?\\]")
+             (setq link-end (1- (match-end 0)))
+             (< link-start link-end))   ; don't match empty links
+        (buffer-substring-no-properties link-start link-end))))
+
+(defun moar-follow-link-or-newline ()
+  (interactive)
+  (if-let (link (moar-link-at-point))
+      (progn
+        (push (point) moar-history)
+        (if (string-prefix-p "<" link)
+            (moar-visit-backlink-interactive (substring link 1))
+          (moar-visit-link link)))
+    (newline)))
+
+(defun moar-follow-link-from-mouse (e)
+  (interactive "e")
+  (mouse-set-point e)
+  (when-let (link (moar-link-at-point))
+    (push (point) moar-history)
+    (if (string-prefix-p "<" link)
+        (moar-visit-backlink-interactive (substring link 1))
+      (moar-visit-link link))))
+
+(defun moar-all-links ()
+  (let ((matches))
+    (save-match-data
+      (save-excursion
+        (save-restriction
+          (widen)
+          (goto-char 1)
+          (while (search-forward-regexp "^\C-l\n.*" nil t 1)
+            (push (substring (match-string 0) 2) matches)))))
+    matches))
+
+(defun moar-all-links-and-titles ()
+  (let (matches
+        current-title)
+    (save-match-data
+      (save-excursion
+        (save-restriction
+          (widen)
+          (goto-char 1)
+          (while (search-forward-regexp "^\C-l\n\\(.*\\)\\|\\[\\(.+?\\)\\]"
+                                        nil t 1)
+            (if (match-string 1)
+                (setq current-title (match-string-no-properties 1))
+              (push (cons current-title (match-string-no-properties 2)) matches)
+              )))))
+    matches))
+
+(defun moar-current-title ()
+  (save-match-data 
+    (save-excursion
+      (save-restriction
+        (widen)
+        (end-of-line 1)
+        (if (search-backward-regexp "^\C-l\n\\(.*\\)" nil t)
+            (match-string-no-properties 1)
+          nil)))))
+
+(defun moar-insert-link ()
+  (interactive)
+  (let* ((links (moar-all-links))
+         (read (if (fboundp 'ivy-read)
+                   #'ivy-read
+                 #'completing-read))
+         (target (funcall read "Link target? " links)))
+    (when target
+      (insert "[" target "]"))))
+
+(defun moar-visit-link-interactive ()
+  (interactive)
+  (let* ((links (moar-all-links))
+         (read (if (fboundp 'ivy-read)
+                   #'ivy-read
+                 #'completing-read))
+         (target (funcall read "Go to: " links)))
+    (when target
+      (moar-visit-link target))))
+
+(defun moar-visit-backlink-interactive (&optional title)
+  (interactive)
+  (let* ((links-titles (moar-all-links-and-titles))
+         (current-title (or title (moar-current-title)))
+         (read (if (fboundp 'ivy-read)
+                   #'ivy-read
+                 #'completing-read))
+         (links (mapcar #'car
+                        (seq-filter #'(lambda (x) (equal (cdr x) current-title))
+                                    links-titles)))
+         (target (funcall read "Go to backlink: " links)))
+    (when target
+      (moar-visit-link target)
+      (when (re-search-forward (concat "\\[" (regexp-quote current-title) "\\]")
+                               nil t)
+        (goto-char (1+ (match-beginning 0))))
+      )))
+
+(define-derived-mode moar-mode
+  text-mode "Moar"
+  "Major mode for Moar hypertext files."
+  (make-local-variable 'font-lock-defaults)
+  (setq font-lock-defaults
+        '((("^\\(\C-l\\)\n\\(.*\\)"
+            (1 'moar-page-break-face)
+            (2 'moar-title-face))
+           ("\\[\\(.+?\\)\\]" 
+            (1 'moar-link-face))
+           )
+          t nil))
+  (add-to-list 'font-lock-extra-managed-props 'display)
+  (font-lock-add-keywords nil
+                          '(("^\\(\C-l\\)\n" 1 '(face nil display "∇"))))
+  (font-lock-mode 1)
+  (when (fboundp 'orgalist-mode)
+    (orgalist-mode 1)))
+
+(define-key moar-mode-map (kbd "RET") 'moar-follow-link-or-newline)
+(define-key moar-mode-map [mouse-2] 'moar-follow-link-from-mouse)
+(define-key moar-mode-map [follow-link] 'moar-link-face)
+
+(define-key moar-mode-map (kbd "C-c [") 'moar-insert-link)
+(define-key moar-mode-map (kbd "C-c C-v") 'moar-visit-link-interactive)
+(define-key moar-mode-map (kbd "C-c C-b") 'moar-visit-backlink-interactive)
+(define-key moar-mode-map (kbd "C-c C-t") 'moar-visit-today)
+(define-key moar-mode-map (kbd "C-c C-y") 'moar-visit-yesterday)
+(define-key moar-mode-map (kbd "C-c C-n") 'narrow-to-page)
+(define-key moar-mode-map (kbd "C-c C-w") 'widen)
+(define-key moar-mode-map (kbd "C-c C-o") 'moar-go-back)
+
+(provide 'moar)
+
+;;; moar.el ends here