polymode-methods.el

(require 'polymode-common)


;;; INITIALIZATION
(defgeneric pm-initialize (config)
  "Initialize current buffer with CONFIG.

First initialize the -hostmode and -innermodes slots of polymode
object ...")

(defmethod pm-initialize ((config pm-polymode))
  ;; fixme: reinstalation leads to infloop of pm--fontify-region-original and others ... 
  ;; On startup with local auto vars emacs reinstals the mode twice .. waf?
  ;; Temporary fix: don't install twice
  (unless pm/polymode
    (let* ((chunkmode (clone (symbol-value (oref config :hostmode))))
           (_ (oset chunkmode -buffer (current-buffer)))
           ;; set if nil, to allow unspecified host chunkmodes to be used in minor modes
           (host-mode (or (oref chunkmode :mode)
                          (oset chunkmode :mode major-mode))))
      (unless (or (eq major-mode host-mode)
                  (eq polymode-major-mode host-mode))
        (let ((polymode-mode t)) ;;major-modes might check it 
          (funcall host-mode)))
      ;; fixme: maybe: inconsistencies?
      ;; 1)  not calling pm-install-buffer on host-buffer
      ;; But, we are not creating/installing a new buffer here .. so it is a
      ;; different thing .. and is probably ok
      ;; 2)  not calling config's :minor-mode (polymode function).
      ;; But polymode function calls pm-initialize... so I guess it is ok
      (oset config -hostmode chunkmode)
      (setq pm/polymode config)
      (setq pm/chunkmode chunkmode)
      (setq pm/type 'host)
      (add-hook 'flyspell-incorrect-hook 'pm--flyspel-dont-highlight-in-chunkmodes nil t)
      (prog1 (pm--setup-buffer) ; general setup for host and innermode buffers
        (let ((PI pm/polymode) IFs)
          ;; aggregate and run hooks; parents first
          (while PI
            (setq IFs (append (and (slot-boundp PI :init-functions) ; don't cascade
                                   (oref PI :init-functions))
                              IFs)
                  PI (and (slot-boundp PI :parent-instance)
                          (oref PI :parent-instance))))
          (run-hooks 'IFs))))))

(defmethod pm-initialize ((config pm-polymode-one))
  (call-next-method)
  (eval `(oset config -innermodes
               (list (clone ,(oref config :innermode))))))

(defmethod pm-initialize ((config pm-polymode-multi))
  (call-next-method)
  (oset config -innermodes
        (mapcar (lambda (sub-name)
                  (clone (symbol-value sub-name)))
                (oref config :innermodes))))



;;; BUFFERS
(defgeneric pm-get-buffer (chunkmode &optional span-type)
  "Get the indirect buffer associated with SUBMODE and
SPAN-TYPE. Should return nil if buffer has not yet been
installed. Also see `pm-get-span'.")

(defmethod pm-get-buffer ((chunkmode pm-chunkmode) &optional type)
  (oref chunkmode -buffer))

(defmethod pm-get-buffer ((chunkmode pm-hbtchunkmode) &optional type)
  (cond ((eq 'body type) (oref chunkmode -buffer))
        ((eq 'head type) (oref chunkmode -head-buffer))
        ((eq 'tail type) (oref chunkmode -tail-buffer))
        (t (error "Don't know how to select buffer of type '%s' for chunkmode '%s' of class '%s'"
                  type (pm--object-name chunkmode) (class-of chunkmode)))))

(defgeneric pm-select-buffer (chunkmode span)
  "Ask SUBMODE to select (make current) its indirect buffer
corresponding to the type of the SPAN returned by
`pm-get-span'.")

(defmethod pm-select-buffer ((chunkmode pm-chunkmode) span)
  "Select the buffer associated with SUBMODE.
Install a new indirect buffer if it is not already installed.

For this method to work correctly, SUBMODE's class should define
`pm-install-buffer' and `pm-get-buffer' methods."
  (let* ((type (car span))
         (buff (pm-get-buffer chunkmode type)))
    (unless (buffer-live-p buff)
      (pm-install-buffer chunkmode type)
      (setq buff (pm-get-buffer chunkmode type)))
    (pm--select-buffer buff)))

(defmethod pm-select-buffer ((chunkmode pm-hbtchunkmode) span)
  (call-next-method)
  (pm--transfer-vars-from-base))

(defmethod pm-select-buffer ((config pm-polymode-multi-auto) &optional span)
  (if (null (car span))
      (pm-select-buffer (oref config -hostmode) span)
    (let ((type (car span))
          (proto (symbol-value (oref config :auto-innermode)))
          chunkmode)
      (save-excursion
        (goto-char (cadr span))
        (unless (eq type 'head)
          (re-search-backward (oref proto :head-reg) nil 'noerr))
        (re-search-forward (oref proto :retriever-regexp))
        (let* ((str (or (match-string-no-properties (oref proto :retriever-num))
                        (error "retriever subexpression didn't match")))
               (name (concat "auto-innermode:" str)))
          (setq chunkmode
                (or (loop for obj in (oref config -auto-innermodes)
                          when  (equal name (object-name-string obj))
                          return obj)
                    (let ((new-obj (clone proto name
                                          :mode (pm--get-mode-symbol-from-name str))))
                      (object-add-to-list config '-auto-innermodes new-obj)
                      new-obj)))))
      (pm-select-buffer chunkmode span))))


(defgeneric pm-install-buffer (chunkmode &optional type)
  "Ask SUBMODE to install an indirect buffer corresponding to
span TYPE. Should return newly installed/retrieved buffer.")

(defmethod pm-install-buffer ((chunkmode pm-chunkmode) &optional type)
  "Independently on the TYPE call `pm/create-indirect-buffer'
create and install a new buffer in slot -buffer of SUBMODE."
  (oset chunkmode -buffer
        (pm--create-chunkmode-buffer-maybe chunkmode type)))

(defmethod pm-install-buffer ((chunkmode pm-hbtchunkmode) type)
  "Depending of the TYPE install an indirect buffer into
slot -buffer of SUBMODE. Create this buffer if does not exist."
  (pm--set-chunkmode-buffer chunkmode type
                          (pm--create-chunkmode-buffer-maybe chunkmode type)))

(defun pm--get-adjusted-background (prop)
  ;; if > lighten on dark backgroun. Oposite on light.
  (color-lighten-name (face-background 'default) 
                      (if (eq (frame-parameter nil 'background-mode) 'light)
                          (- prop) ;; darken
                        prop)))

(defun pm--adjust-chunk-face (beg end face)
  ;; propertize 'face of the region by adding chunk specific configuration
  (interactive "r")
  (when face
    (with-current-buffer (current-buffer)
      (let ((face (or (and (numberp face)
                           (cons 'background-color
                                 (pm--get-adjusted-background face)))
                      face))
            (pchange nil))
        (while (not (eq pchange end))
          (setq pchange (next-single-property-change beg 'face nil end))
          (put-text-property beg pchange 'face
                             `(,face ,@(get-text-property beg 'face)))
          (setq beg pchange))))))

(defun pm--adjust-visual-line-mode (vlm)
  (when (not (eq visual-line-mode vlm))
    (if (null vlm)
        (visual-line-mode -1)
      (visual-line-mode 1))))

;; move only in post-command hook, after buffer selection
(defvar pm--can-move-overlays nil)
(defun pm--move-overlays-to (new-buff)
  (when pm--can-move-overlays 
    (mapc (lambda (o)
            (move-overlay o (overlay-start o) (overlay-end o) new-buff))
          (overlays-in 1 (1+ (buffer-size))))))

(defun pm--transfer-vars-from-base ()
  (let ((bb (pm/base-buffer)))
    (dolist (var '(buffer-file-name))
      (set var (buffer-local-value var bb)))))

(defun pm--select-buffer (buffer)
  (when (and (not (eq buffer (current-buffer)))
             (buffer-live-p buffer))
    (let ((point (point))
          (window-start (window-start))
          (visible (pos-visible-in-window-p))
          (oldbuf (current-buffer))
          (vlm visual-line-mode)
          (ractive (region-active-p))
          (mkt (mark t))
          (bis buffer-invisibility-spec))
      (pm--move-overlays-to buffer)
      (switch-to-buffer buffer)
      (setq buffer-invisibility-spec bis)
      (pm--adjust-visual-line-mode vlm)
      (bury-buffer oldbuf)
      ;; fixme: wha tis the right way to do this ... activate-mark-hook?
      (if (not ractive)
          (deactivate-mark)
        (set-mark mkt)
        (activate-mark))
      (goto-char point)
      ;; Avoid the display jumping around.
      (when visible
        (set-window-start (get-buffer-window buffer t) window-start)))))

(defun pm--setup-buffer (&optional buffer)
  ;; General buffer setup, should work for indirect and base buffers
  ;; alike. Assumes pm/polymode and pm/chunkmode is already in place. Return buffer.
  (let ((buff (or buffer (current-buffer))))
    (with-current-buffer buff
      ;; Don't let parse-partial-sexp get fooled by syntax outside
      ;; the chunk being fontified.

      ;; font-lock, forward-sexp etc should see syntactic comments
      ;; (set (make-local-variable 'parse-sexp-lookup-properties) t)

      (set (make-local-variable 'font-lock-dont-widen) t)
      
      (when pm--dbg-fontlock 
        (setq pm--fontify-region-original
              font-lock-fontify-region-function)
        (set (make-local-variable 'font-lock-fontify-region-function)
             #'pm/fontify-region)
        (setq pm--syntax-begin-function-original
              (or syntax-begin-function ;; Emacs > 23.3
                  font-lock-beginning-of-syntax-function))
        (set (make-local-variable 'syntax-begin-function)
             #'pm/syntax-begin-function))

      (set (make-local-variable 'polymode-mode) t)

      ;; Indentation should first narrow to the chunk.  Modes
      ;; should normally just bind `indent-line-function' to
      ;; handle indentation.
      (when (and indent-line-function ; not that it should ever be nil...
                 (oref pm/chunkmode :protect-indent-line))
        (setq pm--indent-line-function-original indent-line-function)
        (set (make-local-variable 'indent-line-function) 'pm-indent-line))

      ;; Kill the base buffer along with the indirect one; careful not
      ;; to infloop.
      ;; (add-hook 'kill-buffer-hook
      ;;           '(lambda ()
      ;;              ;; (setq kill-buffer-hook nil) :emacs 24 bug (killing
      ;;              ;; dead buffer triggers an error)
      ;;              (let ((base (buffer-base-buffer)))
      ;;                (if  base
      ;;                    (unless (buffer-local-value 'pm--killed-once base)
      ;;                      (kill-buffer base))
      ;;                  (setq pm--killed-once t))))
      ;;           t t)
      
      (when pm--dbg-hook
        (add-hook 'post-command-hook 'polymode-select-buffer nil t))
      (object-add-to-list pm/polymode '-buffers (current-buffer)))
    buff))

(defvar pm--ib-prefix "")
(defun pm--create-indirect-buffer (mode)
  "Create indirect buffer with major MODE and initialize appropriately.

This is a low lever function which must be called, one way or
another from `pm/install' method. Among other things store
`pm/polymode' from the base buffer (must always exist!) in
the newly created buffer.

Return newlly created buffer."
  (unless   (buffer-local-value 'pm/polymode (pm/base-buffer))
    (error "`pm/polymode' not found in the base buffer %s" (pm/base-buffer)))
  
  (setq mode (pm--get-available-mode mode))

  (with-current-buffer (pm/base-buffer)
    (let* ((config (buffer-local-value 'pm/polymode (current-buffer)))
           (new-name
            (generate-new-buffer-name 
             (format "%s%s[%s]" pm--ib-prefix (buffer-name)
                     (replace-regexp-in-string "-mode" "" (symbol-name mode)))))
           (new-buffer (make-indirect-buffer (current-buffer)  new-name))
           ;; (hook pm/indirect-buffer-hook)
           (file (buffer-file-name))
           (base-name (buffer-name))
           (jit-lock-mode nil)
           (coding buffer-file-coding-system))

      (with-current-buffer new-buffer
        (let ((polymode-mode t)) ;;major-modes might check it
          (funcall mode))

        ;; hopefully temporary hack:
        (pm--activate-jit-lock-mode-maybe)
        
        (setq polymode-major-mode mode)
        ;; Avoid the uniqified name for the indirect buffer in the mode line.
        (when pm--dbg-mode-line
          (setq mode-line-buffer-identification
                (propertized-buffer-identification base-name)))
        (setq pm/polymode config)
        (setq buffer-file-coding-system coding)
        (setq buffer-file-name file)
        (vc-find-file-hook))
      new-buffer)))



;;; SPAN MANIPULATION
(defgeneric pm-get-span (chunkmode &optional pos)
  "Ask a chunkmode for the span at point.
Return a list of three elements (TYPE BEG END OBJECT) where TYPE
is a symbol representing the type of the span surrounding
POS (head, tail, body). BEG and END are the coordinates of the
span. OBJECT is a sutable object which is 'responsable' for this
span. That is, OBJECT could be dispached upon with
`pm-select-buffer' or other methods form the interface.

Should return nil if there is no SUBMODE specific span around POS.")

(defmethod pm-get-span (chunkmode &optional pos)
  "Simply return nil. Base mode usually do/can not compute the span"
  nil)

(defmethod pm-get-span ((config pm-polymode) &optional pos)
  "Apply pm-get-span on every element of chunkmodes slot of config object.
Return a cons (chunkmode . span), for which START is closest to
POS (and before it); i.e. the innermost span.  POS defaults to
point."
  (save-restriction
    (widen)
    ;; fixme: host should be last, to take advantage of the chunkmodes computation
    (let* ((smodes (cons (oref config -hostmode)
                         (oref config -innermodes)))
           (start (point-min))
           (end (point-max))
           (pos (or pos (point)))
           (span (list nil start end nil))
           val)
      ;; (save-restriction
      ;;   (widen)

      (dolist (sm smodes)
        (setq val (pm-get-span sm pos))
        (when (and val
                   (or (> (nth 1 val) start)
                       (< (nth 2 val) end)))
          (if (or (car val)
                  (null span))
              (setq span val
                    start (nth 1 val)
                    end (nth 2 val))
            ;; nil car means outer chunkmode (usually host). And it can be an
            ;; intersection of spans returned by 2 different neighbour inner
            ;; chunkmodes. See rapport mode for an example
            (setq start (max (nth 1 val)
                             (nth 1 span))
                  end (min (nth 2 val)
                           (nth 2 span)))
            (setcar (cdr span) start)
            (setcar (cddr span) end)
            )))
      ;; )
      (unless (and (<= start end) (<= pos end) (>= pos start))
        (error "Bad polymode selection: %s, %s"
               (list start end) pos))
      (when (null (car span)) ; chunkmodes can compute the host span by returning nil
        (setcar (last span) (oref config -hostmode)))
      span)))

;; No need for this one so far. Basic method iterates through -innermodes
;; anyhow.
;; (defmethod pm-get-span ((config pm-polymode-multi) &optional pos))

(defmethod pm-get-span ((config pm-polymode-multi-auto) &optional pos)
  (let ((span-other (call-next-method))
        (proto (symbol-value (oref config :auto-innermode))))
    (if (oref proto :head-reg)
        (let ((span (pm--span-at-point (oref proto :head-reg)
                                       (oref proto :tail-reg)
                                       pos)))
          (if (and span-other
                   (or (> (nth 1 span-other) (nth 1 span))
                       (< (nth 2 span-other) (nth 2 span))))
              ;; treat intersections with the host mode
              (if (car span-other)
                  span-other ;not host
                ;; at this stage, car span should better be nil; no explicit check here.
                (setcar (cdr span-other) (max (nth 1 span-other) (nth 1 span)))
                (setcar (cddr span-other) (min (nth 2 span-other) (nth 2 span)))
                span-other)
            (append span (list config)))) ;fixme: this returns config as last object
      span-other)))

(defmethod pm-get-span ((chunkmode pm-hbtchunkmode) &optional pos)
  "Return a list of the form (TYPE POS-START POS-END SELF).
TYPE can be 'body, 'head or 'tail. SELF is just a chunkmode object
in this case."
  (with-slots (head-reg tail-reg head-mode tail-mode) chunkmode
    (let* ((span (pm--span-at-point head-reg tail-reg pos))
           (type (car span)))
      (when (or (and (eq type 'head) (eq head-mode 'host))
                (and (eq type 'tail) (or (eq tail-mode 'host)
                                         (and (null tail-mode)
                                              (eq head-mode 'host)))))
        (setcar span nil))
      (append span (list chunkmode)))))

(defun pm--default-matcher (reg ahead)
  (if (< ahead 0)
      (if (re-search-backward reg nil t)
          (cons (match-beginning 0) (match-end 0)))
    (if (re-search-forward reg nil t)
        (cons (match-beginning 0) (match-end 0)))))

;; fixme: there should be a simpler way... check the code and document
(defun pm--span-at-point-fun-fun (hd-matcher tl-matcher)
  (save-excursion
    (let ((pos (point))
          (posh (funcall hd-matcher -1)))
      (if (null posh)
          ;; special first chunk
          (let ((posh1 (progn (goto-char (point-min))
                              (funcall hd-matcher 1))))
            (if (and posh1
                     (<= (car posh1) pos)
                     (< pos (cdr posh1)))
                (list 'head (car posh1) (cdr posh1))
              (list nil (point-min) (or (car posh1)
                                        (point-max)))))
        (let ((post (progn (goto-char (car posh))
                           (or (funcall tl-matcher 1)
                               (cons (point-max) (point-max))))))
          (if (and (<= (cdr posh) pos)
                   (< pos (car post)))
              (list 'body (cdr posh) (car post))
            (if (and (<= (car post) pos)
                     (< pos (cdr post)))
                (list 'tail (car post) (cdr post))
              (if (< pos (cdr post))
                  ;; might be in the head
                  (progn
                    (goto-char (car post))
                    (let ((posh1 (funcall hd-matcher -1)))
                      (if (and (<= (car posh1) pos)
                               (< pos (cdr posh1)))
                          (list 'head (car posh1) (cdr posh1))
                        (list nil (cdr posh) (car posh1))))) ;; posh is point min, fixme: not true anymore?
                (goto-char (cdr post))
                (let ((posh1 (or (funcall hd-matcher 1)
                                 (cons (point-max) (point-max)))))
                  (if (and posh
                           (<= (car posh1) pos )
                           (< pos (cdr posh1)))
                      (list 'head (car posh1) (cdr posh1))
                    (list nil (cdr post) (car posh1))))))))))))

(defun pm--span-at-point-reg-reg (head-matcher tail-matcher)
  ;; efficent reg-reg lookup with only 2 searches
  (save-excursion
    (let* ((pos (point))
           (reg (concat "\\(?1:\\(" tail-matcher "\\)\\)\\|\\(?2:\\(" head-matcher "\\)\\)"))
           (pos1-end (if (re-search-backward reg nil t)
                         (match-end 0)))
           (pos1-tail? (or (null pos1-end) (match-end 1))) ;; consider point-min as a tail
           (pos1-end (goto-char (or pos1-end  (point-min))))
           (pos2-start (if (re-search-forward reg nil t)
                           (match-beginning 0)))
           (pos2-end (and pos2-start (match-end 0)))
           (pos2-tail? (and pos2-start (match-end 1)))
           (pos2-start (or pos2-start (point-max)))) ;consider pointmax as head
      (if (or (< pos pos2-start)
              (eq pos (point-max)))
          ;; inside doc or chunk body
          (if pos1-tail? 
              (list nil pos1-end pos2-start) ;doc
            (list 'body pos1-end pos2-start)) ; chunk body
        ;; else inside head or tail
        (if (< pos pos2-end) ; <- this one should be always true
            (if pos2-tail?
                (list 'tail pos2-start pos2-end)
              (list 'head pos2-start pos2-end)))
        ))))

(defun pm--span-at-point (head-matcher tail-matcher &optional pos)
  "Basic span detector with head/tail.

HEAD-MATCHER and TAIL-MATCHER can be regexp or functions
returning (cons beg end) and accepting one argument AHEAD that
can be either 1 or -1 for either forward or backward search.

Return (type span-start span-end) where type is one of the
follwoing symbols:

nil - pos is between (tail-reg or point-min) and (head-reg or point-max)
body - pos is between head-reg and (tail-reg or point-max)
head -  head span
tail -  tail span"
  ;; ! start of the span is part of the span !
  (save-restriction
    (widen)
    (goto-char (or pos (point)))
    (cond ((and (stringp head-matcher)
                (stringp tail-matcher))
           (pm--span-at-point-reg-reg head-matcher tail-matcher))
          ((and (stringp head-matcher)
                (functionp tail-matcher))
           (pm--span-at-point-fun-fun
            (lambda (ahead) (pm--default-matcher head-matcher ahead))
            tail-matcher))
          ((and (functionp head-matcher)
                (stringp tail-matcher))
           (pm--span-at-point-fun-fun
            head-matcher
            (lambda (ahead) (pm--default-matcher tail-matcher ahead))))
          ((and (functionp head-matcher)
                (functionp tail-matcher))
           (pm--span-at-point-fun-fun head-matcher tail-matcher))
          (t (error "head and tail matchers should be either regexp strings or functions")))))



;;; INDENT
(defgeneric pm-indent-line (&optional chunkmode span)
  "Indent current line.
Protect and call original indentation function associated with
the chunkmode.")

(defun pm--indent-line (span)
  ;; istr is auto-indent string
  (unwind-protect
      (save-restriction
        (pm--comment-region  1 (nth 1 span))
        (pm/narrow-to-span span)
        (funcall pm--indent-line-function-original))
    (pm--uncomment-region 1 (nth 1 span))))

(defmethod pm-indent-line ()
  "Indent line dispatcher"
  (let ((span (pm/get-innermost-span)))
    (pm-indent-line (car (last span)) span)))

(defmethod pm-indent-line ((chunkmode pm-chunkmode) &optional span)
  (pm--indent-line span))

(defmethod pm-indent-line ((chunkmode pm-hbtchunkmode) &optional span)
  "Indent line in inner chunkmodes.
When point is at the beginning of head or tail, use parent chunk
to indent."
  ;; sloppy work:
  ;; Assumes multiline chunks and single-line head/tail.
  ;; Assumes current buffer is the correct buffer.
  (let ((pos (point))
        shift delta)
    (cond ((or (eq 'head (car span))
               (eq 'tail (car span)))
           ;; use parent's indentation function in head and tail
           (back-to-indentation)
           (setq delta (- pos (point)))
           (backward-char)
           (let ((parent-span (pm/get-innermost-span)))
             (pm-select-buffer (car (last parent-span)) parent-span)
             (forward-char)
             (pm--indent-line parent-span)
             (when (eq 'tail (car span))
               (setq shift (pm--get-head-shift parent-span))
               (indent-to (+ shift (- (point) (point-at-bol))))))
           (if (> delta 0)
               (goto-char (+ (point) delta))))
          (t
           (setq shift (pm--get-head-shift span))
           (pm--indent-line span)
           (when (= (current-column) 0)
             (setq shift (+ shift (oref chunkmode :indent-offset))))
           (setq delta (- (point) (point-at-bol)))
           (beginning-of-line)
           (indent-to shift)
           (goto-char (+ (point) delta))))))

;; fixme: This one is nowhere used?
(defmethod pm-indent-line ((chunkmode pm-polymode-multi-auto) &optional span)
  (pm-select-buffer chunkmode span)
  (pm-indent-line pm/chunkmode span))

(defun pm--get-head-shift (span)
  (save-excursion
    (goto-char (cadr span))
    (back-to-indentation)
    (- (point) (point-at-bol))))



;;; FACES
(defgeneric pm-get-adjust-face (chunkmode &optional type))
(defmethod pm-get-adjust-face ((chunkmode pm-chunkmode) &optional type)
  (oref chunkmode :adjust-face))
(defmethod pm-get-adjust-face ((chunkmode pm-hbtchunkmode) &optional type)
  (setq type (or type pm/type))
  (cond ((eq type 'head)
         (oref chunkmode :head-adjust-face))
        ((eq type 'tail)
         (if (eq 'head (oref pm/chunkmode :tail-adjust-face))
             (oref pm/chunkmode :head-adjust-face)
           (oref pm/chunkmode :tail-adjust-face)))
        (t (oref pm/chunkmode :adjust-face))))

(provide 'polymode-methods)