Re: [Orgmode] Deriving mode from org-mode

[Anders Waldenborg <andersg@0x63.nu>]

[-- Attachment #1: Type: text/plain, Size: 413 bytes --]

On Tue, Feb 22, 2011 at 12:52:03PM +0100, Bastien wrote:
> > It is a "personal wiki" mode. It automatically narrows to current top level
> > heading, adds some extra navigation functions and allows creating links to
> > new "pages" (= top level heading) in a simple way. Hopefully I can clean it
> > up a little bit soon and publish it.
> 
> That'd be great, thanks!

Here it is, after a "slight" delay.

 anders

[-- Attachment #2: aw-org-pw.el --]
[-- Type: text/plain, Size: 10106 bytes --]

;;;; aw-org-pw.el --- personal wiki major mode derived from org-mode.
;;
;; Copyright (C) 2011 Anders Waldenborg
;;
;; Author: Anders Waldenborg <anders@0x63.nu>
;; Keywords: outlines, calendar, wp
;; Version: 0.1
;;
;; This file NOT is part of GNU Emacs.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or (at
;; your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see `http://www.gnu.org/licenses/'.
;;
;;
;;; Commentary:
;;
;; This implements the following features on top of org-mode making it
;; feel more like a (personal) wiki:
;;
;;  * Auto narrowing to current section (= first level heading).
;;  * Linking of all section names.
;;  * Creating of new sections when following nonexistant links.
;;  * Recording navigation history and back functionality.
;;
;;
;;; Code:


(require 'org)

(defconst aw-org-pw-frontpage-name "StartPage"
  "Fake name created for the section before first heading")


;;;;
;;;; Random helper functions
;;;;

(defun aw-truncate-list (l n)
  "Destructivly truncates list l to n elements"
  (let ((e (nthcdr (1- n) l)))
    (when e
      (setcdr e nil)))
  l)

(defun aw-org-pw-word-at-point ()
  "Return word at point, or currently marked text if mark is active"
  (interactive)
  (if mark-active
      (buffer-substring-no-properties (point) (mark))
    (when (looking-at "\\w")
      (let ((start (save-excursion (while (not (looking-at "\\b\\w")) (backward-char)) (point)))
            (end (save-excursion (while (not (looking-at "\\w\\b")) (forward-char)) (1+ (point)))))
        (buffer-substring-no-properties start end)))))


;;;;
;;;; Section navigation
;;;;

(defun aw-org-pw-section-regexp (&optional pagename)
  "Return a regexp matching page section (or any section if pagename is nil)"
  (format "^\\* *\\(%s\\)$" (if pagename
                                (regexp-quote pagename)
                              "[^*].*")))

(defun aw-org-pw-get-section-region (name)
  "Find (start . end) points of specified section"
  (let ((case-fold-search t)
	(search (aw-org-pw-section-regexp name)))
    (save-excursion
      (save-restriction
        (widen)
        (goto-char (point-min))
        (aw-org-pw-next-section)
        (if (string-equal name aw-org-pw-frontpage-name)
            (cons (point-min) (point))
          (while (not (looking-at search))
            (forward-line)
            (aw-org-pw-next-section)
            (if (eobp)
                (error "Section not found")))
          (forward-line)
          (let ((start (point)))
            (aw-org-pw-next-section)
            (cons start (point))))))))

(defun aw-org-pw-all-sections ()
  "Return a list with all section names"
  (save-restriction
    (save-excursion
      (widen)
      (let ((res (list aw-org-pw-frontpage-name))
            (re (aw-org-pw-section-regexp)))
        (goto-char (point-min))
        (while (not (eobp))
          (when (looking-at re)
            (setq res (cons (match-string-no-properties 1) res)))
          (forward-line))
        res))))

(defun aw-org-pw-next-section ()
  "Go to next section"
  (let ((re (aw-org-pw-section-regexp)))
    (while (not (or (eobp) (looking-at re)))
      (forward-line))
    (point)))

(defun aw-org-pw-current-section-name ()
  "Find current section name

This is usually same as the variable aw-org-pw-current-section,
but if navigation has happened by other means (e.g isearch) this
function may be needed to get the correct value."
  (save-restriction
    (save-excursion
      (widen)
      (let ((re (aw-org-pw-section-regexp)))
        (while (not (or (bobp) (looking-at re)))
          (forward-line -1))
        (if (bobp)
            aw-org-pw-frontpage-name
          (match-string-no-properties 1))))))


;;;;
;;;; Navigation with history
;;;;

(defun aw-org-pw-back ()
  "Goto previously visited section"
  (interactive)
  (unless aw-org-pw-breadcrumbs-list
    (error "Nowhere to go I think..."))
  (let ((f (pop aw-org-pw-breadcrumbs-list)))
    (aw-org-pw-goto-section-raw (car f))
    (setq aw-org-pw-current-section (car f))
    (goto-char (+ (point-min) (cdr f)))))

(defun aw-org-pw-goto-section-raw (name)
  "Go to specified section without updating history"
  (let ((reg (aw-org-pw-get-section-region name)))
    (narrow-to-region (car reg) (cdr reg))))

(defun aw-org-pw-goto-section-with-history (name offset prevsec)
  "Go to specified section recording provided history"
  (aw-org-pw-goto-section-raw name)
  (push (cons prevsec offset) aw-org-pw-breadcrumbs-list)
  (aw-truncate-list aw-org-pw-breadcrumbs-list 10)
  (setq aw-org-pw-current-section name)
  (goto-char (point-min)))

(defun aw-org-pw-goto-section (name)
  "Go to specified section"
  (aw-org-pw-goto-section-with-history name (- (point) (point-min)) aw-org-pw-current-section))

(defun aw-org-pw-frontpage ()
  "Navigate to front page"
  (interactive)
  (aw-org-pw-goto-section aw-org-pw-frontpage-name))


;;;;
;;;; Links
;;;;

(defun aw-org-pw-follow-link-at-point ()
  ""
  (interactive)
  (cond
   ;; aw-org-pw link -> aw-org-pw-goto-section
   ((get-text-property (point) 'aw-org-pw-linked-text)
    (aw-org-pw-goto-section (get-text-property (point) 'aw-org-pw-linked-text)))

   ;; other kind of org link -> org-open-at-point
   ((eq (get-text-property (point) 'face) 'org-link)
    (org-open-at-point))

   ;; not a link? -> offer to create page
   ((aw-org-pw-word-at-point) (aw-org-pw-create-new-section t))

   ;; bail out
   (t (message "Don't know what to do"))))

(defun aw-org-pw-follow-link-at-mouse (ev)
  "Follow link at mouse"
  (interactive "e")
  (mouse-set-point ev)
  (aw-org-pw-follow-link-at-point))

(defun aw-org-pw-create-new-section (&optional confirm)
  "Create a new section in current file"
  (let ((pagename (aw-org-pw-word-at-point)))
    (if (and confirm (not (y-or-n-p (format "Create new page '%s'? " pagename))))
        (message "Page creation aborted")
      (widen)
      (goto-char (point-max))
      (insert "\n\n* " pagename "\n")
      (aw-org-pw-update-sections-regexp)
      (aw-org-pw-goto-section pagename))))


;;;;
;;;; Link hilighting
;;;;

(defun aw-org-pw-activate-links (limit)
  ""
  (when (derived-mode-p 'aw-org-pw-mode)
    (let ((case-fold-search t))
      (when (re-search-forward aw-org-pw-link-regexp limit t)
	(org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0))
	(add-text-properties (match-beginning 0) (match-end 0)
			     (list 'mouse-face 'highlight
				   'keymap aw-org-pw-link-map
				   'help-echo "Personal wiki link"
				   'aw-org-pw-linked-text (match-string-no-properties 0)))
	(org-rear-nonsticky-at (match-end 0))
	t))))

(add-hook 'org-font-lock-set-keywords-hook
          (lambda ()
            (add-to-list 'org-font-lock-extra-keywords
                         '(aw-org-pw-activate-links (0 'org-link t))
                         t)))

(defun aw-org-pw-update-sections-regexp ()
  "Update regexp used to create all section-links"
  (setq aw-org-pw-link-regexp (regexp-opt (aw-org-pw-all-sections) 'words)))


;;;;
;;;; isearch integration - widen before search starts, and narrow when
;;;;                       done, possibly updating breadcrumbs.
;;;;

(defvar aw-org-pw-isearch-startoff nil
  "Internal variable for storing offset in page when search starts")

(defun aw-org-pw-isearch-start ()
  (setq aw-org-pw-isearch-startoff (- (point) (point-min)))
  (widen))

(defun aw-org-pw-isearch-end ()
  (if isearch-mode-end-hook-quit
      (aw-org-pw-goto-section-raw aw-org-pw-current-section)
    (save-excursion
      (aw-org-pw-goto-section-with-history (aw-org-pw-current-section-name) aw-org-pw-isearch-startoff aw-org-pw-current-section))))


;;;;
;;;; imenu integration
;;;;

(defun aw-org-pw-imenu-entries ()
  (mapcar (lambda (e)
            (cons e 1))
          (aw-org-pw-all-sections)))

(defun aw-org-pw-imenu-goto (name pos &optional rest)
  (aw-org-pw-goto-section name))

;;;;
;;;; Avoid creating top level headers
;;;;
(defun aw-org-star ()
  "Insert two (on beginning of line) or one (otherwise) '*' characters

This works mostly as a reminder that first level headings are
special in aw-org-pw-mode and should not be created manually."
  (interactive)
  (if (bolp)
      (insert "**")
    (insert "*")))

;;;;
;;;; Actual mode definition
;;;;

(define-derived-mode aw-org-pw-mode org-mode "Org-PW" nil
  (make-local-variable 'aw-org-pw-breadcrumbs-list)
  (make-local-variable 'aw-org-pw-current-section)
  (setq aw-org-pw-breadcrumbs-list nil)
  (setq aw-org-pw-current-section "none")

  (setq header-line-format '("[" aw-org-pw-current-section "] back:" (:eval (if aw-org-pw-breadcrumbs-list (caar aw-org-pw-breadcrumbs-list) "no history"))))

  (setq imenu-create-index-function 'aw-org-pw-imenu-entries)
  (setq imenu-default-goto-function 'aw-org-pw-imenu-goto)

  (add-hook 'isearch-mode-hook 'aw-org-pw-isearch-start nil t)
  (add-hook 'isearch-mode-end-hook 'aw-org-pw-isearch-end nil t)

  (widen)
  (show-all)
  (aw-org-pw-update-sections-regexp)
  (aw-org-pw-frontpage))


;;;;
;;;; Keymaps
;;;;

(define-key aw-org-pw-mode-map "\C-c\C-o" 'aw-org-pw-follow-link-at-point)
(define-key aw-org-pw-mode-map "\C-c\C-b" 'aw-org-pw-back)
(define-key aw-org-pw-mode-map "\C-c\C-f" 'aw-org-pw-frontpage)
(define-key aw-org-pw-mode-map "*" 'aw-org-star)

(defvar aw-org-pw-link-map (make-sparse-keymap))
(define-key aw-org-pw-link-map [mouse-2] 'aw-org-pw-follow-link-at-mouse)
(when org-mouse-1-follows-link
  (define-key aw-org-pw-link-map [follow-link] 'mouse-face))

(define-key aw-org-pw-link-map [return] 'aw-org-pw-follow-link-at-point)

(provide 'aw-org-pw)

;;; aw-org-pw.el ends here