;;; shm-nodes.el --- Node operations
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file 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, or (at your option)
;; any later version.
;; This file 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/>.
;;; Code:
(require 'shm-overlays)
(require 'cl)
(defun shm-decl-ast (&optional reparse)
"Return the AST representing the current declaration at point.
If the AST has already been loaded, that is returned immediately,
otherwise it's regenerated. See the Internal AST section below
for more information."
(let ((p (shm-decl-points)))
(when p
(shm-get-decl-ast (car p)
(cdr p)
reparse))))
(defun shm-current-node ()
"Return just the current node, without its index.
See `shm-current-node-pair' for what 'current' means."
(cdr (shm-current-node-pair)))
(defun shm-actual-node ()
"Return just the actual current node, without its index.
Normally node functions only care about the current workable
node. This function will return the *actual* node at point. See
`shm-current-node-pair' for what 'workable' means."
(cdr (shm-node-backwards)))
(defun shm-current-node-pair ()
"Return the current workable node at point.
Workable means that it is something that we want to be able to
parse.
For example, if we're looking at a Name,
foobar
then that is all well and good, but we don't want to edit a Name,
nor a QName (the parent), we want to edit an Exp (parent-parent)
whose constructor will be a Var."
(let ((current (shm-node-backwards)))
(when current
(if (and shm-current-node-overlay
(overlay-buffer shm-current-node-overlay)
(or (= (shm-node-start (cdr current))
(overlay-start shm-current-node-overlay))
(= (shm-node-end (cdr current))
(overlay-end shm-current-node-overlay))))
(overlay-get shm-current-node-overlay 'node-pair)
(shm-workable-node current)))))
(defun shm-current-workable-node ()
"Returns the same as `shm-current-node' but including the index."
(let ((current (shm-node-backwards)))
(when current
(shm-workable-node current))))
(defun shm-decl-node (start)
"Get the top-level node of the declaration."
(let* ((vector (save-excursion (goto-char start)
(shm-decl-ast))))
(elt vector 0)))
(defun shm-workable-node (current-pair)
"Assume that the given CURRENT node is not workable, and look
at the parent. If the parent has the same start/end position,
then the parent is the correct one to work with."
(let* ((parent-pair (shm-node-parent current-pair))
(parent (cdr parent-pair))
(current (cdr current-pair)))
(cond
(t (if parent
(if (and (= (shm-node-start current)
(shm-node-start parent))
(= (shm-node-end current)
(shm-node-end parent)))
(if (string= (shm-node-type current) (shm-node-type parent))
current-pair
(shm-workable-node parent-pair))
current-pair)
current-pair)))))
(defun shm-node-previous (node-pair)
"Get the previous node of NODE-PAIR."
(let ((vector (shm-decl-ast)))
(loop for i
downfrom (car node-pair)
to -1
until (or (= i -1)
(let ((node (elt vector i)))
(<= (shm-node-end node)
(shm-node-start (cdr node-pair)))))
finally (return
(when (>= i 0)
(shm-workable-node (cons i
(elt vector i))))))))
(defun shm-node-next (node-pair)
"Get the next node of NODE-PAIR."
(let ((vector (shm-decl-ast)))
(loop for i
from 0
to (length vector)
until (or (= i (length vector))
(let ((node (elt vector i)))
(>= (shm-node-start node)
(shm-node-end (cdr node-pair)))))
finally (return
(when (< i (length vector))
(shm-workable-node (cons i
(elt vector i))))))))
(defun shm-node-backwards (&optional start type bound)
"Get the current node searching bottom up starting from START,
and optionally just searching for nodes of type TYPE. BOUND
restricts how far to look back.
This is the fundamental way to look for a node in the declaration
vector.
Backwards means we go from the last node in the list and go
backwards up the list, it doesn't mean backwards as in up the
tree."
(let* ((vector (shm-decl-ast))
(point (point)))
(loop for i
downfrom (if start
(max -1 start)
(1- (length vector)))
to -1
until (or (= i -1)
(let ((node (elt vector i)))
(or (and bound
(< (shm-node-start node)
bound))
(and (>= point (shm-node-start node))
(<= point (shm-node-end node))
(or (not type)
(string= type
(shm-node-type node)))))))
finally (return
(when (and (>= i 0)
(not (and bound
(< (shm-node-start (elt vector i))
bound))))
(cons i
(elt vector i)))))))
(defun shm-node-child-pair (node-pair)
"Return the immediate child-pair of the given parent."
(let ((vector (shm-decl-ast))
(i (car node-pair)))
(when (< i (1- (length vector)))
(cons (1+ i)
(elt vector (1+ i))))))
(defun shm-node-child (node-pair)
"Return the immediate child of the given parent."
(cdr (shm-node-child-pair node-pair)))
(defun shm-node-ancestor-at-point (node-pair point)
"Find the highest up ancestor that still starts at this point."
(let ((parent-pair (shm-node-parent node-pair)))
(if parent-pair
(if (= (shm-node-start (cdr parent-pair))
point)
(shm-node-ancestor-at-point parent-pair point)
node-pair)
node-pair)))
(defun shm-node-parent (node-pair &optional type bound)
"Return the direct parent of the given node-pair.
The start and end point of the parent can be the same as the
child, and in fact is common."
(save-excursion
(goto-char (shm-node-start (cdr node-pair)))
(let* ((actual-parent-pair (shm-node-backwards (1- (car node-pair))
type
bound))
(maybe-parent-parent-pair (when (car actual-parent-pair)
(shm-node-backwards (1- (car actual-parent-pair)))))
(actual-parent (cdr actual-parent-pair))
(maybe-parent-parent (cdr maybe-parent-parent-pair)))
(cond ((and actual-parent-pair
maybe-parent-parent-pair
(string= (shm-node-type-name actual-parent)
(shm-node-type-name maybe-parent-parent))
(and shm-skip-applications
(or (eq (shm-node-cons actual-parent) 'App)
(eq (shm-node-cons actual-parent) 'InfixApp)
(eq (shm-node-cons actual-parent) 'TyApp)))
(eq (shm-node-cons actual-parent)
(shm-node-cons maybe-parent-parent)))
(shm-node-parent actual-parent-pair))
(t actual-parent-pair)))))
(defun shm-decl-points ()
"Get the start and end position of the current
declaration. This assumes that declarations start at column zero
and that the rest is always indented by one space afterwards, so
Template Haskell uses with it all being at column zero are not
expected to work."
(cond
;; If we're in a block comment spanning multiple lines then let's
;; see if it starts at the beginning of the line (or if any comment
;; is at the beginning of the line, we don't care to treat it as a
;; proper declaration.
((and (shm-in-comment)
(save-excursion (goto-char (line-beginning-position))
(shm-in-comment)))
nil)
((save-excursion
(goto-char (line-beginning-position))
(or (looking-at "^-}$")
(looking-at "^{-$")))
nil)
;; Otherwise we just do our line-based hack.
(t
(save-excursion
(let ((start (or (progn (goto-char (line-end-position))
(search-backward-regexp "^[^ \n]" nil t 1)
(unless (or (looking-at "^-}$")
(looking-at "^{-$"))
(point)))
0))
(end (progn (goto-char (1+ (point)))
(or (when (search-forward-regexp "[\n]+[^ \n]" nil t 1)
(forward-char -1)
(search-backward-regexp "[^\n ]" nil t)
(forward-char)
(point))
(point-max)))))
(cons start end))))))
(defun shm-node-type (n)
"Get the AST type of N."
(elt n 0))
(defun shm-node-type-name (n)
"Get just the constructor name part of N.
This doesn't always return the correct thing, e.g. [Foo Bar] will
return [Foo. It's just a convenience function to get things like
Case or whatnot"
(nth 0 (split-string (elt n 0) " ")))
(defun shm-node-cons (n)
"Get the constructor name of N."
(elt n 1))
(defun shm-node-start (n)
"Get the start position of N in its buffer."
(marker-position (elt n 2)))
(defun shm-node-end (n)
"Get the end position of N in its buffer."
(marker-position (elt n 3)))
(defun shm-node-set-start (n x)
"Set the start position of N."
(set-marker (elt n 2) x))
(defun shm-node-set-end (n x)
"Set the end position of N."
(set-marker (elt n 3) x))
(defun shm-node-delete-markers (n)
"Set the markers to NIL, which is about the best we can do for
deletion. The markers will be garbage collected eventually."
(set-marker (elt n 2) nil)
(set-marker (elt n 3) nil))
(defun shm-node-start-column (n)
"Get the starting column of N."
(save-excursion (goto-char (shm-node-start n))
(current-column)))
(defun shm-node-indent-column (n)
"Get the starting column of N."
(+ (shm-node-start-column n)
(if (or (string= "Tuple" (shm-node-cons n))
(string= "Paren" (shm-node-cons n))
(string= "List" (shm-node-cons n)))
1
0)))
(defun shm-node-end-column (n)
"Get the end column of N."
(save-excursion (goto-char (shm-node-end n))
(current-column)))
(defun shm-node-empty (n)
"Is the node empty of any text?"
(= (shm-node-start n)
(shm-node-end n)))
(defun shm-node-pp (n)
"Pretty print the node."
(format "%s: %S: %d—%d"
(shm-node-type-name n)
(shm-node-cons n)
(shm-node-start n)
(shm-node-end n)))
(defun shm-in-comment ()
"Are we currently in a comment?"
(or (and (eq 'font-lock-comment-delimiter-face
(get-text-property (point) 'face))
;; This is taking liberties, but I'm not too sad about it.
(not (save-excursion (goto-char (line-beginning-position))
(looking-at "{-"))))
(eq 'font-lock-doc-face
(get-text-property (point) 'face))
(and (eq 'font-lock-comment-face
(get-text-property (point) 'face))
(not (save-excursion (goto-char (line-beginning-position))
(looking-at "{-"))))))
(defun shm-in-string ()
"Are we in a string?"
(or (eq 'font-lock-string-face
(get-text-property (point) 'face))))
(provide 'shm-nodes)