diff --git a/elisp/shm-ast.el b/elisp/shm-ast.el
--- a/elisp/shm-ast.el
+++ b/elisp/shm-ast.el
@@ -1,4 +1,4 @@
-;;; shm-ast.el --- AST generation functions
+;;; shm-ast.el --- AST functions
;; Copyright (c) 2014 Chris Done. All rights reserved.
@@ -17,14 +17,17 @@
;;; Code:
-(require 'shm-globals)
-(require 'shm-nodes)
-(require 'shm-ast-documentation)
(require 'shm-customizations)
-(require 'shm-yank-kill)
+(require 'shm-node)
+(require 'shm-in)
+(require 'shm-overlays)
+(require 'ring)
(require 'cl)
+(defvar shm-lighter " SHM?"
+ "The lighter for structured Haskell mode.")
+
(defvar shm-decl-asts nil
"This is partly an optimization and partly for more
functionality. We could parse the whole module, but that would be
@@ -37,32 +40,47 @@
stop working on declarations that are fine. I've found in my use
of SHM that this is a common use-case worth taking into account.")
-(defun shm-node-description (node)
- "Generate a description of the given node suitable to be put in
- the minibuffer. If no documentation can be found, it generates
- a reasonable string instead."
- (let* ((type-doc (assoc (shm-node-type-name node)
- shm-ast-documentation))
- (con-doc (assoc (symbol-name (shm-node-cons node))
- (cddr type-doc))))
- (if type-doc
- (format "Node type: “%s”: %s, case: %s\n%s"
- (nth 0 type-doc)
- (nth 1 type-doc)
- (if con-doc
- (format "“%s”: %s"
- (nth 0 con-doc)
- (nth 1 con-doc))
- (format "“%s” (no more info)"
- (shm-node-cons node)))
- (save-excursion
- (shm-kill-node 'buffer-substring-no-properties
- node
- nil
- t)))
- (format "Node type: “%s” (no more info)"
- (shm-node-type-name node)))))
+(defvar shm-last-parse-start 0
+ "This is used to avoid unnecessary work, if the start of the
+ declaration hasn't changed, and the end (see
+ `shm-last-parse-end') since we last parsed, don't bother
+ re-parsing.")
+(defvar shm-last-parse-end 0
+ "See `shm-last-parse-start' for explanation.")
+
+(defvar shm-history-stack nil
+ "Stack for story node history.")
+
+(defcustom shm-history-stack-max-length
+ 10
+ "Maximum length of the node history stack."
+ :group 'shm
+ :type 'integer)
+
+(defun shm/reparse ()
+ "Re-parse the current node.
+
+This is used on the reparsing timer, but also on commands that
+really need accurate AST information *right now*, so this will
+force a reparse immediately (if necessary)."
+ (interactive)
+ (shm-decl-ast t)
+ (when (/= shm-last-point (point))
+ (shm-set-node-overlay)))
+
+(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-set-decl-ast (point ast)
"Store the given decl AST at the given POINT. If there is
already an AST for a decl at the given point then remove that one
@@ -92,31 +110,65 @@
(/= end shm-last-parse-end))
(setq shm-last-parse-start start)
(setq shm-last-parse-end end)
- (let ((ast (shm-get-nodes (shm-get-ast "decl"
- start
- end)
- start
- end)))
- (if ast
- (progn (setq shm-lighter " SHM")
- (when pair
- (shm-delete-markers pair))
- (shm-set-decl-ast start ast)
- ;; Delete only quarantine overlays.
- (shm-delete-overlays (point-min) (point-max) 'shm-quarantine)
- (shm/init)
- ast)
- (progn
- (when shm-display-quarantine
- (shm-quarantine-overlay start end))
- (setq shm-lighter " SHM!")
- nil))))))))
+ (let ((parsed-ast (shm-get-ast (if (bound-and-true-p structured-haskell-repl-mode)
+ "stmt"
+ "decl")
+ start end)))
+ (cl-flet ((bail ()
+ (when shm-display-quarantine
+ (shm-quarantine-overlay start end))
+ (setq shm-lighter " SHM!")
+ nil))
+ (if parsed-ast
+ (progn
+ (when (bound-and-true-p structured-haskell-repl-mode)
+ (shm-font-lock-region start end))
+ (let ((ast (shm-get-nodes parsed-ast start end)))
+ (if ast
+ (progn (setq shm-lighter " SHM")
+ (when pair
+ (shm-delete-markers pair))
+ (shm-set-decl-ast start ast)
+ ;; Delete only quarantine overlays.
+ (shm-delete-overlays (point-min) (point-max) 'shm-quarantine)
+ (shm/init)
+ ast)
+ (bail))))
+ (bail)))))))))
-(defun shm-delete-markers (decl)
- "Delete the markers in DECL."
- (mapc #'shm-node-delete-markers
- (cdr decl)))
+(defun shm-font-lock-region (start end)
+ "When in a REPL, we don't typically have font locking, so we
+ should manually perform a font-lock whenever we get a valid
+ parse."
+ (unless (= (1+ start) end)
+ (let ((point (point))
+ (inhibit-modification-hooks t)
+ (list buffer-undo-list)
+ (string (buffer-substring-no-properties start end)))
+ (unless (string-match "^:" string)
+ (let ((fontified (shm-fontify-as-mode string
+ 'haskell-mode))
+ (overlays (mapcar (lambda (o)
+ (list o
+ (overlay-start o)
+ (overlay-end o)))
+ (overlays-in start end))))
+ (delete-region start end)
+ (insert fontified)
+ (goto-char point)
+ ;; Restore overlay positions
+ (loop for o in overlays
+ do (move-overlay (nth 0 o) (nth 1 o) (nth 2 o)))
+ (setq buffer-undo-list list))))))
+(defun shm-fontify-as-mode (text mode)
+ "Fontify TEXT as MODE, returning the fontified text."
+ (with-temp-buffer
+ (funcall mode)
+ (insert "x=" text)
+ (font-lock-fontify-buffer)
+ (buffer-substring (+ (point-min) (length "x=")) (point-max))))
+
(defun shm-get-ast (type start end)
"Get the AST for the given region at START and END. Parses with TYPE.
@@ -128,7 +180,7 @@
imagine."
(let ((message-log-max nil)
(buffer (current-buffer)))
- (when (> end (1+ start))
+ (when (> end start)
(with-temp-buffer
(let ((temp-buffer (current-buffer)))
(with-current-buffer buffer
@@ -225,5 +277,350 @@
marker))))
ast)))
(t nil))))
+
+(defun shm-decl-points (&optional use-line-comments)
+ "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 (not use-line-comments)
+ (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)
+ ((bound-and-true-p structured-haskell-repl-mode)
+ (case major-mode
+ (haskell-interactive-mode
+ ;; If the prompt start is available.
+ (when (boundp 'haskell-interactive-mode-prompt-start)
+ ;; Unless we're running code.
+ (unless (> (point)
+ (save-excursion (goto-char haskell-interactive-mode-prompt-start)
+ (line-end-position)))
+ ;; When we're within the prompt and not on some output lines or whatever.
+ (when (and (>= (point) haskell-interactive-mode-prompt-start)
+ (not (= haskell-interactive-mode-prompt-start
+ (line-end-position))))
+ (let ((whole-line (buffer-substring-no-properties
+ haskell-interactive-mode-prompt-start
+ (line-end-position))))
+ ;; Don't activate if we're doing a GHCi command.
+ (unless (string-match "^:" whole-line)
+ (cons haskell-interactive-mode-prompt-start
+ (line-end-position)))))))
+ )))
+ ;; 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-delete-markers (decl)
+ "Delete the markers in DECL."
+ (mapc #'shm-node-delete-markers
+ (cdr decl)))
+
+(defun shm/init (&optional force-renew)
+ "Initialize the current node overlay at point.
+
+FORCE-RENEW would be used when the buffer has changed and
+therefore the current overlay should be re-initialized."
+ (interactive)
+ (when force-renew
+ (setq shm-current-node-overlay nil))
+ (shm-set-node-overlay))
+
+(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-set-node-overlay (&optional node-pair jump-direction no-record)
+ "Set the current overlay for the current node. Optionally pass
+NODE-PAIR to use the specific node-pair (index + node)."
+ (setq shm-current-node-overlay nil)
+ (shm-delete-overlays (point-min)
+ (point-max)
+ 'shm-current-overlay)
+ (let* ((node-pair (or node-pair
+ (shm-current-node-pair)))
+ (node (cdr node-pair)))
+ (when jump-direction
+ (if (eq jump-direction 'end)
+ (goto-char (shm-node-end node))
+ (goto-char (shm-node-start node))))
+ (setq shm-last-point (point))
+ (setq shm-current-node-overlay
+ (when node
+ (shm-current-overlay (shm-node-start node)
+ (shm-node-end node)
+ node-pair)))
+ (unless no-record
+ (shm-history-record (point) node-pair))))
+
+(defun shm/goto-last-point ()
+ "Jump to the most recent node."
+ (interactive)
+ (let ((stack (shm-history-stack))
+ (point (point)))
+ (when (not (ring-empty-p stack))
+ (let* ((i (if (= (point) (car (ring-ref stack 0)))
+ 1
+ 0))
+ (pair (ring-ref stack i)))
+ (when pair
+ (goto-char (car pair))
+ (shm-set-node-overlay (cdr pair) nil t)
+ (loop for j from 0 to i
+ do (ring-remove stack 0)))))))
+
+(defun shm-history-jump (point)
+ "Jump to POINT and set the current node to whatever node was
+ last current at that point."
+ (goto-char point)
+ (let ((stack (shm-history-stack)))
+ (when (not (ring-empty-p stack))
+ (let ((pair (assoc point (ring-elements stack))))
+ (when pair
+ (shm-set-node-overlay (cdr pair)))))))
+
+(defun shm-history-record (point node-pair)
+ "Record POINT and NODE in the node history."
+ (ring-insert (shm-history-stack)
+ (cons point node-pair)))
+
+(defun shm-history-stack ()
+ "Get the node history of the current buffer."
+ (if (and (local-variable-p 'shm-history-stack)
+ shm-history-stack)
+ shm-history-stack
+ (set (make-local-variable 'shm-history-stack)
+ (make-ring shm-history-stack-max-length))))
+
+(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-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)))
+ (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-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
+ (shm-node-app-p actual-parent))
+ (eq (shm-node-cons actual-parent)
+ (shm-node-cons maybe-parent-parent)))
+ (shm-node-parent actual-parent-pair))
+ (t actual-parent-pair)))))
+
+(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-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-get-qop-string (node)
+ "Get the string of the operator, if the node is an operator."
+ (when (string= (shm-node-type-name node) "QOp")
+ (buffer-substring-no-properties (shm-node-start node)
+ (shm-node-end node))))
+
+(defun shm/goto-parent (&optional node-pair direction)
+ "Set the current node overlay to the parent node-pair"
+ (interactive)
+ (let ((direction (or direction 'start)))
+ (if shm-current-node-overlay
+ (let* ((o shm-current-node-overlay)
+ (parent-pair (shm-node-parent (or node-pair
+ (shm-current-workable-node)))))
+ (when parent-pair
+ (let ((parent (cdr parent-pair)))
+ (if (and o
+ (overlay-buffer o)
+ (>= (shm-node-start parent)
+ (overlay-start o))
+ (<= (shm-node-end parent)
+ (overlay-end o)))
+ (shm/goto-parent parent-pair direction)
+ (shm-set-node-overlay parent-pair direction)))))
+ (when node-pair
+ (shm-set-node-overlay node-pair direction)))))
+
+(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-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)))
(provide 'shm-ast)
diff --git a/elisp/shm-case-split.el b/elisp/shm-case-split.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-case-split.el
@@ -0,0 +1,176 @@
+;;; shm-case-split.el --- Case splitting functionality
+
+;; 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 .
+
+;;; Commentary:
+
+;; Produces a list of case alternatives from a sum type data
+;; declaration.
+
+;;; Code:
+
+(require 'shm)
+(require 'haskell-process)
+
+(defun shm-case-split-insert-pattern (alts)
+ "Takes the first alt in ALTS and inserts a pattern match for
+ it."
+ (when (car alts)
+ (let ((alt (car alts)))
+ (when (> (cdr alt) 0)
+ (insert "("))
+ (insert (car alt))
+ (loop for i from 1 to (cdr alt)
+ do (progn (insert " _")
+ (shm-evaporate (1- (point)) (point))))
+ (when (> (cdr alt) 0)
+ (insert ")")))))
+
+(defun shm-case-split-insert-alts (alts)
+ "Inserts case alts for the given ALTS. It will create
+evaporating slots for each part. E.g.
+
+case x of
+ |
+
+for data Maybe a = Just a | Nothing will insert
+
+case x of
+ Just _ -> undefined
+ Nothing -> undefined
+
+Where the _ and undefineds are evaporating slots."
+ (let ((column (current-column)))
+ (loop for alt in alts
+ do (progn (when (/= column (current-column))
+ (newline)
+ (indent-to column))
+ (insert (car alt))
+ (loop for i from 1 to (cdr alt)
+ do (progn (insert " _")
+ (shm-evaporate (1- (point)) (point))))
+ (insert " -> undefined")
+ (shm-evaporate (- (point) (length "undefined"))
+ (point))))))
+
+(defun shm-case-split-alts-from-data-decl (string)
+ "Given a data declaration STRING, generate a list of alternatives."
+ (with-temp-buffer
+ (insert (replace-regexp-in-string
+ "[a-zA-Z0-9]+-[0-9.]+:"
+ ""
+ string))
+ (text-mode)
+ (structured-haskell-mode)
+ (setq shm-last-parse-start (point-max))
+ (setq shm-last-parse-end (point-min))
+ (shm/reparse)
+ (mapcar #'shm-case-split-name-and-arity
+ (shm-case-split-get-constructors))))
+
+(defun shm-case-split-generate-alt (cons)
+ "Generate an alt from the given NODE-PAIR."
+ (let ((name (car cons))
+ (arity (cdr cons)))
+ (format "%s%s"
+ name
+ (apply 'concat
+ (loop for i from 1 to arity
+ collect " _")))))
+
+(defun shm-case-split-name-and-arity (node-pair)
+ "Get the constructor name and arity of the given constructor NODE-PAIR."
+ (let* ((parent (shm-node-child-pair node-pair))
+ (name-node (shm-node-child parent)))
+ (goto-char (shm-node-end name-node))
+ (cons (shm-node-string name-node)
+ (or (when (/= (shm-node-end name-node)
+ (shm-node-end (cdr parent)))
+ (shm/forward-node)
+ (shm/reparse)
+ (let ((n 0)
+ (last-node 0)
+ (current-pair (shm-current-node-pair)))
+ (while (and (/= (point) (point-max))
+ current-pair
+ (= (car parent)
+ (car (shm-node-parent current-pair))))
+ (when (/= (car current-pair)
+ last-node)
+ (setq n (1+ n))
+ (setq last-node (car current-pair)))
+ (unless (= (point)
+ (point-max))
+ (shm/forward-node)
+ (shm/reparse)
+ (setq current-pair (shm-current-node-pair))))
+ n))
+ 0))))
+
+(defun shm-case-split-get-constructors ()
+ "Get a list of constructors."
+ (goto-char (point-min))
+ (or (search-forward "= " nil t 1)
+ (error "Couldn't find any constructors (searched for '=')."))
+ (let ((conses (list)))
+ (while (/= (point) (point-max))
+ (let ((cons (shm-case-split-get-constructor)))
+ (when cons
+ (setq conses (cons cons conses)))))
+ (reverse conses)))
+
+(defun shm-case-split-get-constructor ()
+ "Get the constructor at point."
+ (shm/reparse)
+ (let ((cons-pair (shm-node-ancestor-at-point (shm-current-node-pair)
+ (point))))
+ (goto-char (shm-node-end (cdr cons-pair)))
+ (or (search-forward "| " nil t 1)
+ (goto-char (point-max)))
+ cons-pair))
+
+;; Backend based on haskell-process.el
+
+(defun haskell-process-get-data-type (name)
+ "Get the data type definition of the given name."
+ (let ((reply
+ (haskell-process-queue-sync-request (haskell-process)
+ (format ":i %s\n" name))))
+ (car (split-string reply "[\n\t ]+-- Defined "))))
+
+(defun shm/case-split (name)
+ "Do a case split on NAME at point."
+ (interactive (list (read-from-minibuffer "Type: ")))
+ (save-excursion
+ (let ((column (current-column)))
+ (insert "case undefined ")
+ (shm-evaporate (- (point) (+ 1 (length "undefined")))
+ (- (point) 1))
+ (insert "of\n")
+ (indent-to (+ column 2))
+ (shm-case-split-insert-alts
+ (shm-case-split-alts-from-data-decl
+ (haskell-process-get-data-type name))))))
+
+(defun shm/expand-pattern (name)
+ "Expand a pattern match on a data type."
+ (interactive (list (read-from-minibuffer "Type: ")))
+ (save-excursion
+ (shm-case-split-insert-pattern
+ (shm-case-split-alts-from-data-decl
+ (haskell-process-get-data-type name)))))
+
+(provide 'shm-case-split)
diff --git a/elisp/shm-constraint.el b/elisp/shm-constraint.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-constraint.el
@@ -0,0 +1,87 @@
+;;; shm-constraint.el --- Constraint editing functions.
+
+;; 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 .
+
+;;; Code:
+
+(require 'shm-ast)
+
+(defun shm/modify-type-constraint ()
+ "Modify a type signatures constraint"
+ (interactive)
+ (let* ((pair (shm-current-node-pair))
+ (current-node (cdr pair)))
+ (if (shm-type-signature-with-constraint-p pair)
+ (shm-add-additional-type-constraint current-node)
+ (add-initial-type-constraint current-node))))
+
+(defun shm-add-additional-type-constraint (node)
+ (if (shm-constraint-has-parens-p node)
+ (progn
+ (shm-goto-end-of-constraint node)
+ (backward-char 1)
+ (insert ", "))
+ (goto-char (shm-node-start node))
+ (insert "(")
+ (shm-goto-end-of-constraint node)
+ (insert ", )")
+ (backward-char 1)))
+
+(defun add-initial-type-constraint (node)
+ (goto-char (shm-node-start node))
+ (insert " => ") (backward-char 4))
+
+(defun shm-top-level-type-decl-p (node-pair)
+ (let ((current-node (cdr node-pair)))
+ (if (and (not (shm-has-parent-with-matching-type-p node-pair))
+ (string= "Type SrcSpanInfo" (shm-node-type current-node))) t)))
+
+(defun shm-type-signature-with-constraint-p (pair)
+ (let ((current-node (cdr pair)))
+ (and (shm-top-level-type-decl-p pair)
+ (shm-node-syntax-contains-regex "=>" current-node))))
+
+(defun shm-constraint-has-parens-p (node)
+ (let* ((syntax (shm-concrete-syntax-for-node node))
+ (constraint-syntax (car (split-string syntax "=>"))))
+ (string-match-p ")" constraint-syntax)))
+
+(defun shm-goto-end-of-constraint (node)
+ "Set point to the first white-space character between the end of the type constraint and the '=>'"
+ (goto-char (+ (shm-node-start node)
+ (shm-node-syntax-contains-regex "=>" node)))
+ (re-search-backward "^\\|[^[:space:]]") (goto-char (+ (point) 1)))
+
+(defun shm-node-syntax-contains-regex (regex node)
+ "check the syntax of a node for an occurrence of pattern"
+ (let ((node-concrete-syntax (shm-concrete-syntax-for-node node)))
+ (string-match-p regex node-concrete-syntax)))
+
+(defun shm-concrete-syntax-for-node (node)
+ "Get the concrete syntax of the node"
+ (buffer-substring-no-properties
+ (shm-node-start (shm-current-node))
+ (shm-node-end (shm-current-node))))
+
+(defun shm-has-parent-with-matching-type-p (node-pair)
+ (let* ((current (cdr node-pair))
+ (parent-pair (shm-node-parent node-pair (shm-node-type current)))
+ (parent (cdr parent-pair)))
+ (if parent
+ (if (string= (shm-node-type current)
+ (shm-node-type parent)) t))))
+
+(provide 'shm-constraint)
diff --git a/elisp/shm-customizations.el b/elisp/shm-customizations.el
--- a/elisp/shm-customizations.el
+++ b/elisp/shm-customizations.el
@@ -1,4 +1,4 @@
-;;; shm-customizations.el --- Customizations for structured-haskell-mode
+;;; shm-customizations.el --- Structured Haskell Mode
;; Copyright (c) 2014 Chris Done. All rights reserved.
@@ -17,6 +17,29 @@
;;; Code:
+
+;; Group
+
+(defgroup shm nil
+ "Structured editing mode for Haskell"
+ :group 'haskell)
+
+
+;; Faces
+
+(defface shm-quarantine-face
+ '((((class color)) :background "#443333"))
+ "Face for quarantines."
+ :group 'shm)
+
+(defface shm-current-face
+ '((((class color)) :background "#373737"))
+ "Face for the current node."
+ :group 'shm)
+
+
+;; Customizations
+
(defcustom shm-auto-insert-skeletons
t
"Auto-insert skeletons for case, if, etc."
@@ -94,10 +117,56 @@
:group 'shm
:type 'boolean)
+(defcustom shm-colon-enabled
+ nil
+ "Do special insertion of colons."
+ :group 'shm
+ :type 'boolean)
+
+(defcustom shm-prevent-parent-deletion
+ t
+ "Prevent backspacing over parent heads that would break the
+syntax."
+ :group 'shm
+ :type 'boolean)
+
(defcustom shm-idle-timeout
0.2
"Number of seconds before re-parsing."
:group 'shm
:type 'string)
+(defcustom shm-indent-point-after-adding-where-clause
+ nil
+ "Whether to indent point to the next line when inseting where clause, e.g.
+| being a point:
+
+foo x = ...
+ where
+ |
+
+when option is t, as opposed to
+
+foo x = ...
+ where |
+
+when option is nil.
+"
+ :group 'shm
+ :type 'boolean)
+
+(defcustom shm-pragmas
+ '("LANGUAGE" "OPTIONS_GHC" "INCLUDE" "DEPRECATED" "WARNING"
+ "INLINE" "NOINLINE" "INLINABLE" "CONLIKE" "LINE" "RULES"
+ "SPECIALIZE" "UNPACK" "SOURCE")
+ "Pragmas supported."
+ :group 'shm
+ :type 'list)
+
+
+;; Provide
+
(provide 'shm-customizations)
+
+;;; shm.el ends here
+;; End:
diff --git a/elisp/shm-debug.el b/elisp/shm-debug.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-debug.el
@@ -0,0 +1,93 @@
+;;; shm-debug.el --- Debugging utilities
+
+;; 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 .
+
+;;; Code:
+
+(require 'shm-layout)
+
+(defun shm/test-exe ()
+ "Test that the executable is working properly."
+ (interactive)
+ (let ((region (shm-decl-points)))
+ (when (get-buffer "*shm-scratch-test*")
+ (with-current-buffer
+ (switch-to-buffer "*shm-scratch-test*")
+ (erase-buffer)))
+ (call-process-region (car region)
+ (cdr region)
+ shm-program-name
+ nil
+ "*shm-scratch-test*"
+ nil
+ "parse"
+ "decl")
+ (switch-to-buffer "*shm-scratch-test*")
+ (when (save-excursion (goto-char (point-min))
+ (looking-at "structured-haskell-mode:"))
+ (insert "\nNote: If you got a parse error for valid code
+that is using fairly new (read: couple years) a GHC extension,
+you are probably hitting the fact that haskell-src-exts doesn't
+parse a bunch of newer GHC extensions. SHM does not do any
+parsing itself, it uses HSE. There are some patches in the HSE
+repo, provided as pull requests, which you can try applying to a
+local copy of HSE and then recompile SHM with the new version.
+
+See also: https://github.com/haskell-suite/haskell-src-exts/issues/19
+
+And: https://github.com/chrisdone/structured-haskell-mode/blob/master/src/Main.hs"))))
+
+(defun shm/describe-node (&optional node)
+ "Present a description of the current node in the minibuffer.
+
+Very useful for debugging and also a bit useful for newbies."
+ (interactive)
+ (let ((node (or node (shm-current-node))))
+ (if node
+ (message "%s" (shm-node-description node))
+ (error "No current node."))))
+
+(defun shm-node-description (node)
+ "Generate a description of the given node suitable to be put in
+ the minibuffer. If no documentation can be found, it generates
+ a reasonable string instead."
+ (let* ((type-doc (assoc (shm-node-type-name node)
+ shm-ast-documentation))
+ (con-doc (assoc (symbol-name (shm-node-cons node))
+ (cddr type-doc))))
+ (if type-doc
+ (format "Node type: “%s”: %s, case: %s\n%s"
+ (nth 0 type-doc)
+ (nth 1 type-doc)
+ (if con-doc
+ (format "“%s”: %s"
+ (nth 0 con-doc)
+ (nth 1 con-doc))
+ (format "“%s” (no more info)"
+ (shm-node-cons node)))
+ (shm-node-string node))
+ (format "Node type: “%s” (no more info)"
+ (shm-node-type-name node)))))
+
+(defun shm-node-string (node)
+ "Get the string of the NODE."
+ (save-excursion
+ (shm-kill-node 'buffer-substring-no-properties
+ node
+ nil
+ t)))
+
+(provide 'shm-debug)
diff --git a/elisp/shm-deletion.el b/elisp/shm-deletion.el
deleted file mode 100644
--- a/elisp/shm-deletion.el
+++ /dev/null
@@ -1,182 +0,0 @@
-;;; shm-deletion.el --- Deletion 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 .
-
-;;; Code:
-
-(require 'shm-indentation)
-(require 'shm-nodes)
-(require 'shm-macros)
-(require 'shm-generic)
-(require 'shm-globals)
-(require 'shm-insertion)
-
-(defun shm/backward-kill-word ()
- "Kill the word backwards."
- (interactive)
- (let ((to-be-deleted (save-excursion (backward-word)
- (point))))
- (save-excursion
- (shm-appropriate-adjustment-point)
- (shm-adjust-dependents (point) (* -1 (- (point) to-be-deleted))))
- (backward-kill-word 1)))
-
-(defun shm/delete ()
- "Delete the current node."
- (interactive)
- (let ((current (shm-current-node))
- (inhibit-read-only t))
- (delete-region (shm-node-start current)
- (shm-node-end current))))
-
-(defun shm/del ()
- "Character deletion handler.
-
-Generally, we delete things in the current node. BUT, there are
-some things that we shouldn't delete, because they would cause
-parse errors that are rarely useful. For example:
-
- (|case x of _ -> _) -- where | indicates cursor.
-
-"
- (interactive)
- (shm-with-fallback
- delete-backward-char
- (cond
- ;; These cases are “gliders”. They simply move over the character
- ;; backwards. These could be handled all as one regular
- ;; expression, but in the interest of clarity—for now—they are left
- ;; as separate cases.
- ((and (shm-in-string)
- (looking-back "^[ ]*\\\\"))
- (let ((here (point)))
- (delete-region (search-backward-regexp "\\\\$")
- here)))
- ((and (looking-back "{-[ ]*")
- (looking-at "[ ]*-}"))
- (delete-region (search-backward-regexp "-")
- (progn (forward-char 1)
- (search-forward-regexp "-"))))
- ((and (looking-back "^{-#[ ]*")
- (looking-at "[ ]*#-}$"))
- (delete-region (search-backward-regexp "#")
- (progn (forward-char 1)
- (search-forward-regexp "#"))))
- ((looking-back "[()]") (shm-delete-or-glide "(" ")"))
- ((looking-back "[[]") (shm-delete-or-glide "\\[" "\\]"))
- ((looking-back "[]]") (shm-delete-or-glide "\\[" "\\]"))
- ((looking-back "[{}]") (shm-delete-or-glide "{" "}"))
- ((looking-back "[\"]") (shm-delete-or-glide "\"" "\""))
- ;; These kind of patterns block the parens of syntaxes that would
- ;; otherwise break everything, so, "if", "of", "case", "do",
- ;; etc. if deleted.
- ((and (looking-back "[^A-Zaz0-9_]do ?")
- (not (or (eolp)
- (looking-at "[])}]"))))
- nil) ; do nothing
- ((and (looking-back " <-")
- (not (or (eolp)
- (looking-at "[])}]"))))
- (forward-char -3))
- ((and (looking-back " <- ")
- (not (or (eolp)
- (looking-at "[])}]"))))
- (forward-char -4))
- ((looking-back "[^A-Zaz0-9_]of ?")
- (search-backward-regexp "[ ]*of"))
- ((or (looking-at "of$")
- (looking-at "of "))
- (forward-char -1))
- ((looking-back "[_ ]-> ?") (forward-char -3))
- ((looking-at "-> ?")
- (forward-char -1))
- ((looking-back "[^A-Zaz0-9_]then ?")
- (search-backward-regexp "[^ ][ ]*then")
- (unless (or (looking-at "$") (looking-at " "))
- (forward-char 1)))
- ((looking-back "[^A-Zaz0-9_]else ?")
- (search-backward-regexp "[^ ][ ]*else")
- (unless (or (looking-at "$") (looking-at " "))
- (forward-char 1)))
- ((looking-back "^module ?")
- (when (looking-at "[ ]*where$")
- (delete-region (line-beginning-position) (line-end-position))))
- ((looking-back "[^A-Zaz0-9_]if ?")
- nil) ; do nothing
- ((looking-back "[^A-Zaz0-9_]case ?")
- nil) ; do nothing
- ((and (looking-at "= ")
- (looking-back " "))
- (forward-char -1))
- ((or (and (looking-back " = ")
- (not (looking-at "$"))
- (not (looking-at " ")))
- (and (looking-back "=")
- (looking-at " ")))
- (search-backward-regexp "[ ]+=[ ]*"
- (line-beginning-position)
- t
- 1)
- (when (looking-back " ")
- (when (search-backward-regexp "[^ ]" (line-beginning-position)
- t 1)
- (forward-char 1))))
- ;; This is the base case, we assume that we can freely delete
- ;; whatever we're looking back at, and that the node will be able
- ;; to re-parse it.
- (t (save-excursion
- (shm-appropriate-adjustment-point)
- (shm-adjust-dependents (point) -1))
- (shm-delete-char))))
- (shm/init t))
-
-(defun shm-delete-or-glide (open close)
- "Delete the given OPEN/CLOSE delimiter, or simply glide over it
- if it isn't empty."
- (cond
- ;; If the delimiters are empty, we can delete the whole thing.
- ((shm-delimiter-empty open close)
- (let ((inhibit-read-only t))
- (shm-adjust-dependents (point) -2)
- (delete-region (1- (point))
- (1+ (point)))))
- ;; If the delimiters aren't empty and we're in a literal, then go
- ;; ahead and elete the character.
- ((and (shm-literal-insertion)
- (not (= (point) (1+ (shm-node-start (shm-current-node))))))
- (shm-delete-char))
- ;; Otherwise just glide over the character.
- (t
- (when (looking-back close)
- (forward-char -1)))))
-
-(defun shm-delete-char ()
- "Delete a character backwards or delete the region, if there is
-one active."
- (if (region-active-p)
- (delete-region (region-beginning)
- (region-end))
- (delete-region (1- (point))
- (point))))
-
-(defun shm-delimiter-empty (open close)
- "Is the current expression delimited by OPEN and CLOSE empty?"
- (and (looking-back open)
- (not (save-excursion (forward-char (* -1 (length open)))
- (looking-back "\\\\")))
- (looking-at close)))
-
-(provide 'shm-deletion)
diff --git a/elisp/shm-edit-string.el b/elisp/shm-edit-string.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-edit-string.el
@@ -0,0 +1,78 @@
+;;; shm-edit-string.el --- Editing strings
+
+;; 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 .
+
+;;; Code:
+
+(require 'shm-insert-del)
+(require 'shm-layout)
+
+(defvar shm-string-buffer nil
+ "The buffer of the string node that's currently being edited.")
+
+(defvar shm-string-node nil
+ "The string node that's currently being edited.")
+
+(defun shm/edit-string ()
+ "Edit the string at point."
+ (interactive)
+ (let ((current (shm-current-node))
+ (buffer (current-buffer))
+ (string (shm-kill-node 'buffer-substring-no-properties nil nil t)))
+ (goto-char (shm-node-start current))
+ (switch-to-buffer (get-buffer-create "*shm-string*"))
+ (erase-buffer)
+ (insert
+ (replace-regexp-in-string
+ "\\\\\"" "\""
+ (replace-regexp-in-string
+ "\\\\n" "\n"
+ (replace-regexp-in-string
+ "^\"\\(.*\\)\"$" "\\1"
+ (replace-regexp-in-string
+ "\\\\\n\\\\" ""
+ string)))))
+ (shm-edit-string-mode)
+ (set (make-local-variable 'shm-string-node)
+ current)
+ (set (make-local-variable 'shm-string-buffer)
+ buffer)
+ (goto-char (point-min))))
+
+(define-derived-mode shm-edit-string-mode
+ text-mode "String"
+ "Major mode for editing string content from a Haskell string.")
+
+(define-key shm-edit-string-mode-map (kbd "C-c C-c") 'shm-finish-editing-string)
+
+(defun shm-finish-editing-string ()
+ "Take the contents of the buffer and insert it back into the
+original node in the Haskell buffer, replacing the old one."
+ (interactive)
+ (let ((finish-string (buffer-string))
+ (buffer shm-string-buffer))
+ (quit-window)
+ (switch-to-buffer buffer)
+ (shm/delete)
+ (insert "\"\"")
+ (forward-char -1)
+ (save-excursion
+ (font-lock-fontify-region (line-beginning-position)
+ (line-end-position)))
+ (shm-insert-indented (lambda () (insert finish-string)))
+ (forward-char -1)))
+
+(provide 'shm-edit-string)
diff --git a/elisp/shm-evaporate.el b/elisp/shm-evaporate.el
--- a/elisp/shm-evaporate.el
+++ b/elisp/shm-evaporate.el
@@ -42,8 +42,7 @@
(let ((inhibit-modification-hooks t))
(when (and changed
(overlay-start o))
- (delete-region (overlay-start o)
- (overlay-end o))
+ (shm-evaporate-delete-text o beg end)
(delete-overlay o))))
(defun shm-evaporate-insert-before-hook (o changed beg end &optional len)
@@ -51,9 +50,14 @@
(let ((inhibit-modification-hooks t))
(when (and (not changed)
(overlay-start o))
- (delete-region (overlay-start o)
- (overlay-end o))
+ (shm-evaporate-delete-text o beg end)
(delete-overlay o))))
+
+(defun shm-evaporate-delete-text (o beg end)
+ "Delete the text associated with the evaporating slot."
+ (unless (eq this-command 'undo)
+ (delete-region (overlay-start o)
+ (overlay-end o))))
(provide 'shm-evaporate)
diff --git a/elisp/shm-generic.el b/elisp/shm-generic.el
deleted file mode 100644
--- a/elisp/shm-generic.el
+++ /dev/null
@@ -1,111 +0,0 @@
-;;; shm-generic.el --- Generic mode functions
-
-;; 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 .
-
-;;; Code:
-
-(require 'shm-types)
-(require 'shm-ast)
-
-(defun shm/reparse ()
- "Re-parse the current node.
-
-This is used on the reparsing timer, but also on commands that
-really need accurate AST information *right now*, so this will
-force a reparse immediately (if necessary)."
- (interactive)
- (shm-decl-ast t)
- (when (/= shm-last-point (point))
- (shm-set-node-overlay)))
-
-(defun shm/mark-node ()
- "Set the active mark to the current node."
- (interactive)
- (let ((current (shm-current-node)))
- (goto-char (shm-node-start current))
- (set-mark (shm-node-end current))))
-
-(defun shm/test-exe ()
- "Test that the executable is working properly."
- (interactive)
- (let ((region (shm-decl-points)))
- (when (get-buffer "*shm-scratch-test*")
- (with-current-buffer
- (switch-to-buffer "*shm-scratch-test*")
- (erase-buffer)))
- (call-process-region (car region)
- (cdr region)
- shm-program-name
- nil
- "*shm-scratch-test*"
- nil
- "parse"
- "decl")
- (switch-to-buffer "*shm-scratch-test*")
- (when (save-excursion (goto-char (point-min))
- (looking-at "structured-haskell-mode:"))
- (insert "\nNote: If you got a parse error for valid code
-that is using fairly new (read: couple years) a GHC extension,
-you are probably hitting the fact that haskell-src-exts doesn't
-parse a bunch of newer GHC extensions. SHM does not do any
-parsing itself, it uses HSE. There are some patches in the HSE
-repo, provided as pull requests, which you can try applying to a
-local copy of HSE and then recompile SHM with the new version.
-
-See also: https://github.com/haskell-suite/haskell-src-exts/issues/19
-
-And: https://github.com/chrisdone/structured-haskell-mode/blob/master/src/Main.hs"))))
-
-(defun shm/type-of-node ()
- (interactive)
- (let ((current (shm-current-node)))
- (cond
- ((or (string= (shm-node-type-name current) "Exp")
- (string= (shm-node-type-name current) "Decl")
- (string= (shm-node-type-name current) "Pat")
- (string= (shm-node-type-name current) "QOp"))
- (let ((type-info (shm-node-type-info current)))
- (if type-info
- (shm-present-type-info current type-info)
- (if (and shm-type-info-fallback-to-ghci
- (fboundp 'haskell-process-do-type))
- (haskell-process-do-type)
- (error "Unable to get type information for that node.")))))
- ((and (string= (shm-node-type-name current) "Name")
- (let ((parent-name (shm-node-type-name (cdr (shm-node-parent (shm-current-node-pair))))))
- (or (string= parent-name "Match")
- (string= parent-name "Decl"))))
- (let* ((node (cdr (shm-node-parent (shm-current-node-pair))))
- (type-info (shm-node-type-info node)))
- (if type-info
- (shm-present-type-info node type-info)
- (if (and shm-type-info-fallback-to-ghci
- (fboundp 'haskell-process-do-type))
- (haskell-process-do-type)
- (error "Unable to get type information for that node (tried the whole decl, too).")))))
- (t (error "Not an expression, operator, pattern binding or declaration.")))))
-
-(defun shm/describe-node (&optional node)
- "Present a description of the current node in the minibuffer.
-
-Very useful for debugging and also a bit useful for newbies."
- (interactive)
- (let ((node (or node (shm-current-node))))
- (if node
- (message "%s" (shm-node-description node))
- (error "No current node."))))
-
-(provide 'shm-generic)
diff --git a/elisp/shm-globals.el b/elisp/shm-globals.el
deleted file mode 100644
--- a/elisp/shm-globals.el
+++ /dev/null
@@ -1,47 +0,0 @@
-;;; shm-globals.el --- Global variables shared among modules
-
-;; 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 .
-
-;;; Code:
-
-(defvar shm-lighter " SHM?"
- "The lighter for structured Haskell mode.")
-
-(defvar shm-last-point 0
- "When moving around, the current node overlay will update
- according to where you are. But often you can shrink/expand the
- scope of the current node. This variable lets us avoid the node
- being reset by realising we haven't actually moved the point.")
-
-(defvar shm-parsing-timer nil
- "The timer used to re-parse every so often. The idle time can
- be configured with `shm-idle-timeout'.")
-
-(defvar shm-last-parse-start 0
- "This is used to avoid unnecessary work, if the start of the
- declaration hasn't changed, and the end (see
- `shm-last-parse-end') since we last parsed, don't bother
- re-parsing.")
-
-(defvar shm-last-parse-end 0
- "See `shm-last-parse-start' for explanation.")
-
-(defvar shm-last-yanked (list 0 0)
- "When yanking, some text will be inserted, when popping a
- yank (i.e. with M-y), you need to be able to erase the previous
- yank. This is simply a region.")
-
-(provide 'shm-globals)
diff --git a/elisp/shm-in.el b/elisp/shm-in.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-in.el
@@ -0,0 +1,60 @@
+;;; shm-in.el --- Are we in some thing.
+
+;; 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 .
+
+;;; Code:
+
+(defun shm-in-comment ()
+ "Are we currently in a comment?"
+ (save-excursion
+ (when (and (= (line-end-position)
+ (point))
+ (/= (line-beginning-position) (point)))
+ (forward-char -1))
+ (and (or (eq 'font-lock-comment-delimiter-face
+ (get-text-property (point) 'face))
+ (eq 'font-lock-doc-face
+ (get-text-property (point) 'face))
+ (eq 'font-lock-comment-face
+ (get-text-property (point) 'face))
+ (save-excursion (goto-char (line-beginning-position))
+ (looking-at "^\-\- ")))
+ ;; Pragmas {-# SPECIALIZE .. #-} etc are not to be treated as
+ ;; comments, even though they are highlighted as such
+ (not (save-excursion (goto-char (line-beginning-position))
+ (looking-at "{-# "))))))
+
+(defun shm-in-string ()
+ "Are we in a string?"
+ (save-excursion
+ (when (looking-at "\"")
+ (forward-char -1))
+ (eq 'font-lock-string-face
+ (get-text-property (point) 'face))))
+
+(defun shm-in-char ()
+ "Are we in a char literal?"
+ (save-excursion
+ (and (looking-at "'")
+ (looking-back "'"))))
+
+(defun shm-literal-insertion ()
+ "Should a node have literal insertion?"
+ (or (shm-in-string)
+ (shm-in-char)
+ (shm-in-comment)))
+
+(provide 'shm-in)
diff --git a/elisp/shm-indent.el b/elisp/shm-indent.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-indent.el
@@ -0,0 +1,472 @@
+;;; shm-indent.el --- Indentation commands
+
+;; 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 .
+
+;;; Code:
+
+(require 'shm-layout)
+
+(defun shm/delete-indentation ()
+ "Send the node up one line."
+ (interactive)
+ (if (looking-back "^[ ]+")
+ (cond
+ ((or (looking-at "then[] [{}\"'()]")
+ (looking-at "else[] [{}\"'()]"))
+ (delete-indentation))
+ ((looking-at "[ ]*$")
+ (delete-indentation))
+ (t
+ (let ((current (shm-current-node)))
+ (let ((old-column (current-column)))
+ (delete-region (line-beginning-position) (point))
+ (delete-char -1)
+ (let ((new-column (current-column)))
+ (indent-rigidly (line-end-position)
+ (shm-node-end current)
+ (abs (- old-column new-column))))))
+ (when nil
+ (let ((string (shm-kill-node 'buffer-substring-no-properties)))
+ (delete-indentation)
+ (insert " ")
+ (shm-insert-indented
+ (lambda ()
+ (insert string)))))))
+ (delete-indentation)))
+
+(defun shm/swing-down ()
+ "Swing the children of the current node downwards.
+
+hai = do foo bar
+ mu zot
+
+With the cursor on `do', this will produce:
+
+hai = do
+ foo bar
+ mu zot
+"
+ (interactive)
+ (let* ((current-pair (shm-current-node-pair))
+ (current (cdr current-pair)))
+ (cond
+ ((eq (shm-node-cons current)
+ 'Do)
+ (save-excursion
+ (let ((new-column (shm-get-swing-column current)))
+ (goto-char (shm-node-start current))
+ (forward-word 1)
+ (search-forward " ")
+ (let ((old-column (current-column)))
+ (insert "\n")
+ (indent-rigidly (point)
+ (shm-node-end current)
+ (- old-column))
+ (indent-rigidly (point)
+ (shm-node-end current)
+ new-column)))
+ (shm/reparse)))
+ ((eq (shm-node-cons current)
+ 'Var)
+ (let* ((next-pair (shm-node-next current-pair))
+ (parent-pair (shm-node-parent current-pair))
+ (start (shm-node-start-column (cdr parent-pair))))
+ (let ((swing-string
+ (shm-kill-region 'buffer-substring-no-properties
+ (shm-node-start (cdr next-pair))
+ (shm-node-end (cdr parent-pair))
+ nil)))
+ (shm/reparse)
+ (forward-char -1)
+ (shm-newline)
+ (indent-to (+ (shm-indent-spaces)
+ start))
+ (shm-insert-indented (lambda () (insert swing-string))))))
+ (t
+ (error "Don't know how to swing that kind of expression.")))))
+
+(defun shm-get-swing-column (node)
+ "Get the column that a node would be newline-indented to."
+ (save-excursion
+ (let ((start (shm-node-start node)))
+ (goto-char start)
+ (shm-newline-indent nil nil)
+ (let ((column (current-column)))
+ (delete-region start (point))
+ column))))
+
+(defun shm/swing-up ()
+ "Swing the children of the current node upwards.
+
+hai = do
+ foo bar
+ mu zot
+
+With the cursor on `do', this will produce:
+
+hai = do foo bar
+ mu zot
+"
+ (interactive)
+ (let* ((current-pair (shm-current-node-pair))
+ (current (cdr current-pair)))
+ (cond
+ ((eq (shm-node-cons current)
+ 'Do)
+ (let ((swing-string
+ (shm-kill-node 'buffer-substring-no-properties
+ current
+ (shm-node-start (shm-node-child current-pair)))))
+ (delete-indentation)
+ (if (looking-at " ")
+ (forward-char 1)
+ (insert " "))
+ (shm-insert-indented (lambda () (insert swing-string)))))
+ (t
+ (error "Don't know how to swing that kind of expression.")))))
+
+(defun shm/newline-indent ()
+ "Make a newline and indent, making sure to drag anything down, re-indented
+ with it."
+ (interactive)
+ (cond
+ ((and (shm-in-string)
+ (not (= (shm-node-start (shm-current-node))
+ (point))))
+ (let ((column (shm-node-start-column (shm-current-node))))
+ (insert "\\")
+ (shm-newline)
+ (indent-to column)
+ (insert "\\")))
+ ((and (looking-at "[^])}\"]") ;; This is a cheap solution. It
+ ;; could use node boundaries
+ ;; instead.
+ (not (looking-at "$"))
+ (looking-back " "))
+ (shm/reparse)
+ (let ((newline-string (buffer-substring-no-properties (point)
+ (shm-node-end (shm-current-node))))
+ ;; This is like (line-end-position), but if the line ends in
+ ;; a closing delimiter like ), then *really* the "end" of
+ ;; the thing we're dragging should be inside these
+ ;; delimiters.
+ (end-position (save-excursion
+ (goto-char (line-end-position))
+ (when (looking-back "[])}\"]+")
+ (search-backward-regexp "[^])}\"]")
+ (forward-char 1))
+ (point))))
+ ;; If we're going to drag something, that means the *real* parent
+ ;; should encompass whatever we're going to drag, and that should
+ ;; be at or beyond the end of the line.
+ (unless (looking-at "\\(=>\\|->\\)")
+ (let ((current (shm-current-node-pair)))
+ (while (and (not (>= (shm-node-end (cdr current))
+ end-position))
+ (/= (car current)
+ (car (shm-node-ancestor-at-point current
+ (shm-node-start (cdr current))))))
+ (shm/goto-parent)
+ (setq current (shm-current-node-pair)))))
+ ;; If there's some stuff trailing us, then drag that with us.
+ (let* ((current (shm-current-node))
+ (old-column (shm-node-start-column current)))
+ (shm-newline-indent t
+ newline-string)
+ (let ((new-column (current-column)))
+ (indent-rigidly (point)
+ (shm-node-end current)
+ (- (abs (- old-column new-column))))))))
+ ;; Otherwise just do the indent.
+ (t (shm/reparse)
+ (shm-newline-indent nil)))
+ (shm/reparse))
+
+(defun shm-newline-indent (dragging &optional newline-string)
+ "Go to the next logical line from the current node at the right column.
+
+This function uses the node's type to decode how to indent, and
+in some cases will insert commas and things like for tuples and
+lists.
+
+DRAGGING indicates whether this indent will drag a node downwards."
+ (let* ((current-pair (shm-current-node-pair))
+ (current (cdr current-pair))
+ (parent-pair (shm-node-parent current-pair))
+ (parent (cdr parent-pair))
+ (inhibit-read-only t))
+ (cond
+ ((or (string= (shm-node-type-name current)
+ "ImportSpecList")
+ (and (string= (shm-node-type-name current)
+ "ModuleName")
+ (looking-at "$")
+ parent
+ (string= (shm-node-type-name parent)
+ "ImportDecl")))
+ (shm-newline)
+ (insert "import "))
+ ((and (or (string= "Type" (shm-node-type-name current))
+ (string= "Context" (shm-node-type-name current)))
+ (eq 'TypeSig (shm-node-cons (shm-decl-node (point)))))
+ (let ((column (save-excursion (search-backward-regexp " :: ")
+ (+ 4 (current-column)))))
+ (shm-newline)
+ (indent-to column)
+ (when (and dragging
+ (or (string-match "^=>" newline-string)
+ (string-match "^->" newline-string)))
+ (delete-region (- (point) 3) (point)))))
+ ;; List comprehensions
+ ((and parent
+ (eq 'QualStmt (shm-node-cons parent)))
+ (shm-newline)
+ (indent-to (1- (shm-node-start-column parent)))
+ (insert ",")
+ (shm-set-node-overlay parent-pair))
+ ;; When inside a list, indent to the list's position with an
+ ;; auto-inserted comma.
+ ((and parent
+ (or (eq 'List (shm-node-cons parent))
+ (eq 'Tuple (shm-node-cons parent))
+ (eq 'QualStmt (shm-node-cons parent))))
+ (let* ((first-item-on-line (save-excursion
+ (goto-char (shm-node-start current))
+ (search-backward-regexp "[[,][ ]*")
+ (= (current-column)
+ (shm-node-start-column parent)))))
+ (shm-newline)
+ (indent-to (shm-node-start-column parent))
+ (insert ",")
+ (when first-item-on-line
+ (insert (make-string (- (shm-node-start-column current)
+ (current-column))
+ ? )))
+ (shm-set-node-overlay parent-pair)))
+ ;; Lambdas indents k spaces inwards
+ ((eq 'Lambda (shm-node-cons current))
+ (shm-newline)
+ (indent-to (+ (shm-indent-spaces) (shm-node-start-column current))))
+ ;; Indentation for RHS
+ ((and parent
+ (eq 'App (shm-node-cons parent))
+ (= (shm-node-start current)
+ (shm-node-start parent)))
+ (let ((ancestor-parent (shm-node-parent
+ (shm-node-ancestor-at-point current-pair (point))))
+ (decl (shm-node-parent current-pair "Decl SrcSpanInfo")))
+ (shm-newline)
+ (indent-to (+ (shm-indent-spaces)
+ (shm-node-start-column (cdr decl))))))
+ ;; Indentation for function application.
+ ((and parent
+ (or (eq 'App (shm-node-cons parent))
+ (eq 'TyApp (shm-node-cons parent))))
+ (let ((column
+ (save-excursion
+ (if (/= (shm-node-start-line current)
+ (shm-node-start-line parent))
+ (shm-node-start-column current)
+ (progn (shm/goto-parent)
+ (forward-sexp)
+ (1+ (current-column))))))
+ (previous
+ (when (looking-back " ")
+ (save-excursion
+ (search-backward-regexp "[ ]+"
+ (line-beginning-position)
+ t
+ 1)
+ (let ((prev (shm-current-workable-node)))
+ (when (and (= (car (shm-node-parent prev))
+ (car parent-pair))
+ (/= (shm-node-start parent)
+ (shm-node-start (cdr prev))))
+ prev))))))
+ (cond
+ (previous
+ (shm-newline)
+ (indent-to (shm-node-start-column (cdr previous))))
+ ((and (or (= column (current-column))
+ (= column (+ (shm-node-start-column parent)
+ (shm-indent-spaces))))
+ (/= column (shm-node-start-column parent)))
+ (shm-newline)
+ (indent-to (+ (shm-node-start-column parent)
+ (shm-indent-spaces))))
+ (t
+ (shm-newline)
+ (indent-to column)))))
+ ;; Indent for sum types
+ ((or (and parent
+ (eq 'DataDecl (shm-node-cons parent)))
+ (eq 'ConDecl (shm-node-cons current)))
+ (shm-newline)
+ (indent-to (shm-node-start-column current))
+ (delete-char -2)
+ (insert "| "))
+ ;; Auto-insert commas for field updates
+ ((or (string= "FieldUpdate" (shm-node-type-name current))
+ (string= "FieldDecl" (shm-node-type-name current))
+ (string= "ExportSpec" (shm-node-type-name current))
+ (string= "ImportSpec" (shm-node-type-name current)))
+ ;; This is hacky because HSE doesn't have special nodes for the
+ ;; record and the update in record {update} and so we have to
+ ;; figure out where the { starts. There is some additional
+ ;; information in HSE's trees, but I haven't thought of a nice
+ ;; way to extract that yet.
+ (goto-char (shm-node-end parent))
+ (backward-sexp)
+ (let ((column (current-column)))
+ (goto-char (shm-node-end current))
+ (shm-newline)
+ (indent-to column)
+ (insert ",")
+ (insert (make-string (abs (- (shm-node-start-column current)
+ (1+ column)))
+ ? ))
+ (shm-auto-insert-field-prefix current parent)
+ (shm/init)))
+ ((and parent
+ (eq 'Lambda (shm-node-cons parent)))
+ (cond
+ ((eq shm-lambda-indent-style 'leftmost-parent)
+ (let ((leftmost-parent (cdr (shm-find-furthest-parent-on-line parent-pair))))
+ (shm-newline)
+ (indent-to (+ (shm-indent-spaces)
+ (shm-node-indent-column leftmost-parent)))))
+ (t (shm-newline)
+ (indent-to (+ (shm-indent-spaces)
+ (shm-node-start-column parent))))))
+ ;; Guards | foo = …
+ ((or (string= "GuardedRhs" (shm-node-type-name current))
+ (string= "GuardedAlt" (shm-node-type-name current)))
+ (shm-newline)
+ (indent-to (shm-node-start-column current))
+ (insert "| "))
+ ;; Indent after or at the = (an rhs).
+ ((and parent
+ (or (string= "Rhs" (shm-node-type-name parent))
+ (string= "Rhs" (shm-node-type-name current))
+ (string= "GuardedAlt" (shm-node-type-name parent))
+ (string= "GuardedRhs" (shm-node-type-name parent))))
+ (shm-newline)
+ (indent-to (+ (shm-indent-spaces)
+ (shm-node-start-column (cdr (shm-node-parent parent-pair))))))
+ ;; When in a field update.
+ ((and parent
+ (string= "FieldUpdate" (shm-node-type-name parent)))
+ (shm-newline)
+ (indent-to (+ (shm-node-start-column parent)
+ (shm-indent-spaces))))
+ ;; When in an alt list
+ ((and parent
+ (string= "GuardedAlts" (shm-node-type-name current)))
+ (shm-newline)
+ (indent-to (+ (shm-node-start-column parent)
+ (shm-indent-spaces))))
+ ;; When in a case alt.
+ ((and parent
+ (string= "GuardedAlts" (shm-node-type-name parent)))
+ (shm-newline)
+ (let ((alt (cdr (shm-node-parent parent-pair))))
+ (indent-to (+ (shm-node-start-column alt)
+ (shm-indent-spaces)))))
+ ;; Copy infix operators similar to making new list/tuple
+ ;; separators
+ ((and parent
+ (eq 'InfixApp (shm-node-cons parent)))
+ (let* ((operand-pair (shm-node-previous current-pair))
+ (operand (cdr operand-pair))
+ (string (buffer-substring-no-properties (shm-node-start operand)
+ (shm-node-end operand))))
+ (cond
+ (dragging
+ (shm-newline)
+ (indent-to (shm-node-start-column parent)))
+ ((save-excursion (goto-char (shm-node-end operand))
+ (= (point) (line-end-position)))
+ (insert " " string)
+ (shm-newline)
+ (indent-to (shm-node-start-column current)))
+ (t
+ (shm-newline)
+ (indent-to (shm-node-start-column operand))
+ (insert string " ")))))
+ ;; Infix operators
+ ((and parent
+ (eq 'InfixApp (shm-node-cons parent)))
+ (shm-newline)
+ (indent-to (+ (shm-node-start-column parent))))
+ ;; ((eq 'Alt (shm-node-cons current))
+ ;; (shm-newline)
+ ;; (indent-to (shm-node-start-column current))
+ ;; (when shm-auto-insert-skeletons
+ ;; (save-excursion (insert "_ -> undefined"))
+ ;; (shm-evaporate (point) (+ (point) 1))
+ ;; (shm-evaporate (+ (point) (length "_ -> "))
+ ;; (+ (point) (length "_ -> undefined")))))
+ ;; Commenting out this behaviour for now
+ ;; ((string= "Match" (shm-node-type-name current))
+ ;; (let ((name (cdr (shm-node-child-pair current-pair))))
+ ;; (shm-newline)
+ ;; (indent-to (shm-node-start-column current))
+ ;; (insert (buffer-substring-no-properties (shm-node-start name)
+ ;; (shm-node-end name))
+ ;; " ")))
+ ;; Default indentation just copies the current node's indentation
+ ;; level. Generally works reliably, but has less than favourable
+ ;; indentation sometimes. It just serves as a catch-all.
+ (t
+ (shm-newline)
+ (indent-to (shm-node-start-column current))))))
+
+(defun shm-auto-insert-field-prefix (current parent)
+ "Auto insert prefixes of fields in record declarations. Example:
+
+data Person = Person
+ { personAge :: Int
+ , person|
+
+"
+ (when (string= "FieldDecl" (shm-node-type-name current))
+ (let* ((cur-substr
+ (save-excursion
+ (goto-char (shm-node-start current))
+ (buffer-substring-no-properties (point)
+ (progn (forward-word 1)
+ (point)))))
+ (type-name
+ (save-excursion
+ (goto-char (shm-node-start parent))
+ (buffer-substring-no-properties (point)
+ (progn (forward-word 1)
+ (point)))))
+ (prefix
+ (if (string-match "\\([A-Z]\\)\\(.*\\)"
+ type-name)
+ (concat (downcase (match-string 1 type-name))
+ (match-string 2 type-name))
+ type-name)))
+ (when (string-prefix-p prefix cur-substr)
+ (insert prefix)))))
+
+(defun shm-newline ()
+ "Normal `newline' does funny business. What we want is to
+literally insert a newline and no more."
+ (insert "\n"))
+
+(provide 'shm-indent)
diff --git a/elisp/shm-indentation.el b/elisp/shm-indentation.el
deleted file mode 100644
--- a/elisp/shm-indentation.el
+++ /dev/null
@@ -1,636 +0,0 @@
-;;; shm-indentation.el --- Indentation functions
-
-;; 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 .
-
-;;; Code:
-
-(require 'shm-nodes)
-(require 'shm-navigation)
-
-(defun shm/delete-indentation ()
- "Send the node up one line."
- (interactive)
- (if (looking-back "^[ ]+")
- (cond
- ((or (looking-at "then[] [{}\"'()]")
- (looking-at "else[] [{}\"'()]"))
- (delete-indentation))
- ((looking-at "[ ]*$")
- (delete-indentation))
- (t (let ((string (shm-kill-node 'buffer-substring-no-properties)))
- (delete-indentation)
- (insert " ")
- (shm-insert-indented
- (lambda ()
- (insert string))))))
- (delete-indentation)))
-
-(defun shm/swing-down ()
- "Swing the children of the current node downwards.
-
-hai = do foo bar
- mu zot
-
-With the cursor on `do', this will produce:
-
-hai = do
- foo bar
- mu zot
-"
- (interactive)
- (let* ((current-pair (shm-current-node-pair))
- (current (cdr current-pair)))
- (cond
- ((eq (shm-node-cons current)
- 'Do)
- (let ((swing-string
- (shm-kill-node 'buffer-substring-no-properties
- current
- (shm-node-start (shm-node-child current-pair)))))
- (shm/newline-indent)
- (shm-insert-indented (lambda () (insert swing-string)))))
- ((eq (shm-node-cons current)
- 'Var)
- (let* ((next-pair (shm-node-next current-pair))
- (parent-pair (shm-node-parent current-pair))
- (start (shm-node-start-column (cdr parent-pair))))
- (let ((swing-string
- (shm-kill-region 'buffer-substring-no-properties
- (shm-node-start (cdr next-pair))
- (shm-node-end (cdr parent-pair))
- nil)))
- (shm/reparse)
- (forward-char -1)
- (newline)
- (indent-to (+ (shm-indent-spaces)
- start))
- (shm-insert-indented (lambda () (insert swing-string))))))
- (t
- (error "Don't know how to swing that kind of expression.")))))
-
-(defun shm/swing-up ()
- "Swing the children of the current node upwards.
-
-hai = do
- foo bar
- mu zot
-
-With the cursor on `do', this will produce:
-
-hai = do foo bar
- mu zot
-"
- (interactive)
- (let* ((current-pair (shm-current-node-pair))
- (current (cdr current-pair)))
- (cond
- ((eq (shm-node-cons current)
- 'Do)
- (let ((swing-string
- (shm-kill-node 'buffer-substring-no-properties
- current
- (shm-node-start (shm-node-child current-pair)))))
- (delete-indentation)
- (if (looking-at " ")
- (forward-char 1)
- (insert " "))
- (shm-insert-indented (lambda () (insert swing-string)))))
- (t
- (error "Don't know how to swing that kind of expression.")))))
-
-(defun shm/newline-indent ()
- "Make a newline and indent, making sure to drag anything down, re-indented
- with it."
- (interactive)
- (cond
- ((and (shm-in-string)
- (not (= (shm-node-start (shm-current-node))
- (point))))
- (let ((column (shm-node-start-column (shm-current-node))))
- (insert "\\")
- (newline)
- (indent-to column)
- (insert "\\")))
- ((and (looking-at "[^])}\"]") ;; This is a cheap solution. It
- ;; could use node boundaries
- ;; instead.
- (not (looking-at "$"))
- (looking-back " "))
- ;; If there's some stuff trailing us, then drag that with us.
- (let ((newline-string (shm-kill-node 'buffer-substring-no-properties))
- (point (point)))
- (shm-newline-indent t)
- (shm-insert-indented
- (lambda ()
- (insert newline-string)))))
- ;; Otherwise just do the indent.
- (t (shm-newline-indent nil))))
-
-(defun shm/goto-where ()
- "Either make or go to a where clause of the current right-hand-side."
- (interactive)
- (let ((node-pair (shm-current-node-pair))
- (vector (shm-decl-ast)))
- (loop for i
- downfrom (car node-pair)
- to -1
- until (or (= i -1)
- (let ((node (elt vector i)))
- (and (string= "Rhs"
- (shm-node-type-name node))
- (<= (shm-node-start node)
- (shm-node-start (cdr node-pair)))
- (>= (shm-node-end node)
- (shm-node-end (cdr node-pair))))))
- finally (return
- (when (>= i 0)
- (let ((rhs (elt vector i)))
- (goto-char (shm-node-end rhs))
- (cond
- ((looking-at "[\n ]*where")
- (search-forward-regexp "where[ \n]*"))
- (t
- (unless (= (line-beginning-position) (point))
- (newline))
- (indent-to
- (+ 2
- (shm-node-start-column
- (cdr (shm-node-parent (cons i rhs))))))
- (insert "where ")))))))))
-
-(defun shm/tab ()
- "Either indent if at the start of a line, or jump to the next
- slot."
- (interactive)
- (cond
- ((save-excursion (goto-char (line-beginning-position))
- (looking-at "^[ ]*$"))
- (shm/simple-indent))
- (t
- (shm/jump-to-slot))))
-
-(defun shm/backtab ()
- "Either de-indent if at the start of a line, or jump to the previous
- slot."
- (interactive)
- (cond
- ((save-excursion (goto-char (line-beginning-position))
- (looking-at "^[ ]*$"))
- (shm/simple-indent-backtab))
- (t
- (shm/jump-to-previous-slot))))
-
-(defun shm/simple-indent ()
- "Space out to under next visible indent point.
-Indent points are positions of non-whitespace following whitespace in
-lines preceeding point. A position is visible if it is to the left of
-the first non-whitespace of every nonblank line between the position and
-the current line. If there is no visible indent point beyond the current
-column, `tab-to-tab-stop' is done instead."
- (interactive)
- (let* ((start-column (current-column))
- (invisible-from nil) ; `nil' means infinity here
- (indent
- (catch 'shm-simple-indent-break
- (save-excursion
- (while (progn (beginning-of-line)
- (not (bobp)))
- (forward-line -1)
- (if (not (looking-at "[ \t]*\n"))
- (let ((this-indentation (current-indentation)))
- (if (or (not invisible-from)
- (< this-indentation invisible-from))
- (if (> this-indentation start-column)
- (setq invisible-from this-indentation)
- (let ((end (line-beginning-position 2)))
- (move-to-column start-column)
- ;; Is start-column inside a tab on this line?
- (if (> (current-column) start-column)
- (backward-char 1))
- (or (looking-at "[ \t]")
- (skip-chars-forward "^ \t" end))
- (skip-chars-forward " \t" end)
- (let ((col (current-column)))
- (throw 'shm-simple-indent-break
- (if (or (= (point) end)
- (and invisible-from
- (> col invisible-from)))
- invisible-from
- col)))))))))))))
- (if indent
- (let ((opoint (point-marker)))
- (indent-line-to indent)
- (if (> opoint (point))
- (goto-char opoint))
- (set-marker opoint nil))
- (tab-to-tab-stop))))
-
-(defun shm/simple-indent-backtab ()
- "Indent backwards. Dual to `shm-simple-indent'."
- (interactive)
- (let ((current-point (point))
- (i 0)
- (x 0))
- (goto-char (line-beginning-position))
- (save-excursion
- (while (< (point) current-point)
- (shm/simple-indent)
- (setq i (+ i 1))))
- (while (< x (- i 1))
- (shm/simple-indent)
- (setq x (+ x 1)))))
-
-(defun shm/simple-indent-newline-same-col ()
- "Make a newline and go to the same column as the current line."
- (interactive)
- (let ((point (point)))
- (let ((start-end
- (save-excursion
- (let* ((start (line-beginning-position))
- (end (progn (goto-char start)
- (search-forward-regexp
- "[^ ]" (line-end-position) t 1))))
- (when end (cons start (1- end)))))))
- (if start-end
- (progn (newline)
- (insert (buffer-substring-no-properties
- (car start-end) (cdr start-end))))
- (newline)))))
-
-(defun shm/simple-indent-newline-indent ()
- "Make a newline on the current column and indent on step."
- (interactive)
- (shm/simple-indent-newline-same-col)
- (insert (make-string (shm-indent-spaces) ? )))
-
-(defun shm-appropriate-adjustment-point ()
- "Go to the appropriate adjustment point.
-
-This is called before calling `shm-adjust-dependents', because some places, e.g.
-
-zoo = do
- bar
- mu
-
-If the point is at 'z', then we should *not* move 'bar' or 'mu',
-even though we normally would. To avoid doing this, we use a very
-simple but 90% effective (100% is rather hard, will not be
-appearing in a beta version) heuristic. We jump to here:
-
-zoo| = do
- bar
- mu
-
-And use our normal adjustment test there. After all, only thing
-after 'zoo' are *really* dependent."
- (let ((current (shm-current-node)))
- (when (and current
- (<= (shm-node-end current) (line-end-position)))
- (goto-char (shm-node-end current)))))
-
-(defun shm-newline-indent (dragging)
- "Go to the next logical line from the current node at the right column.
-
-This function uses the node's type to decode how to indent, and
-in some cases will insert commas and things like for tuples and
-lists.
-
-DRAGGING indicates whether this indent will drag a node downwards."
- (let* ((current-pair (shm-current-node-pair))
- (current (cdr current-pair))
- (parent-pair (shm-node-parent current-pair))
- (parent (cdr parent-pair))
- (inhibit-read-only t))
- (cond
- ((or (string= (shm-node-type-name current)
- "ImportSpecList")
- (and (string= (shm-node-type-name current)
- "ModuleName")
- (looking-at "$")
- parent
- (string= (shm-node-type-name parent)
- "ImportDecl")))
- (newline)
- (insert "import "))
- ;; When inside a list, indent to the list's position with an
- ;; auto-inserted comma.
- ((and parent
- (eq 'List (shm-node-cons parent)))
- (newline)
- (indent-to (shm-node-start-column parent))
- (insert ",")
- (shm-set-node-overlay parent-pair))
- ;; Lambdas indents k spaces inwards
- ((eq 'Lambda (shm-node-cons current))
- (newline)
- (indent-to (+ (shm-indent-spaces) (shm-node-start-column current))))
- ;; Indentation for function application.
- ((and parent
- (or (eq 'App (shm-node-cons parent))
- (eq 'TyApp (shm-node-cons parent))))
- (let ((column
- (save-excursion
- (shm/goto-parent)
- (forward-sexp)
- (1+ (current-column)))))
- (cond
-
- ((and (or (= column (current-column))
- (= column (+ (shm-node-start-column parent)
- (shm-indent-spaces))))
- (/= column (shm-node-start-column parent)))
- (newline)
- (indent-to (+ (shm-node-start-column parent)
- (shm-indent-spaces))))
- (t
- (newline)
- (indent-to column)))))
- ;; Indent for sum types
- ((or (and parent
- (eq 'DataDecl (shm-node-cons parent)))
- (eq 'ConDecl (shm-node-cons current)))
- (newline)
- (indent-to (shm-node-start-column current))
- (delete-char -2)
- (insert "| "))
- ;; Auto-insert commas for field updates
- ((or (string= "FieldUpdate" (shm-node-type-name current))
- (string= "FieldDecl" (shm-node-type-name current))
- (string= "ExportSpec" (shm-node-type-name current))
- (string= "ImportSpec" (shm-node-type-name current)))
- ;; This is hacky because HSE doesn't have special nodes for the
- ;; record and the update in record {update} and so we have to
- ;; figure out where the { starts. There is some additional
- ;; information in HSE's trees, but I haven't thought of a nice
- ;; way to extract that yet.
- (goto-char (shm-node-end parent))
- (backward-sexp)
- (let ((column (current-column)))
- (goto-char (shm-node-end current))
- (newline)
- (indent-to column)
- (insert ",")
- (insert (make-string (abs (- (shm-node-start-column current)
- (1+ column)))
- ? ))
- (shm/init)))
- ((and parent
- (eq 'Lambda (shm-node-cons parent)))
- (cond
- ((eq shm-lambda-indent-style 'leftmost-parent)
- (let ((leftmost-parent (cdr (shm-find-furthest-parent-on-line parent-pair))))
- (newline)
- (indent-to (+ (shm-indent-spaces)
- (shm-node-indent-column leftmost-parent)))))
- (t (newline)
- (indent-to (+ (shm-indent-spaces)
- (shm-node-start-column parent))))))
- ;; Guards | foo = …
- ((or (string= "GuardedRhs" (shm-node-type-name current))
- (string= "GuardedAlt" (shm-node-type-name current)))
- (newline)
- (indent-to (shm-node-start-column current))
- (insert "| "))
- ;; Indent after or at the = (an rhs).
- ((and parent
- (or (string= "Rhs" (shm-node-type-name parent))
- (string= "Rhs" (shm-node-type-name current))
- (string= "GuardedAlt" (shm-node-type-name parent))
- (string= "GuardedRhs" (shm-node-type-name parent))))
- (newline)
- (indent-to (+ (shm-indent-spaces)
- (shm-node-start-column (cdr (shm-node-parent parent-pair))))))
- ;; When in a field update.
- ((and parent
- (string= "FieldUpdate" (shm-node-type-name parent)))
- (newline)
- (indent-to (+ (shm-node-start-column parent)
- (shm-indent-spaces))))
- ;; When in an alt list
- ((and parent
- (string= "GuardedAlts" (shm-node-type-name current)))
- (newline)
- (indent-to (+ (shm-node-start-column parent)
- (shm-indent-spaces))))
- ;; When in a case alt.
- ((and parent
- (string= "GuardedAlts" (shm-node-type-name parent)))
- (newline)
- (let ((alt (cdr (shm-node-parent parent-pair))))
- (indent-to (+ (shm-node-start-column alt)
- (shm-indent-spaces)))))
- ;; Copy infix operators similar to making new list/tuple
- ;; separators
- ((and parent
- (eq 'InfixApp (shm-node-cons parent)))
- (let* ((operand-pair (shm-node-previous current-pair))
- (operand (cdr operand-pair))
- (string (buffer-substring-no-properties (shm-node-start operand)
- (shm-node-end operand))))
- (cond
- (dragging
- (newline)
- (indent-to (shm-node-start-column parent)))
- ((save-excursion (goto-char (shm-node-end operand))
- (= (point) (line-end-position)))
- (insert " " string)
- (newline)
- (indent-to (shm-node-start-column current)))
- (t
- (newline)
- (indent-to (shm-node-start-column operand))
- (insert string " ")))))
- ;; Infix operators
- ((and parent
- (eq 'InfixApp (shm-node-cons parent)))
- (newline)
- (indent-to (+ (shm-node-start-column parent))))
- ;; Commenting out this behaviour for now
- ;; ((string= "Match" (shm-node-type-name current))
- ;; (let ((name (cdr (shm-node-child-pair current-pair))))
- ;; (newline)
- ;; (indent-to (shm-node-start-column current))
- ;; (insert (buffer-substring-no-properties (shm-node-start name)
- ;; (shm-node-end name))
- ;; " ")))
- ;; Default indentation just copies the current node's indentation
- ;; level. Generally works reliably, but has less than favourable
- ;; indentation sometimes. It just serves as a catch-all.
- (t
- (newline)
- (indent-to (shm-node-start-column current))))))
-
-(defun shm-adjust-dependents (end-point n)
- "Adjust dependent lines by N characters that depend on this
-line after END-POINT."
- (let ((line (line-number-at-pos)))
- (when (and (not (and (looking-back "^[ ]+")
- (looking-at "[ ]*")))
- (save-excursion (goto-char end-point)
- (forward-word)
- (= (line-number-at-pos) line)))
- (shm-move-dependents n
- end-point))))
-
-(defun shm-move-dependents (n point)
- "Move dependent-with-respect-to POINT lines N characters forwards or backwards.
-
-This is purely based on alignments. If anything is aligned after
-the current column, then it's assumed to be a child of whatever
-has recently changed at POINT, and thus we 'bring it along'
-either forwards or backwards.
-
-The algorithm isn't quite comprehensive, it needs special cases
-for top-level functions and things like that."
- (save-excursion
- (let ((column (progn (goto-char point)
- (current-column)))
- (point nil)
- (end-point nil))
- (while (and (= 0 (forward-line 1))
- (or (not end-point)
- (/= end-point (line-end-position))))
- (if (shm-line-indented-past (1+ column))
- (progn (unless point
- (setq point (goto-char (line-beginning-position))))
- (setq end-point (line-end-position)))
- (goto-char (point-max))))
- (when end-point
- (indent-rigidly point end-point n)))))
-
-(defun shm-line-indented-past (n)
- "Is the current line indented past N?"
- (goto-char (line-beginning-position))
- (let ((column (search-forward-regexp "[^ ]" (line-end-position) t 1)))
- (if column
- (>= (1- (current-column)) n)
- t)))
-
-(defun shm-insert-string (string)
- "Insert the given string."
- (save-excursion
- (shm-appropriate-adjustment-point)
- (shm-adjust-dependents (point) (length string)))
- (insert string)
- (shm/init t))
-
-(defun shm-insert-indented (do-insert)
- "Insert, indented in The Right Way. Calls DO-INSERT to do the insertion.
-
-This function assumes a certain semantic meaning towards the
-contents of the kill ring. That is,
-
-do bar
- mu
-
-Is an expression which, when pasted, into
-
-main =
-
-should yield,
-
-main = do bar
- mu
-
-Which is so convenient it changes the way you work. However,
-there is also the other case:
-
- do
-bar
-mu
-
-This is what happens when you have expressions whose children
-hang on the underside, and thus pasting these can be done in two
-ways: (1) the above way, (2) or like this:
-
-main = do
- bar
- mu
-
-I.e. take the parent into account and try to re-paste an
-underside dangling expression. I don't like this style. With SHM
-this style becomes pointless and in fact detrimental. It's much
-easier to read and manipulate children who are next to their
-parents. But one must compromise and conform to some styles no
-matter how poorly reasoned.
-
-We can actually give the option for people to pick and choose
-this underside dangling vs not. But that will be implemented as a
-separate function rather than hard-coded into this one specific
-operation."
- (let ((column (current-column))
- (line (line-beginning-position))
- (start (point))
- (in-string (shm-in-string)))
- (let ((string (with-temp-buffer
- (funcall do-insert)
- (buffer-string))))
- (insert
- ;; Pasting inside a string should escape double quotes and
- ;; convert newlines to multiline strings.
- (if in-string
- (replace-regexp-in-string
- "\"" "\\\\\""
- (replace-regexp-in-string
- "\n" "\\\\n\\\\\n\\\\"
- string))
- string)))
- (when (= line (line-beginning-position))
- (shm-adjust-dependents start (- (current-column)
- column)))
- (let ((end (point)))
- (cond
- ((progn (goto-char start)
- (looking-at " "))
- (let ((node (cdr (shm-find-furthest-parent-on-line (shm-current-node-pair)))))
- (goto-char end)
- (indent-rigidly start
- end
- (+ (shm-indent-spaces)
- (shm-node-indent-column node)))
- (delete-region start
- (save-excursion
- (goto-char start)
- (search-forward-regexp "[ ]+" (line-end-position) t 1)))))
- (t (goto-char end)
- (indent-rigidly start end
- (if in-string
- (1- column)
- column))))
- (setq shm-last-yanked (list start (point)))
- (goto-char start))))
-
-(defun shm-find-furthest-parent-on-line (current)
- "Find the parent which starts nearest to column 0 on the
-current line.
-
-This is used when indenting dangling expressions."
- (let ((parent (shm-node-parent current)))
- (if parent
- (if (= (line-beginning-position)
- (save-excursion (goto-char (shm-node-start (cdr parent)))
- (line-beginning-position)))
- (shm-find-furthest-parent-on-line parent)
- current)
- current)))
-
-(defun shm-indent-spaces ()
- "Get the number of spaces to indent."
- (if (boundp 'haskell-indent-spaces)
- haskell-indent-spaces
- shm-indent-spaces))
-
-(provide 'shm-indentation)
diff --git a/elisp/shm-insert-del.el b/elisp/shm-insert-del.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-insert-del.el
@@ -0,0 +1,558 @@
+;;; shm-insert-del.el --- Insertion/deletion commands
+
+;; 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 .
+
+;;; Code:
+
+(require 'shm-macros)
+(require 'shm-slot)
+(require 'shm-layout)
+(require 'shm-indent)
+
+(defun shm-post-self-insert ()
+ "Self-insertion handler."
+ (save-excursion
+ (shm-appropriate-adjustment-point 'forward)
+ (forward-char -1)
+ (shm-adjust-dependents (point) 1)))
+
+(defun shm/wrap-parens ()
+ "Wrap the node in parentheses."
+ (interactive)
+ (cond
+ ((region-active-p)
+ (shm-wrap-delimiters "(" ")"))
+ (t (let ((line (line-number-at-pos))
+ (node (shm-current-node)))
+ (save-excursion
+ (goto-char (shm-node-start node))
+ (insert "(")
+ (goto-char (shm-node-end node))
+ (when (/= line (line-number-at-pos))
+ (indent-rigidly (shm-node-start node)
+ (shm-node-end node)
+ 1))
+ (insert ")"))
+ (forward-char 1)))))
+
+(defun shm/space ()
+ "Insert a space but sometimes do something more clever, like
+ inserting skeletons."
+ (interactive)
+ (if (and (bound-and-true-p god-local-mode)
+ (fboundp 'god-mode-self-insert))
+ (god-mode-self-insert)
+ (let ((case-fold-search nil))
+ (cond
+ ((or (shm-in-comment)
+ (shm-in-string))
+ (insert " "))
+ (shm-auto-insert-skeletons
+ (cond
+ ((and (looking-back "[^a-zA-Z0-9_]do")
+ (or (eolp)
+ (looking-at "[])}]")))
+ (shm-auto-insert-do))
+ ((and (looking-back " <-")
+ (let ((current (shm-current-node)))
+ (when current
+ (or (eq 'Do (shm-node-cons current))
+ (string= "Stmt" (shm-node-type-name current))))))
+ (shm-auto-insert-stmt 'qualifier))
+ ((looking-back "[^a-zA-Z0-9_]case")
+ (shm-auto-insert-case))
+ ((looking-back "[^a-zA-Z0-9_]if")
+ (shm-auto-insert-if))
+ ((looking-back "[^a-zA-Z0-9_]let")
+ (cond
+ ((let ((current (shm-current-node)))
+ (and current
+ (or (not (or (eq 'Do (shm-node-cons current))
+ (eq 'BDecls (shm-node-cons current))
+ (string= "Stmt" (shm-node-type-name current))))
+ (bound-and-true-p structured-haskell-repl-mode)))
+ (shm-auto-insert-let)))
+ ((not (bound-and-true-p structured-haskell-repl-mode))
+ (shm-auto-insert-stmt 'let))))
+ ((and (looking-back "module")
+ (= (line-beginning-position)
+ (- (point) 6))
+ (looking-at "[ ]*$"))
+ (shm-auto-insert-module))
+ (t (shm-insert-string " "))))
+ (t (shm-insert-string " "))))))
+
+(defun shm/double-quote ()
+ "Insert double quotes.
+
+This tries to be clever about insertion. If already in a string,
+it will insert \", if at the end of a string, it will glide over
+the ending quote. If not in a string, it will insert \"\", and
+also space out any neccessary spacing."
+ (interactive)
+ (shm/reparse)
+ (if (shm-in-comment)
+ (insert "\"")
+ (let* ((current-node (shm-current-node))
+ (node (if (eq 'Lit (shm-node-cons current-node))
+ (shm-actual-node)
+ current-node)))
+ (cond
+ ((and (shm-in-string)
+ (looking-back "\\\\"))
+ (insert "\""))
+ ((shm-find-overlay 'shm-quarantine)
+ (insert "\"\"")
+ (forward-char -1))
+ ;; "…|…"
+ ((shm-in-string)
+ (cond
+ ;; "…|"
+ ((= (point)
+ (1- (shm-node-end node)))
+ (forward-char 1))
+ ;; "…|…"
+ ((= (point) (shm-node-end node))
+ (if (looking-back "\"")
+ (shm-delimit "\"" "\"")
+ (progn (insert "\""))))
+ (t (let ((inhibit-read-only t))
+ (shm-adjust-dependents (point) 2)
+ (insert "\\\"")))))
+ ;; '|'
+ ((save-excursion (forward-char -1)
+ (looking-at "''"))
+ (let ((inhibit-read-only t))
+ (shm-adjust-dependents (point) 1)
+ (insert "\"")))
+ ;; anywhere
+ (t
+ (shm-delimit "\"" "\""))))))
+
+(defun shm/comma (n)
+ "Insert a comma. In a list it tries to help a bit by setting
+the current node to the parent."
+ (interactive "p")
+ (if (shm-in-comment)
+ (self-insert-command n)
+ (let ((current-pair (shm-current-node-pair)))
+ (if (not current-pair)
+ (self-insert-command n)
+ (let* ((current (cdr current-pair))
+ (parent-pair (shm-node-parent current-pair))
+ (parent (cdr parent-pair)))
+ (cond
+ ;; When inside a list, indent to the list's position with an
+ ;; auto-inserted comma.
+ ((eq 'List (shm-node-cons parent))
+ (shm-insert-string ",")
+ (shm-set-node-overlay parent-pair))
+ (t
+ (shm-insert-string ",")
+ (shm-set-node-overlay parent-pair))))))))
+
+(defun shm/single-quote ()
+ "Delimit single quotes."
+ (interactive)
+ (shm-delimit "'" "'"))
+
+(defun shm/= ()
+ "Insert equal."
+ (interactive)
+ (cond
+ ((shm-literal-insertion)
+ (insert "="))
+ (t (unless (looking-back " ")
+ (shm-insert-string " "))
+ (shm-insert-string "=")
+ (unless (looking-at " ")
+ (shm-insert-string " ")))))
+
+(defun shm/: ()
+ "Insert colon."
+ (interactive)
+ (if (or (not shm-colon-enabled)
+ (shm-literal-insertion))
+ (call-interactively 'self-insert-command)
+ (let ((current (shm-current-node)))
+ (cond
+ ((and current
+ (or (eq (shm-node-cons current)
+ 'SpliceDecl)
+ (string= (shm-node-type-name current)
+ "BangType")
+ (string= (shm-node-type-name current)
+ "FieldDecl")))
+ (unless (looking-back "[ ]+")
+ (insert " "))
+ (unless (looking-back "::[ ]+")
+ (shm-insert-string ":: a")
+ (forward-word -1)
+ (shm-evaporate (point) (1+ (point)))))
+ (t
+ (shm-insert-string ":"))))))
+
+(defun shm/hyphen (n)
+ "The - hyphen."
+ (interactive "p")
+ (if (and (looking-back "{")
+ (looking-at "}"))
+ (progn (insert "--")
+ (forward-char -1))
+ (self-insert-command n)))
+
+(defun shm/hash (n)
+ "The # hash."
+ (interactive "p")
+ (if (and (looking-back "{-")
+ (looking-at "-}"))
+ (progn (insert "# #")
+ (forward-char -2)
+ (let ((pragma (ido-completing-read "Pragma: "
+ shm-pragmas)))
+ (insert pragma
+ " ")
+ (when (string= pragma "LANGUAGE")
+ (insert (ido-completing-read
+ "Language: "
+ (remove-if (lambda (s) (string= s ""))
+ (split-string (shell-command-to-string "ghc --supported-languages")
+ "\n")))))))
+ (self-insert-command n)))
+
+(defun shm/open-paren ()
+ "Delimit parentheses."
+ (interactive)
+ (let ((current (shm-current-node)))
+ (cond
+ ((and current
+ (or (string= "ExportSpec" (shm-node-type-name current))
+ (string= "ImportSpec" (shm-node-type-name current))))
+ (insert "()")
+ (forward-char -1))
+ (t
+ (shm-delimit "(" ")")))))
+
+(defun shm/open-bracket ()
+ "Delimit brackets."
+ (interactive)
+ (shm-delimit "[" "]"))
+
+(defun shm/open-brace ()
+ "Delimit braces."
+ (interactive)
+ (let ((current (shm-current-node)))
+ (cond
+ ((and current
+ (string= "Pat" (shm-node-type-name current)))
+ (shm-insert-string "{}")
+ (forward-char -1))
+ (t
+ (shm-delimit "{" "}")))))
+
+(defun shm/del ()
+ "Character deletion handler.
+
+Generally, we delete things in the current node. BUT, there are
+some things that we shouldn't delete, because they would cause
+parse errors that are rarely useful. For example:
+
+ (|case x of _ -> _) -- where | indicates cursor.
+
+"
+ (interactive)
+ (shm-with-fallback
+ delete-backward-char
+ (let ((case-fold-search nil))
+ (cond
+ ;; These cases are “gliders”. They simply move over the character
+ ;; backwards. These could be handled all as one regular
+ ;; expression, but in the interest of clarity—for now—they are left
+ ;; as separate cases.
+ ((and (shm-in-string)
+ (looking-back "^[ ]*\\\\"))
+ (let ((here (point)))
+ (delete-region (search-backward-regexp "\\\\$")
+ here)))
+ ((and (looking-back "{-[ ]*")
+ (looking-at "[ ]*-}"))
+ (delete-region (search-backward-regexp "-")
+ (progn (forward-char 1)
+ (search-forward-regexp "-"))))
+ ((and (looking-back "^{-#[ ]*")
+ (looking-at "[ ]*#-}$"))
+ (delete-region (search-backward-regexp "#")
+ (progn (forward-char 1)
+ (search-forward-regexp "#"))))
+ ((looking-back "[()]") (shm-delete-or-glide "(" ")"))
+ ((looking-back "[[]") (shm-delete-or-glide "\\[" "\\]"))
+ ((looking-back "[]]") (shm-delete-or-glide "\\[" "\\]"))
+ ((looking-back "[{}]") (shm-delete-or-glide "{" "}"))
+ ((looking-back "[\"]") (shm-delete-or-glide "\"" "\""))
+ ;; These kind of patterns block the parens of syntaxes that would
+ ;; otherwise break everything, so, "if", "of", "case", "do",
+ ;; etc. if deleted.
+ ((and (shm-prevent-parent-deletion-p)
+ (looking-back "[^A-Zaz0-9_]do ?")
+ (not (or (eolp)
+ (looking-at "[])}]"))))
+ nil) ; do nothing
+ ((and (shm-prevent-parent-deletion-p)
+ (looking-back " <-")
+ (not (or (eolp)
+ (looking-at "[])}]"))))
+ (forward-char -3))
+ ((and (shm-prevent-parent-deletion-p)
+ (looking-back " <- ")
+ (not (or (eolp)
+ (looking-at "[])}]"))))
+ (forward-char -4))
+ ((and (shm-prevent-parent-deletion-p)
+ (looking-back "[^A-Zaz0-9_]of ?"))
+ (search-backward-regexp "[ ]*of"))
+ ((and (shm-prevent-parent-deletion-p)
+ (or (looking-at "of$")
+ (looking-at "of ")))
+ (forward-char -1))
+ ((and (shm-prevent-parent-deletion-p)
+ (looking-back "[_ ]-> ?")) (forward-char -3))
+ ((and (shm-prevent-parent-deletion-p)
+ (looking-at "-> ?"))
+ (forward-char -1))
+ ((and (shm-prevent-parent-deletion-p)
+ (looking-back "[^A-Zaz0-9_]then ?"))
+ (search-backward-regexp "[^ ][ ]*then")
+ (unless (or (looking-at "$") (looking-at " "))
+ (forward-char 1)))
+ ((and (shm-prevent-parent-deletion-p)
+ (looking-back "[^A-Zaz0-9_]else ?"))
+ (search-backward-regexp "[^ ][ ]*else")
+ (unless (or (looking-at "$") (looking-at " "))
+ (forward-char 1)))
+ ((and (shm-prevent-parent-deletion-p)
+ (looking-back "^module ?"))
+ (when (looking-at "[ ]*where$")
+ (delete-region (line-beginning-position) (line-end-position))))
+ ((and (shm-prevent-parent-deletion-p)
+ (looking-back "[^A-Zaz0-9_]if ?"))
+ nil) ; do nothing
+ ((and (shm-prevent-parent-deletion-p)
+ (looking-back "[^A-Zaz0-9_]case ?"))
+ nil) ; do nothing
+ ((and (shm-prevent-parent-deletion-p)
+ (and (looking-at "= ")
+ (looking-back " ")))
+ (forward-char -1))
+ ((and (shm-prevent-parent-deletion-p)
+ (or (and (looking-back " = ")
+ (not (looking-at "$"))
+ (not (looking-at " ")))
+ (and (looking-back "=")
+ (looking-at " "))))
+ (search-backward-regexp "[ ]+=[ ]*"
+ (line-beginning-position)
+ t
+ 1)
+ (when (looking-back " ")
+ (when (search-backward-regexp "[^ ]" (line-beginning-position)
+ t 1)
+ (forward-char 1))))
+ ;; This is the base case, we assume that we can freely delete
+ ;; whatever we're looking back at, and that the node will be able
+ ;; to re-parse it.
+ (t (shm-delete-char)
+ (save-excursion
+ (shm-appropriate-adjustment-point 'backward)
+ (shm-adjust-dependents (point) -1))))))
+ (shm/init t))
+
+(defun shm-prevent-parent-deletion-p ()
+ "Prevent parent deletion at point?"
+ (and shm-prevent-parent-deletion
+ (not (shm-in-string))))
+
+(defun shm-delete-or-glide (open close)
+ "Delete the given OPEN/CLOSE delimiter, or simply glide over it
+ if it isn't empty."
+ (cond
+ ;; If the delimiters are empty, we can delete the whole thing.
+ ((shm-delimiter-empty open close)
+ (let ((inhibit-read-only t))
+ (shm-adjust-dependents (point) -2)
+ (delete-region (1- (point))
+ (1+ (point)))))
+ ;; If the delimiters aren't empty and we're in a literal, then go
+ ;; ahead and elete the character.
+ ((and (shm-literal-insertion)
+ (not (= (point) (1+ (shm-node-start (shm-current-node))))))
+ (shm-delete-char))
+ ;; Otherwise just glide over the character.
+ (t
+ (when (looking-back close)
+ (forward-char -1)))))
+
+(defun shm-delete-char ()
+ "Delete a character backwards or delete the region, if there is
+one active."
+ (if (region-active-p)
+ (delete-region (region-beginning)
+ (region-end))
+ (delete-region (1- (point))
+ (point))))
+
+(defun shm-delimiter-empty (open close)
+ "Is the current expression delimited by OPEN and CLOSE empty?"
+ (and (looking-back open)
+ (not (save-excursion (forward-char (* -1 (length open)))
+ (looking-back "\\\\")))
+ (looking-at close)))
+
+(defun shm-wrap-delimiters (open close)
+ "Wrap the current region with the given delimiters. Called when
+the region is active."
+ (let ((beg (region-beginning))
+ (end (region-end)))
+ (save-excursion
+ (goto-char beg)
+ (save-excursion
+ (goto-char end)
+ (shm-insert-string close))
+ (shm-insert-string open))
+ (when (= (point) beg)
+ (forward-char 1))))
+
+(defun shm-delimit (open close)
+ "Insert the given delimiters.
+
+This is a special function because it will do different things
+depending on the context.
+
+If we're in a string, it just inserts OPEN. If we're in an
+expression, it will insert OPEN and CLOSE and put the point
+between them. It will also space out so that there is space
+between previous nodes and the next. E.g.
+
+foo|(bar)
+
+If you hit \" at | then you will get:
+
+foo \"\" (bar)
+
+It saves one having to type spaces; it's obvious what to do
+here."
+ (cond
+ ((region-active-p)
+ (shm-wrap-delimiters open close))
+ ((and (shm-literal-insertion)
+ (not (string= open "\"")))
+ (shm-insert-string open))
+ (t
+ (shm/reparse)
+ (let ((current (shm-actual-node)))
+ (cond
+ ((shm-find-overlay 'shm-quarantine)
+ (if (not (or (looking-back "[ ,[({\\]")
+ (and (looking-back "\\$")
+ (string= "(" open))
+ (bolp)))
+ (progn (shm-insert-string " ") 1)
+ 0)
+ (shm-insert-string open)
+ (let ((point (point)))
+ (shm-insert-string close)
+ (when (and (/= (point) (line-end-position))
+ (not (looking-at "[]){} ,]")))
+ (shm-insert-string " "))
+ (goto-char point)))
+ (t
+ (if (not (or (looking-back "[ ,[({]")
+ (bolp)))
+ (progn (shm-insert-string " ") 1)
+ 0)
+ (shm-insert-string open)
+ (let ((point (point)))
+ (shm-insert-string close)
+ (when (and (/= (point) (line-end-position))
+ (not (looking-at "[]){} ,]")))
+ (shm-insert-string " "))
+ (goto-char point)
+ (shm/init t))))))))
+
+(defun shm-auto-insert-stmt (type)
+ "Insert template
+
+do x <- |
+ {undefined}
+"
+ (let* ((current (shm-current-node))
+ (column (save-excursion
+ (case type
+ ('let (backward-word 1)
+ (current-column))
+ ('qualifier
+ (cond
+ ((eq 'Do (shm-node-cons current))
+ (goto-char (shm-node-start current))
+ (forward-char 2)
+ (search-forward-regexp "[^ \n]")
+ (1- (current-column)))
+ (t (goto-char (shm-node-start current))
+ (current-column))))))))
+ (unless (save-excursion
+ (let ((current-line (line-number-at-pos)))
+ (forward-line 1)
+ (goto-char (+ (line-beginning-position)
+ column))
+ (and (not (bolp))
+ (/= current-line (line-number-at-pos))
+ (= (point)
+ (save-excursion (back-to-indentation)
+ (point))))))
+ (save-excursion
+ (newline)
+ (indent-to column)
+ (insert "undefined")
+ (forward-word -1)
+ (shm/reparse)
+ (shm-evaporate (point)
+ (progn (forward-word 1)
+ (point)))))
+ (insert " ")))
+
+(defun shm/delete ()
+ "Delete the current node."
+ (interactive)
+ (shm-with-fallback
+ delete-char
+ (let ((current (shm-current-node))
+ (inhibit-read-only t))
+ (delete-region (shm-node-start current)
+ (shm-node-end current)))))
+
+(defun shm/export ()
+ "Export the identifier at point."
+ (interactive)
+ (let ((name (shm-node-string (shm-actual-node))))
+ (save-excursion
+ (goto-char (point-min))
+ (search-forward-regexp "^module")
+ (search-forward-regexp " where")
+ (search-backward-regexp ")")
+ (shm/reparse)
+ (shm/newline-indent)
+ (insert name))))
+
+(provide 'shm-insert-del)
diff --git a/elisp/shm-insertion.el b/elisp/shm-insertion.el
deleted file mode 100644
--- a/elisp/shm-insertion.el
+++ /dev/null
@@ -1,339 +0,0 @@
-;;; shm-insertion.el --- Operations to insert things
-
-;; 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 .
-
-;;; Code:
-
-(require 'shm-evaporate)
-(require 'shm-skeletons)
-(require 'shm-nodes)
-
-(defun shm/insert-undefined ()
- "Insert undefined."
- (interactive)
- (save-excursion
- (let ((point (point)))
- (shm-insert-string "undefined")
- (shm-evaporate point (point)))))
-
-(defun shm/wrap-parens ()
- "Wrap the node in parentheses."
- (interactive)
- (cond
- ((region-active-p)
- (let ((beg (region-beginning))
- (end (region-end)))
- (goto-char beg)
- (insert "(")
- (goto-char (1+ end))
- (insert ")")
- (goto-char (1+ beg))))
- (t (let ((line (line-number-at-pos))
- (node (shm-current-node)))
- (save-excursion
- (goto-char (shm-node-start node))
- (insert "(")
- (goto-char (shm-node-end node))
- (when (/= line (line-number-at-pos))
- (indent-rigidly (shm-node-start node)
- (shm-node-end node)
- 1))
- (insert ")"))
- (forward-char 1)))))
-
-(defun shm/space ()
- "Insert a space but sometimes do something more clever, like
- inserting skeletons."
- (interactive)
- (if (and (bound-and-true-p god-local-mode)
- (fboundp 'god-mode-self-insert))
- (god-mode-self-insert)
- (cond
- ((shm-in-comment)
- (insert " "))
- (shm-auto-insert-skeletons
- (cond
- ((and (looking-back "[^a-zA-Z0-9_]do")
- (or (eolp)
- (looking-at "[])}]")))
- (shm-auto-insert-do))
- ((and (looking-back " <-")
- (let ((current (shm-current-node)))
- (when current
- (or (eq 'Do (shm-node-cons current))
- (string= "Stmt" (shm-node-type-name current))))))
- (shm-auto-insert-stmt 'qualifier))
- ((looking-back "[^a-zA-Z0-9_]case")
- (shm-auto-insert-case))
- ((looking-back "[^a-zA-Z0-9_]if")
- (shm-auto-insert-if))
- ((looking-back "[^a-zA-Z0-9_]let")
- (cond
- ((let ((current (shm-current-node)))
- (not (or (eq 'Do (shm-node-cons current))
- (eq 'BDecls (shm-node-cons current))
- (string= "Stmt" (shm-node-type-name current)))))
- (shm-auto-insert-let))
- (t (shm-auto-insert-stmt 'let))))
- ((and (looking-back "module")
- (= (line-beginning-position)
- (- (point) 6))
- (looking-at "[ ]*$"))
- (shm-auto-insert-module))
- (t (insert " "))))
- (t (insert " ")))))
-
-(defun shm/jump-to-slot ()
- "Jump to the next skeleton slot."
- (interactive)
- (let ((os (sort (remove-if-not (lambda (o) (overlay-get o 'shm-evaporate-overlay))
- (overlays-in (point) (point-max)))
- (lambda (a b)
- (< (overlay-start a)
- (overlay-start b))))))
- (when os
- (if (= (overlay-start (car os))
- (point))
- (when (cadr os)
- (goto-char (overlay-start (cadr os))))
- (goto-char (overlay-start (car os)))))))
-
-(defun shm/jump-to-previous-slot ()
- "Jump to the previous skeleton slot."
- (interactive)
- (let ((os (sort (remove-if-not (lambda (o) (overlay-get o 'shm-evaporate-overlay))
- (overlays-in (point-min) (point)))
- (lambda (a b)
- (> (overlay-start a)
- (overlay-start b))))))
- (when os
- (if (= (overlay-start (car os))
- (point))
- (when (cadr os)
- (goto-char (overlay-start (cadr os))))
- (goto-char (overlay-start (car os)))))))
-
-(defun shm/double-quote ()
- "Insert double quotes.
-
-This tries to be clever about insertion. If already in a string,
-it will insert \", if at the end of a string, it will glide over
-the ending quote. If not in a string, it will insert \"\", and
-also space out any neccessary spacing."
- (interactive)
- (shm/reparse)
- (if (shm-in-comment)
- (insert "\"")
- (let* ((current-node (shm-current-node))
- (node (if (eq 'Lit (shm-node-cons current-node))
- (shm-actual-node)
- current-node)))
- (cond
- ((shm-find-overlay 'shm-quarantine)
- (insert "\"\"")
- (forward-char -1))
- ;; "…|…"
- ((shm-in-string)
- (cond
- ;; "…|"
- ((= (point)
- (1- (shm-node-end node)))
- (forward-char 1))
- ;; "…|…"
- ((= (point) (shm-node-end node))
- (if (looking-back "\"")
- (shm-delimit "\"" "\"")
- (progn (insert "\""))))
- (t (let ((inhibit-read-only t))
- (shm-adjust-dependents (point) 2)
- (insert "\\\"")))))
- ;; '|'
- ((save-excursion (forward-char -1)
- (looking-at "''"))
- (let ((inhibit-read-only t))
- (shm-adjust-dependents (point) 1)
- (insert "\"")))
- ;; anywhere
- (t
- (shm-delimit "\"" "\""))))))
-
-(defun shm/comma (n)
- "Insert a comma. In a list it tries to help a bit by setting
-the current node to the parent."
- (interactive "p")
- (if (shm-in-comment)
- (self-insert-command n)
- (let* ((current-pair (shm-current-node-pair))
- (current (cdr current-pair))
- (parent-pair (shm-node-parent current-pair))
- (parent (cdr parent-pair)))
- (cond
- ;; When inside a list, indent to the list's position with an
- ;; auto-inserted comma.
- ((eq 'List (shm-node-cons parent))
- (shm-insert-string ",")
- (shm-set-node-overlay parent-pair))
- (t
- (shm-insert-string ",")
- (shm-set-node-overlay parent-pair))))))
-
-(defun shm/single-quote ()
- "Delimit single quotes."
- (interactive)
- (shm-delimit "'" "'"))
-
-(defun shm/= ()
- "Insert equal."
- (interactive)
- (cond
- ((shm-literal-insertion)
- (insert "="))
- (t (unless (looking-back " ")
- (shm-insert-string " "))
- (shm-insert-string "=")
- (unless (looking-at " ")
- (shm-insert-string " ")))))
-
-(defun shm/: ()
- "Insert colon."
- (interactive)
- (if (shm-literal-insertion)
- (call-interactively 'self-insert-command)
- (let ((current (shm-current-node)))
- (cond
- ((and current
- (or (eq (shm-node-cons current)
- 'SpliceDecl)
- (string= (shm-node-type-name current)
- "BangType")
- (string= (shm-node-type-name current)
- "FieldDecl")))
- (unless (looking-back "[ ]+")
- (insert " "))
- (unless (looking-back "::[ ]+")
- (shm-insert-string ":: a")
- (forward-word -1)
- (shm-evaporate (point) (1+ (point)))))
- (t
- (shm-insert-string ":"))))))
-
-(defun shm/hyphen (n)
- "The - hyphen."
- (interactive "p")
- (if (and (looking-back "{")
- (looking-at "}"))
- (progn (insert "--")
- (forward-char -1))
- (self-insert-command n)))
-
-(defun shm/hash (n)
- "The # hash."
- (interactive "p")
- (if (and (looking-back "{-")
- (looking-at "-}"))
- (progn (insert "# #")
- (forward-char -2))
- (self-insert-command n)))
-
-(defun shm/open-paren ()
- "Delimit parentheses."
- (interactive)
- (let ((current (shm-current-node)))
- (cond
- ((and current
- (or (string= "ExportSpec" (shm-node-type-name current))
- (string= "ImportSpec" (shm-node-type-name current))))
- (insert "()")
- (forward-char -1))
- (t
- (shm-delimit "(" ")")))))
-
-(defun shm/open-bracket ()
- "Delimit brackets."
- (interactive)
- (shm-delimit "[" "]"))
-
-(defun shm/open-brace ()
- "Delimit braces."
- (interactive)
- (let ((current (shm-current-node)))
- (cond
- ((and current
- (string= "Pat" (shm-node-type-name current)))
- (shm-insert-string "{}")
- (forward-char -1))
- (t
- (shm-delimit "{" "}")))))
-
-(defun shm-delimit (open close)
- "Insert the given delimiters.
-
-This is a special function because it will do different things
-depending on the context.
-
-If we're in a string, it just inserts OPEN. If we're in an
-expression, it will insert OPEN and CLOSE and put the point
-between them. It will also space out so that there is space
-between previous nodes and the next. E.g.
-
-foo|(bar)
-
-If you hit \" at | then you will get:
-
-foo \"\" (bar)
-
-It saves one having to type spaces; it's obvious what to do
-here."
- (cond
- ((and (shm-literal-insertion)
- (not (string= open "\"")))
- (shm-insert-string open))
- (t
- (shm/reparse)
- (let ((current (shm-actual-node)))
- (cond
- ((shm-find-overlay 'shm-quarantine)
- (if (not (or (looking-back "[ ,[({]")
- (bolp)))
- (progn (shm-insert-string " ") 1)
- 0)
- (shm-insert-string open)
- (let ((point (point)))
- (shm-insert-string close)
- (when (and (/= (point) (line-end-position))
- (not (looking-at "[]){} ,]")))
- (shm-insert-string " "))
- (goto-char point)))
- (t
- (if (not (or (looking-back "[ ,[({]")
- (bolp)))
- (progn (shm-insert-string " ") 1)
- 0)
- (shm-insert-string open)
- (let ((point (point)))
- (shm-insert-string close)
- (when (and (/= (point) (line-end-position))
- (not (looking-at "[]){} ,]")))
- (shm-insert-string " "))
- (goto-char point)
- (shm/init t))))))))
-
-(defun shm-literal-insertion ()
- "Should a node have literal insertion?"
- (or (shm-in-string)
- (shm-in-comment)))
-
-(provide 'shm-insertion)
diff --git a/elisp/shm-layout.el b/elisp/shm-layout.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-layout.el
@@ -0,0 +1,367 @@
+;;; shm-layout.el --- Layout-sensitive tasks
+
+;; 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 .
+
+;;; Code:
+
+(require 'shm-node)
+(require 'shm-ast)
+
+(defun shm-appropriate-adjustment-point (direction)
+ "Go to the appropriate adjustment point.
+
+This is called before calling `shm-adjust-dependents', because some places, e.g.
+
+zoo = do
+ bar
+ mu
+
+If the point is at 'z', then we should *not* move 'bar' or 'mu',
+even though we normally would. To avoid doing this, we use a very
+simple but 90% effective (100% is rather hard, will not be
+appearing in a beta version) heuristic. We jump to here:
+
+zoo| = do
+ bar
+ mu
+
+And use our normal adjustment test there. After all, only thing
+after 'zoo' are *really* dependent."
+ (unless (eolp)
+ (let ((current (shm-current-node)))
+ (case direction
+ ('forward
+ (when (and current
+ (< (shm-node-end current) (line-end-position))
+ (not (and (looking-at " ")
+ (looking-back " "))))
+ (goto-char (shm-node-end current))))
+ ('backward
+ (when (and current
+ (> (shm-node-start current) (line-beginning-position)))
+ (goto-char (shm-node-start current))))))))
+
+(defun shm-adjust-dependents (end-point n)
+ "Adjust dependent lines by N characters that depend on this
+line after END-POINT."
+ (unless (= (line-beginning-position)
+ (1- (point)))
+ (let ((line (line-number-at-pos))
+ (column (current-column)))
+ (when (and (not (< column (shm-indent-spaces)))
+ ;; I don't remember what this is for. I'm removing
+ ;; it. If it causes problems, I'll deal with it then.
+ ;;
+ ;; (not (and (looking-back "^[ ]+")
+ ;; (looking-at "[ ]*")))
+ (save-excursion (goto-char end-point)
+ (forward-word)
+ (= (line-number-at-pos) line)))
+ (unless (save-excursion
+ (goto-char (line-end-position))
+ (let ((current-pair (shm-node-backwards)))
+ (when current-pair
+ (or (string= (shm-node-type-name (cdr current-pair))
+ "Rhs")
+ (eq (shm-node-cons (cdr current-pair))
+ 'Lambda)))))
+ (shm-move-dependents n
+ end-point))))))
+
+(defun shm-move-dependents (n point)
+ "Move dependent-with-respect-to POINT lines N characters forwards or backwards.
+
+This is purely based on alignments. If anything is aligned after
+the current column, then it's assumed to be a child of whatever
+has recently changed at POINT, and thus we 'bring it along'
+either forwards or backwards.
+
+The algorithm isn't quite comprehensive, it needs special cases
+for top-level functions and things like that."
+ (save-excursion
+ (let ((column (progn (goto-char point)
+ (current-column)))
+ (point nil)
+ (end-point nil))
+ (while (and (= 0 (forward-line 1))
+ (or (not end-point)
+ (/= end-point (line-end-position))))
+ (if (shm-line-indented-past (1+ column))
+ (progn (unless point
+ (setq point (goto-char (line-beginning-position))))
+ (setq end-point (line-end-position)))
+ (goto-char (point-max))))
+ (when end-point
+ (indent-rigidly point end-point n)))))
+
+(defun shm-line-indented-past (n)
+ "Is the current line indented past N?"
+ (goto-char (line-beginning-position))
+ (let ((column (search-forward-regexp "[^ ]" (line-end-position) t 1)))
+ (if column
+ (>= (1- (current-column)) n)
+ t)))
+
+(defun shm-insert-string (string)
+ "Insert the given string."
+ (save-excursion
+ (shm-appropriate-adjustment-point 'forward)
+ (shm-adjust-dependents (point) (length string)))
+ (insert string)
+ (shm/init t))
+
+(defun shm-insert-indented (do-insert &optional no-adjust-dependents)
+ "Insert, indented in The Right Way. Calls DO-INSERT to do the insertion.
+
+This function assumes a certain semantic meaning towards the
+contents of the kill ring. That is,
+
+do bar
+ mu
+
+Is an expression which, when pasted, into
+
+main =
+
+should yield,
+
+main = do bar
+ mu
+
+Which is so convenient it changes the way you work. However,
+there is also the other case:
+
+ do
+bar
+mu
+
+This is what happens when you have expressions whose children
+hang on the underside, and thus pasting these can be done in two
+ways: (1) the above way, (2) or like this:
+
+main = do
+ bar
+ mu
+
+I.e. take the parent into account and try to re-paste an
+underside dangling expression. I don't like this style. With SHM
+this style becomes pointless and in fact detrimental. It's much
+easier to read and manipulate children who are next to their
+parents. But one must compromise and conform to some styles no
+matter how poorly reasoned.
+
+We can actually give the option for people to pick and choose
+this underside dangling vs not. But that will be implemented as a
+separate function rather than hard-coded into this one specific
+operation."
+ (let ((column (current-column))
+ (line (line-beginning-position))
+ (start (point)))
+ (let ((string
+ (with-temp-buffer
+ (funcall do-insert)
+ (buffer-string))))
+ (insert (if (shm-in-string)
+ (replace-regexp-in-string
+ "\n" "\\\\n\\\\\n\\\\"
+ string)
+ string)))
+ (when (and (= line (line-beginning-position))
+ (not no-adjust-dependents))
+ (shm-adjust-dependents start (- (current-column)
+ column)))
+ (when (= (point) start)
+ (goto-char (region-end)))
+ (let ((end (point)))
+ (cond
+ ((save-excursion (goto-char start)
+ (looking-at " "))
+ (let ((current-pair (shm-current-node-pair)))
+ (when (and current-pair (= (point-max) (point)) current-pair)
+ (let ((node (cdr (shm-find-furthest-parent-on-line current-pair))))
+ (goto-char end)
+ (indent-rigidly start
+ end
+ (+ (shm-indent-spaces)
+ (shm-node-indent-column node)))
+ (delete-region start
+ (save-excursion
+ (goto-char start)
+ (search-forward-regexp "[ ]+" (line-end-position) t 1)))))))
+ (t (goto-char end)
+ (indent-rigidly start end column)))
+ (push-mark)
+ (goto-char start))))
+
+(defun shm-find-furthest-parent-on-line (current)
+ "Find the parent which starts nearest to column 0 on the
+current line.
+
+This is used when indenting dangling expressions."
+ (let ((parent (shm-node-parent current)))
+ (if parent
+ (if (= (line-beginning-position)
+ (save-excursion (goto-char (shm-node-start (cdr parent)))
+ (line-beginning-position)))
+ (shm-find-furthest-parent-on-line parent)
+ current)
+ current)))
+
+(defun shm-indent-spaces ()
+ "Get the number of spaces to indent."
+ (if (boundp 'haskell-indent-spaces)
+ haskell-indent-spaces
+ shm-indent-spaces))
+
+(defun shm-kill-region (save-it start end do-not-delete)
+ "Kill the given region, dropping any redundant indentation.
+
+This normalizes everything it kills assuming what has been killed
+is a node or set of nodes. Indentation is stripped off and
+preserved appropriately so that if we kill e.g.
+
+foo = {do bar
+ mu}
+
+where {} indicates the current node, then what is put into the kill ring is:
+
+do bar
+ mu
+
+rather than what is normally put there,
+
+do bar
+ mu
+
+So this is nice to paste elsewhere outside of Emacs, but it's
+especially nice for pasting back into other parts of code,
+because the yank function will take advantage of this
+normalization and paste and re-indent to fit into the new
+location. See `shm/yank' for documentation on that."
+ (goto-char start)
+ (let* ((start-col (current-column))
+ (multi-line (/= (line-beginning-position)
+ (save-excursion (goto-char end)
+ (line-beginning-position))))
+ (string (buffer-substring-no-properties
+ start
+ end))
+ (result
+ (unless (string= string "")
+ (with-temp-buffer
+ (when multi-line
+ (insert (make-string start-col ? )))
+ (insert string)
+ ;; This code de-indents code until a single line is
+ ;; hitting column zero.
+ (let ((indent-tabs-mode nil)
+ (continue t)
+ (buffer-max (point-max)))
+ (while (and continue
+ (progn (goto-char (point-min))
+ (not (and (search-forward-regexp "^[^ ]" nil t 1)
+ (forward-line -1)
+ ;; If there are empty lines, they
+ ;; don't count as hitting column zero.
+ (if (/= (line-beginning-position)
+ (line-end-position))
+ t
+ ;; And we should actually delete empty lines.
+ (progn (if (bobp)
+ (delete-region (point) (1+ (point)))
+ (delete-region (1- (point)) (point)))
+ nil))))))
+
+ ;; Bring everything back one.
+ (unless (= 0 start-col)
+ (indent-rigidly (point-min) (point-max)
+ -1))
+ (if (/= buffer-max (point-max))
+ (setq buffer-max (point-max))
+ (setq continue nil))))
+ ;; If there's an empty line at the end, then strip that
+ ;; out. It's just bothersome when pasting back in.
+ (goto-char (point-max))
+ (when (looking-at "^$")
+ (delete-region (1- (point))
+ (point)))
+ ;; Finally, the actual save.
+ (funcall (if save-it save-it 'clipboard-kill-ring-save)
+ (point-min)
+ (point-max))))))
+ (let ((inhibit-read-only t))
+ (unless do-not-delete
+ (delete-region start
+ end)))
+ result))
+
+(defun shm-kill-to-end-of-line (&optional prepend-newline)
+ "Kill everything possible to kill after point before the end of
+the line."
+ (let* ((vector (shm-decl-ast))
+ (current-pair (shm-current-node-pair))
+ (current (cdr current-pair))
+ (parent-pair (shm-node-ancestor-for-kill current-pair (point)))
+ (parent (cdr parent-pair)))
+ (loop for i
+ from 0
+ to (length vector)
+ until (or (>= i (length vector))
+ (let ((node (elt vector i)))
+ (and (>= (shm-node-start node)
+ (shm-node-start parent))
+ (<= (shm-node-end node)
+ (shm-node-end parent)))))
+ finally (return
+ (let ((last-command (if prepend-newline 'kill-region last-command)))
+ (when prepend-newline
+ (kill-append "\n" nil))
+ (if (< i (length vector))
+ (shm-kill-node 'clipboard-kill-ring-save
+ parent
+ (point))
+ (let ((line-end-position (if prepend-newline
+ (save-excursion (forward-line)
+ (line-end-position))
+ (line-end-position))))
+ (when (= (point)
+ line-end-position)
+ (kill-region (point)
+ line-end-position)))))))))
+
+(defun shm-node-ancestor-for-kill (current-pair point)
+ "Get the ancestor for greedy killing."
+ (let* ((current (cdr current-pair))
+ (parent-pair (shm-node-parent current-pair))
+ (parent (cdr parent-pair)))
+ (if (and (shm-node-app-p parent)
+ (< (shm-node-end current) (line-end-position)))
+ parent-pair
+ (shm-node-ancestor-at-point current-pair point))))
+
+(defun shm-kill-node (&optional save-it node start do-not-delete)
+ "Kill the current node.
+
+See documentation of `shm-kill-region' for the transformations
+this does."
+ (interactive)
+ (let* ((current (or node (shm-current-node))))
+ (shm-kill-region save-it
+ (or start (shm-node-start current))
+ (shm-node-end current)
+ do-not-delete)))
+
+(provide 'shm-layout)
diff --git a/elisp/shm-manipulation.el b/elisp/shm-manipulation.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-manipulation.el
@@ -0,0 +1,161 @@
+;;; shm-manipulation.el --- Manipulation of nodes commands
+
+;; 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 .
+
+;;; Code:
+
+(require 'shm-layout)
+
+(defun shm/add-operand ()
+ "When in an infix application, figure out the operator and add
+a new operand. E.g.
+
+foo <> bar|
+
+will give you
+
+foo <> bar <> |
+
+or
+
+foo <> |bar
+
+will give you
+
+foo <> | <> bar
+
+This is more convenient than typing out the same operator."
+ (interactive)
+ (let* ((current-pair (shm-current-node-pair))
+ (current (cdr current-pair))
+ (parent-pair (shm-node-parent current-pair))
+ (parent (cdr parent-pair)))
+ (cond
+ ((eq 'InfixApp (shm-node-cons parent))
+ (let ((qop
+ (or (shm-get-qop-string (cdr (shm-node-previous current-pair)))
+ (shm-get-qop-string (cdr (shm-node-next current-pair))))))
+ (cond
+ (qop
+ (cond
+ ((= (point) (shm-node-start current))
+ (let ((point (point)))
+ (shm-insert-string (concat " " qop " "))
+ (goto-char point)))
+ ((= (point) (shm-node-end current))
+ (shm-insert-string (concat " " qop " ")))
+ (t (error "Please go to the start or end of the node to indicate direction."))))
+ (t (error "Unable to figure out the operator.")))))
+ (t (error "Not in an infix application.")))))
+
+(defun shm/raise ()
+ "Raise the expression up one, replacing its parent."
+ (interactive)
+ (let* ((current-pair (shm-current-node-pair))
+ (current (cdr current-pair))
+ (parent-pair (shm-node-parent current-pair (shm-node-type current)))
+ (parent (cdr parent-pair))
+ (actual-parent-pair (shm-node-parent current-pair)))
+ (cond
+ (parent
+ (if (string= (shm-node-type current)
+ (shm-node-type parent))
+ (let ((shm/raise-code (shm-kill-node 'buffer-substring-no-properties nil nil t)))
+ (shm-kill-node 'buffer-substring-no-properties parent)
+ (shm-insert-indented (lambda () (insert shm/raise-code)))
+ (shm/reparse))))
+ ((and (eq 'UnGuardedRhs (shm-node-cons (cdr actual-parent-pair)))
+ (eq 'Lambda (shm-node-cons current)))
+ (goto-char (shm-node-start current))
+ (delete-char 1)
+ (delete-region (point)
+ (search-backward-regexp "[ ]+=[ ]+"))
+ (insert " ")
+ (search-forward-regexp "[ ]*->")
+ (delete-region (- (point) 2)
+ (search-forward-regexp "[ ]+"))
+ (insert "= "))
+ (t
+ (error "No matching parent!")))))
+
+(defun shm/split-list ()
+ "Split the current list into two lists by the nearest comma."
+ (interactive)
+ (let ((current-pair (shm-current-node-pair)))
+ (while (not (eq 'List (shm-node-cons (cdr (shm-node-parent current-pair)))))
+ (setq current-pair (shm-node-parent current-pair)))
+ (let ((current (cdr current-pair)))
+ (cond
+ ((< (abs (- (point) (shm-node-start current)))
+ (abs (- (point) (shm-node-end current))))
+ (goto-char (shm-node-start current))
+ (when (looking-back ",")
+ (delete-char -1)))
+ (t
+ (goto-char (shm-node-end current))
+ (when (looking-at ",")
+ (delete-char 1))))
+ (insert "] ["))))
+
+(defun shm/comment ()
+ "Comment the current node, or if there is none, or some error,
+ fall back to `comment-dwim'. If the region is active, uses
+ `comment-dwim'."
+ (interactive)
+ (if (region-active-p)
+ (call-interactively 'comment-dwim)
+ (let ((current (shm-current-node)))
+ (cond
+ ((shm-in-comment)
+ (save-excursion
+ (unless (looking-at "{-")
+ (search-backward-regexp "{" nil nil 1))
+ (delete-region (point) (+ 2 (point)))
+ (search-forward-regexp "}" nil nil 1)
+ (delete-region (- (point) 2) (point))))
+ (current
+ (save-excursion
+ (goto-char (shm-node-start current))
+ (insert "{-")
+ (goto-char (shm-node-end current))
+ (insert "-}")
+ (font-lock-fontify-region (shm-node-start current)
+ (shm-node-end current))))
+ (t (call-interactively 'comment-dwim))))))
+
+(defun shm/qualify-import ()
+ "Toggle the qualification of the import at point."
+ (interactive)
+ (save-excursion
+ (let ((points (shm-decl-points)))
+ (goto-char (car points))
+ (shm/reparse)
+ (let ((current (shm-current-node)))
+ (when (and current
+ (string= "ImportDecl"
+ (shm-node-type-name current)))
+ (cond
+ ((looking-at "import[\n ]+qualified[ \n]+")
+ (search-forward-regexp "qualified" (shm-node-end current) t 1)
+ (delete-region (point)
+ (search-backward-regexp "qualified"))
+ (just-one-space 1))
+ (t
+ (search-forward-regexp "import")
+ (shm-insert-string " qualified")
+ (just-one-space 1))))))))
+
+(provide 'shm-manipulation)
diff --git a/elisp/shm-nav.el b/elisp/shm-nav.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-nav.el
@@ -0,0 +1,137 @@
+;;; shm-nav.el --- Navigation commands
+
+;; 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 .
+
+;;; Code:
+
+(require 'shm-macros)
+(require 'shm-layout)
+
+(defun shm/forward-paragraph ()
+ "Go forward one declaration."
+ (interactive)
+ (unless (/= (point)
+ (goto-char (cdr (shm-decl-points t))))
+ (search-forward-regexp "[^\n ]" nil t 1)
+ (backward-char)))
+
+(defun shm/backward-paragraph ()
+ "Go backward one declaration."
+ (interactive)
+ (unless (/= (point)
+ (goto-char (car (shm-decl-points t))))
+ (search-backward-regexp "[^\n ]" nil t 1)
+ (forward-char)))
+
+(defun shm/goto-where ()
+ "Either make or go to a where clause of the current right-hand-side."
+ (interactive)
+ (let ((node-pair (shm-current-node-pair))
+ (vector (shm-decl-ast)))
+ (loop for i
+ downfrom (car node-pair)
+ to -1
+ until (or (= i -1)
+ (let ((node (elt vector i)))
+ (and (string= "Rhs"
+ (shm-node-type-name node))
+ (<= (shm-node-start node)
+ (shm-node-start (cdr node-pair)))
+ (>= (shm-node-end node)
+ (shm-node-end (cdr node-pair))))))
+ finally (return
+ (when (>= i 0)
+ (let ((rhs (elt vector i)))
+ (goto-char (shm-node-end rhs))
+ (cond
+ ((looking-at "[\n ]*where")
+ (search-forward-regexp "where[ \n]*"))
+ (t
+ (unless (= (line-beginning-position) (point))
+ (newline))
+ (let ((indent (shm-node-start-column
+ (cdr (shm-node-parent (cons i rhs))))))
+ (indent-to (+ 2 indent))
+ (insert "where")
+ (if shm-indent-point-after-adding-where-clause
+ (progn
+ (insert "\n")
+ (indent-to (+ 4 indent)))
+ (insert " ")))))))))))
+
+(defun shm/goto-parent-end ()
+ "Set the current node overlay to the parent node, but go to the
+ end rather than the start."
+ (interactive)
+ (shm/goto-parent nil 'end))
+
+(defun shm/forward-node ()
+ "Go forward by node, i.e. go to the next of the current node. If
+we're already at the end of the current node, jump to the next
+node."
+ (interactive)
+ (let* ((current-pair (shm-current-node-pair))
+ (current (cdr current-pair)))
+ (if (= (point) (shm-node-end current))
+ (let ((next-pair (shm-node-next current-pair)))
+ (goto-char (shm-node-start (cdr next-pair))))
+ (progn (goto-char (shm-node-end current))
+ (setq shm-last-point (point))))))
+
+(defun shm/backward-node ()
+ "Go backward by node, i.e. go to the previous of the current node. If
+we're already at the start of the current node, jump to the previous
+node."
+ (interactive)
+ (let* ((current-pair (shm-current-node-pair))
+ (current (cdr current-pair)))
+ (if (= (point) (shm-node-start current))
+ (let ((prev-pair (shm-node-previous current-pair)))
+ (goto-char (shm-node-start (cdr prev-pair))))
+ (progn (goto-char (shm-node-start current))
+ (setq shm-last-point (point))))))
+
+(defun shm/close-paren ()
+ "Either insert a close paren or go to the end of the node."
+ (interactive)
+ (shm-with-fallback
+ self-insert-command
+ (if (shm-literal-insertion)
+ (shm-insert-string ")")
+ (progn (shm/reparse)
+ (shm/goto-parent-end)))))
+
+(defun shm/close-bracket ()
+ "Either insert a close bracket or go to the end of the node."
+ (interactive)
+ (shm-with-fallback
+ self-insert-command
+ (if (shm-literal-insertion)
+ (shm-insert-string "]")
+ (progn (shm/reparse)
+ (shm/goto-parent-end)))))
+
+(defun shm/close-brace ()
+ "Either insert a close brace or go to the end of the node."
+ (interactive)
+ (shm-with-fallback
+ self-insert-command
+ (if (shm-literal-insertion)
+ (shm-insert-string "}")
+ (progn (shm/reparse)
+ (shm/goto-parent-end)))))
+
+(provide 'shm-nav)
diff --git a/elisp/shm-navigation.el b/elisp/shm-navigation.el
deleted file mode 100644
--- a/elisp/shm-navigation.el
+++ /dev/null
@@ -1,117 +0,0 @@
-;;; shm-navigation.el --- Navigation functions that don't change the buffer
-
-;; 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 .
-
-;;; Code:
-
-(defun shm/forward-paragraph ()
- "Go forward one declaration."
- (interactive)
- (unless (/= (point)
- (goto-char (cdr (shm-decl-points))))
- (search-forward-regexp "[^\n ]" nil t 1)
- (backward-char)))
-
-(defun shm/backward-paragraph ()
- "Go backward one declaration."
- (interactive)
- (unless (/= (point)
- (goto-char (car (shm-decl-points))))
- (search-backward-regexp "[^\n ]" nil t 1)
- (forward-char)))
-
-(defun shm/close-paren ()
- "Either insert a close paren or go to the end of the node."
- (interactive)
- (shm-with-fallback
- self-insert-command
- (if (shm-literal-insertion)
- (shm-insert-string ")")
- (progn (shm/reparse)
- (shm/goto-parent-end)))))
-
-(defun shm/close-bracket ()
- "Either insert a close bracket or go to the end of the node."
- (interactive)
- (shm-with-fallback
- self-insert-command
- (if (shm-literal-insertion)
- (shm-insert-string "]")
- (progn (shm/reparse)
- (shm/goto-parent-end)))))
-
-(defun shm/close-brace ()
- "Either insert a close brace or go to the end of the node."
- (interactive)
- (shm-with-fallback
- self-insert-command
- (if (shm-literal-insertion)
- (shm-insert-string "}")
- (progn (shm/reparse)
- (shm/goto-parent-end)))))
-
-(defun shm/goto-parent-end ()
- "Set the current node overlay to the parent node, but go to the
- end rather than the start."
- (interactive)
- (shm/goto-parent nil 'end))
-
-(defun shm/forward-node ()
- "Go forward by node, i.e. go to the next of the current node. If
-we're already at the end of the current node, jump to the next
-node."
- (interactive)
- (let* ((current-pair (shm-current-node-pair))
- (current (cdr current-pair)))
- (if (= (point) (shm-node-end current))
- (let ((next-pair (shm-node-next current-pair)))
- (goto-char (shm-node-start (cdr next-pair))))
- (goto-char (shm-node-end current)))))
-
-(defun shm/backward-node ()
- "Go backward by node, i.e. go to the previous of the current node. If
-we're already at the start of the current node, jump to the previous
-node."
- (interactive)
- (let* ((current-pair (shm-current-node-pair))
- (current (cdr current-pair)))
- (if (= (point) (shm-node-start current))
- (let ((prev-pair (shm-node-previous current-pair)))
- (goto-char (shm-node-start (cdr prev-pair))))
- (goto-char (shm-node-start current)))))
-
-(defun shm/goto-parent (&optional node-pair direction)
- "Set the current node overlay to the parent node-pair"
- (interactive)
- (let ((direction (or direction 'start)))
- (if shm-current-node-overlay
- (let* ((o shm-current-node-overlay)
- (parent-pair (shm-node-parent (or node-pair
- (shm-current-workable-node)))))
- (when parent-pair
- (let ((parent (cdr parent-pair)))
- (if (and o
- (overlay-buffer o)
- (>= (shm-node-start parent)
- (overlay-start o))
- (<= (shm-node-end parent)
- (overlay-end o)))
- (shm/goto-parent parent-pair direction)
- (shm-set-node-overlay parent-pair direction)))))
- (when node-pair
- (shm-set-node-overlay node-pair direction)))))
-
-(provide 'shm-navigation)
diff --git a/elisp/shm-node.el b/elisp/shm-node.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-node.el
@@ -0,0 +1,109 @@
+;;; shm-node.el --- Node functions
+
+;; 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 .
+
+;;; Code:
+
+(require 'shm-customizations)
+(require 'shm-ast-documentation)
+
+(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-start-line (n)
+ "Get the starting line of N."
+ (save-excursion (goto-char (shm-node-start n))
+ (line-number-at-pos)))
+
+(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-node-string (n)
+ "Get the string of the region spanned by the node."
+ (buffer-substring-no-properties (shm-node-start n)
+ (shm-node-end n)))
+
+(defun shm-node-app-p (node)
+ "Is the given node an application of some kind?"
+ (or (eq (shm-node-cons node) 'App)
+ (eq (shm-node-cons node) 'InfixApp)
+ (eq (shm-node-cons node) 'TyApp)))
+
+(provide 'shm-node)
diff --git a/elisp/shm-nodes.el b/elisp/shm-nodes.el
deleted file mode 100644
--- a/elisp/shm-nodes.el
+++ /dev/null
@@ -1,348 +0,0 @@
-;;; 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 .
-
-;;; 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)
diff --git a/elisp/shm-overlays.el b/elisp/shm-overlays.el
--- a/elisp/shm-overlays.el
+++ b/elisp/shm-overlays.el
@@ -1,4 +1,4 @@
-;;; shm-overlays.el --- Error and current node overlays
+;;; shm-overlays.el --- Overlays
;; Copyright (c) 2014 Chris Done. All rights reserved.
@@ -17,29 +17,17 @@
;;; Code:
-
-;; Requirements
-
-(require 'shm-globals)
-
-
-;; Buffer locals
+(require 'cl)
+(require 'shm-node)
(defvar shm-current-node-overlay nil
"Overlay to highlight the current node.")
-
-;; Functions
-
-(defun shm/init (&optional force-renew)
- "Initialize the current node overlay at point.
-
-FORCE-RENEW would be used when the buffer has changed and
-therefore the current overlay should be re-initialized."
- (interactive)
- (when force-renew
- (setq shm-current-node-overlay nil))
- (shm-set-node-overlay))
+(defvar shm-last-point 0
+ "When moving around, the current node overlay will update
+ according to where you are. But often you can shrink/expand the
+ scope of the current node. This variable lets us avoid the node
+ being reset by realising we haven't actually moved the point.")
(defun shm-delete-overlays (start end type)
"Delete overlays of the given type. This is used for both
@@ -49,11 +37,6 @@
(delete-overlay o)))
(overlays-in start end)))
-(defun shm-find-overlay (type)
- "Find overlays at point."
- (remove-if-not (lambda (o) (overlay-get o type))
- (overlays-in (point-min) (point-max))))
-
(defun shm-current-overlay (start end node-pair)
"Make the overlay for current node at START to END, setting the
NODE-PAIR in the overlay."
@@ -72,25 +55,9 @@
(overlay-put o 'priority 0)
o))
-(defun shm-set-node-overlay (&optional node-pair jump-direction)
- "Set the current overlay for the current node. Optionally pass
-NODE-PAIR to use the specific node-pair (index + node)."
- (setq shm-current-node-overlay nil)
- (shm-delete-overlays (point-min)
- (point-max)
- 'shm-current-overlay)
- (let* ((node-pair (or node-pair
- (shm-current-node-pair)))
- (node (cdr node-pair)))
- (when jump-direction
- (if (eq jump-direction 'end)
- (goto-char (shm-node-end node))
- (goto-char (shm-node-start node))))
- (setq shm-last-point (point))
- (setq shm-current-node-overlay
- (when node
- (shm-current-overlay (shm-node-start node)
- (shm-node-end node)
- node-pair)))))
+(defun shm-find-overlay (type)
+ "Find overlays at point."
+ (remove-if-not (lambda (o) (overlay-get o type))
+ (overlays-in (point-min) (point-max))))
(provide 'shm-overlays)
diff --git a/elisp/shm-simple-indent.el b/elisp/shm-simple-indent.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-simple-indent.el
@@ -0,0 +1,105 @@
+;;; shm-simple-indent.el --- Simple indentation
+
+;; 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 .
+
+;;; Code:
+
+(require 'shm-layout)
+
+(defun shm/simple-indent ()
+ "Space out to under next visible indent point.
+Indent points are positions of non-whitespace following whitespace in
+lines preceeding point. A position is visible if it is to the left of
+the first non-whitespace of every nonblank line between the position and
+the current line. If there is no visible indent point beyond the current
+column, `tab-to-tab-stop' is done instead."
+ (interactive)
+ (let* ((start-column (current-column))
+ (invisible-from nil) ; `nil' means infinity here
+ (indent
+ (catch 'shm-simple-indent-break
+ (save-excursion
+ (while (progn (beginning-of-line)
+ (not (bobp)))
+ (forward-line -1)
+ (if (not (looking-at "[ \t]*\n"))
+ (let ((this-indentation (current-indentation)))
+ (if (or (not invisible-from)
+ (< this-indentation invisible-from))
+ (if (> this-indentation start-column)
+ (setq invisible-from this-indentation)
+ (let ((end (line-beginning-position 2)))
+ (move-to-column start-column)
+ ;; Is start-column inside a tab on this line?
+ (if (> (current-column) start-column)
+ (backward-char 1))
+ (or (looking-at "[ \t]")
+ (skip-chars-forward "^ \t" end))
+ (skip-chars-forward " \t" end)
+ (let ((col (current-column)))
+ (throw 'shm-simple-indent-break
+ (if (or (= (point) end)
+ (and invisible-from
+ (> col invisible-from)))
+ invisible-from
+ col)))))))))))))
+ (if indent
+ (let ((opoint (point-marker)))
+ (indent-line-to indent)
+ (if (> opoint (point))
+ (goto-char opoint))
+ (set-marker opoint nil))
+ (tab-to-tab-stop))))
+
+(defun shm/simple-indent-backtab ()
+ "Indent backwards. Dual to `shm-simple-indent'."
+ (interactive)
+ (let ((current-point (point))
+ (i 0)
+ (x 0))
+ (goto-char (line-beginning-position))
+ (save-excursion
+ (while (< (point) current-point)
+ (shm/simple-indent)
+ (setq i (+ i 1))))
+ (while (< x (- i 1))
+ (shm/simple-indent)
+ (setq x (+ x 1)))))
+
+(defun shm/simple-indent-newline-same-col ()
+ "Make a newline and go to the same column as the current line."
+ (interactive)
+ (let ((point (point)))
+ (let ((start-end
+ (save-excursion
+ (let* ((start (line-beginning-position))
+ (end (progn (goto-char start)
+ (search-forward-regexp
+ "[^ ]" (line-end-position) t 1))))
+ (when end (cons start (1- end)))))))
+ (if start-end
+ (progn (newline)
+ (insert (buffer-substring-no-properties
+ (car start-end) (cdr start-end))))
+ (newline)))))
+
+(defun shm/simple-indent-newline-indent ()
+ "Make a newline on the current column and indent on step."
+ (interactive)
+ (shm/simple-indent-newline-same-col)
+ (insert (make-string (shm-indent-spaces) ? )))
+
+(provide 'shm-simple-indent)
diff --git a/elisp/shm-skeletons.el b/elisp/shm-skeletons.el
deleted file mode 100644
--- a/elisp/shm-skeletons.el
+++ /dev/null
@@ -1,163 +0,0 @@
-;;; shm-skeletons.el --- Skeleton syntax templates
-
-;; 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 .
-
-;;; Code:
-
-(require 'shm-evaporate)
-
-(defun shm-auto-insert-stmt (type)
- "Insert template
-
-do x <- |
- {undefined}
-"
- (let* ((current (shm-current-node))
- (column (save-excursion
- (case type
- ('let (backward-word 1)
- (current-column))
- ('qualifier
- (cond
- ((eq 'Do (shm-node-cons current))
- (goto-char (shm-node-start current))
- (forward-char 2)
- (search-forward-regexp "[^ \n]")
- (1- (current-column)))
- (t (goto-char (shm-node-start current))
- (current-column))))))))
- (unless (save-excursion
- (let ((current-line (line-number-at-pos)))
- (forward-line 1)
- (goto-char (+ (line-beginning-position)
- column))
- (and (not (bolp))
- (/= current-line (line-number-at-pos))
- (= (point)
- (save-excursion (back-to-indentation)
- (point))))))
- (save-excursion
- (newline)
- (indent-to column)
- (insert "undefined")
- (forward-word -1)
- (shm/reparse)
- (shm-evaporate (point)
- (progn (forward-word 1)
- (point)))))
- (insert " ")))
-
-(defun shm-auto-insert-do ()
- "Insert template
-
-do {undefined}
- {undefined}
-"
- (insert " ")
- (let ((point (point))
- (column (current-column)))
- (insert "undefined")
- (newline)
- (indent-to column)
- (let ((next-point (point)))
- (insert "undefined")
- (goto-char point)
- (shm/reparse)
- (save-excursion
- (shm-evaporate (point) (+ (point) (length "undefined")))
- (goto-char next-point)
- (shm-evaporate (point) (+ (point) (length "undefined")))))))
-
-(defun shm-auto-insert-case ()
- "Insert template
-
-case {undefined} of
- {_} -> {undefined}
-"
- (let ((start (save-excursion (forward-char -1)
- (search-backward-regexp "[^a-zA-Z0-9_]")
- (forward-char 1)
- (point)))
- (template "case undefined of\n _ -> undefined"))
- (shm-adjust-dependents (point) (- start (point)))
- (delete-region start (point))
- (shm-adjust-dependents (point) (length (car (last (split-string template "\n")))))
- (shm-insert-indented
- (lambda ()
- (insert template)))
- (forward-char 5)
- (shm/reparse)
- (save-excursion
- (shm-evaporate (point) (+ (point) (length "undefined")))
- (search-forward-regexp "_" nil nil 1)
- (shm-evaporate (1- (point)) (point))
- (forward-char 4)
- (shm-evaporate (point) (+ (point) (length "undefined"))))))
-
-(defun shm-auto-insert-if ()
- "Insert template
-
-if {undefined}
- then {undefined}
- else {undefined}
-
-or
-
-if {undefined} then {undefined} else {undefined}
-
-if inside parentheses."
- (let ((start (save-excursion (forward-char -1)
- (search-backward-regexp "[^a-zA-Z0-9_]")
- (forward-char 1)
- (point)))
- (template (if (looking-at "$")
- "if undefined\n then undefined\n else undefined"
- "if undefined then undefined else undefined")))
- (shm-adjust-dependents (point) (- start (point)))
- (delete-region start (point))
- (shm-adjust-dependents (point) (length (car (last (split-string template "\n")))))
- (shm-insert-indented
- (lambda ()
- (insert template)))
- (forward-char 3)
- (save-excursion
- (shm-evaporate (point) (+ (point) (length "undefined")))
- (search-forward-regexp "then ")
- (shm-evaporate (point) (+ (point) (length "undefined")))
- (search-forward-regexp "else ")
- (shm-evaporate (point) (+ (point) (length "undefined"))))))
-
-(defun shm-auto-insert-let ()
- "Insert template
-
-let | in {undefined}"
- (delete-region (- (point) 3) (point))
- (shm-insert-indented (lambda () (insert "let \nin undefined")))
- (forward-char 4)
- (save-excursion
- (forward-word)
- (forward-char 1)
- (shm-evaporate (point) (+ (point) (length "undefined")))))
-
-(defun shm-auto-insert-module ()
- "Insert template
-
-module | where"
- (insert " where")
- (backward-word 1)
- (forward-char -1))
-
-(provide 'shm-skeletons)
diff --git a/elisp/shm-slot.el b/elisp/shm-slot.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-slot.el
@@ -0,0 +1,193 @@
+;;; shm-slot.el --- Slots for shm
+
+;; 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 .
+
+;;; Code:
+
+(require 'shm-evaporate)
+(require 'shm-layout)
+
+(require 'cl)
+
+(defun shm/jump-to-slot ()
+ "Jump to the next skeleton slot."
+ (interactive)
+ (let ((os (sort (remove-if-not (lambda (o) (overlay-get o 'shm-evaporate-overlay))
+ (overlays-in (point) (point-max)))
+ (lambda (a b)
+ (< (overlay-start a)
+ (overlay-start b))))))
+ (when os
+ (if (= (overlay-start (car os))
+ (point))
+ (when (cadr os)
+ (goto-char (overlay-start (cadr os))))
+ (goto-char (overlay-start (car os)))))))
+
+(defun shm/jump-to-previous-slot ()
+ "Jump to the previous skeleton slot."
+ (interactive)
+ (let ((os (sort (remove-if-not (lambda (o) (overlay-get o 'shm-evaporate-overlay))
+ (overlays-in (point-min) (point)))
+ (lambda (a b)
+ (> (overlay-start a)
+ (overlay-start b))))))
+ (when os
+ (if (= (overlay-start (car os))
+ (point))
+ (when (cadr os)
+ (goto-char (overlay-start (cadr os))))
+ (goto-char (overlay-start (car os)))))))
+
+(defun shm/insert-undefined ()
+ "Insert undefined."
+ (interactive)
+ (save-excursion
+ (let ((point (point)))
+ (shm-insert-string "undefined")
+ (shm-evaporate point (point)))))
+
+(defun shm-auto-insert-do ()
+ "Insert template
+
+do {undefined}
+ {undefined}
+"
+ (insert " ")
+ (let ((point (point))
+ (column (current-column)))
+ (insert "undefined")
+ (cond
+ ((bound-and-true-p structured-haskell-repl-mode)
+ (forward-word -1)
+ (shm/reparse)
+ (save-excursion
+ (shm-evaporate (point) (+ (point) (length "undefined")))))
+ (t (newline)
+ (indent-to column)
+ (let ((next-point (point)))
+ (insert "undefined")
+ (goto-char point)
+ (shm/reparse)
+ (save-excursion
+ (shm-evaporate (point) (+ (point) (length "undefined")))
+ (goto-char next-point)
+ (shm-evaporate (point) (+ (point) (length "undefined")))))))))
+
+(defun shm-auto-insert-case ()
+ "Insert template
+
+case {undefined} of
+ {_} -> {undefined}
+"
+ (let ((start (save-excursion (forward-char -1)
+ (search-backward-regexp "[^a-zA-Z0-9_]")
+ (forward-char 1)
+ (point)))
+ (template (if (bound-and-true-p structured-haskell-repl-mode)
+ "case undefined of _ -> undefined"
+ "case undefined of\n _ -> undefined")))
+ (shm-adjust-dependents (point) (- start (point)))
+ (delete-region start (point))
+ (shm-adjust-dependents (point) (length (car (last (split-string template "\n")))))
+ (shm-insert-indented
+ (lambda ()
+ (insert template)))
+ (forward-char 5)
+ (shm/reparse)
+ (save-excursion
+ (shm-evaporate (point) (+ (point) (length "undefined")))
+ (search-forward-regexp "_" nil nil 1)
+ (shm-evaporate (1- (point)) (point))
+ (forward-char 4)
+ (shm-evaporate (point) (+ (point) (length "undefined"))))))
+
+(defun shm-auto-insert-if ()
+ "Insert template
+
+if {undefined}
+ then {undefined}
+ else {undefined}
+
+or
+
+if {undefined} then {undefined} else {undefined}
+
+if inside parentheses."
+ (let ((start (save-excursion (forward-char -1)
+ (search-backward-regexp "[^a-zA-Z0-9_]")
+ (forward-char 1)
+ (point)))
+ (template (if (bound-and-true-p structured-haskell-repl-mode)
+ "if undefined then undefined else undefined"
+ "if undefined\n then undefined\n else undefined")))
+ (shm-adjust-dependents (point) (- start (point)))
+ (delete-region start (point))
+ (shm-adjust-dependents (point) (length (car (last (split-string template "\n")))))
+ (shm-insert-indented
+ (lambda ()
+ (insert template)))
+ (forward-char 3)
+ (save-excursion
+ (shm-evaporate (point) (+ (point) (length "undefined")))
+ (search-forward-regexp "then ")
+ (shm-evaporate (point) (+ (point) (length "undefined")))
+ (search-forward-regexp "else ")
+ (shm-evaporate (point) (+ (point) (length "undefined"))))))
+
+(defun shm-auto-insert-let ()
+ "Insert template
+
+let | in {undefined}"
+ (delete-region (- (point) 3) (point))
+ ;; If needs to be nested this way. Don't change it.
+ (cl-flet
+ ((evaporate-in ()
+ (forward-char 4)
+ (save-excursion
+ (forward-word)
+ (forward-char 1)
+ (shm-evaporate (point) (+ (point) (length "undefined"))))))
+ (if (bound-and-true-p structured-haskell-repl-mode)
+ (let ((points (shm-decl-points)))
+ (if points
+ (if (= (point) (car points))
+ (progn (shm-insert-indented
+ (lambda () (insert "let _ = undefined")))
+ (search-forward "_")
+ (shm-evaporate (1- (point)) (point))
+ (forward-word 1)
+ (forward-word -1)
+ (shm-evaporate (point) (+ (point) (length "undefined")))
+ (search-backward "_"))
+ (progn (shm-insert-indented
+ (lambda () (insert "let in undefined")))
+ (evaporate-in)))
+ (insert "let ")))
+ (progn (shm-insert-indented
+ (lambda () (insert "let \nin undefined")))
+ (evaporate-in))))
+ (shm/reparse))
+
+(defun shm-auto-insert-module ()
+ "Insert template
+
+module | where"
+ (insert " where")
+ (backward-word 1)
+ (forward-char -1))
+
+(provide 'shm-slot)
diff --git a/elisp/shm-strings.el b/elisp/shm-strings.el
deleted file mode 100644
--- a/elisp/shm-strings.el
+++ /dev/null
@@ -1,88 +0,0 @@
-;;; shm-strings.el --- String literal editing
-
-;; 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 .
-
-;;; Code:
-
-
-;; Requirements
-
-(require 'shm-nodes)
-(require 'shm-yank-kill)
-(require 'shm-deletion)
-
-
-;; Globals
-
-(defvar shm-string-node nil
- "The string node that's currently being edited.")
-
-(defvar shm-string-buffer nil
- "The buffer of the string node that's currently being edited.")
-
-
-;; Mode
-
-(define-derived-mode shm-edit-string-mode
- text-mode "String"
- "Major mode for editing string content from a Haskell string.")
-
-(define-key shm-edit-string-mode-map (kbd "C-c C-c") 'shm-finish-editing-string)
-
-(defun shm/edit-string ()
- "Edit the string at point."
- (interactive)
- (let ((current (shm-current-node))
- (buffer (current-buffer))
- (string (shm-kill-node 'buffer-substring-no-properties nil nil t)))
- (goto-char (shm-node-start current))
- (switch-to-buffer (get-buffer-create "*shm-string*"))
- (erase-buffer)
- (insert
- (replace-regexp-in-string
- "\\\\\"" "\""
- (replace-regexp-in-string
- "\\\\n" "\n"
- (replace-regexp-in-string
- "^\"\\(.*\\)\"$" "\\1"
- (replace-regexp-in-string
- "\\\\\n\\\\" ""
- string)))))
- (shm-edit-string-mode)
- (set (make-local-variable 'shm-string-node)
- current)
- (set (make-local-variable 'shm-string-buffer)
- buffer)
- (goto-char (point-min))))
-
-(defun shm-finish-editing-string ()
- "Take the contents of the buffer and insert it back into the
-original node in the Haskell buffer, replacing the old one."
- (interactive)
- (let ((finish-string (buffer-string))
- (buffer shm-string-buffer))
- (quit-window)
- (switch-to-buffer buffer)
- (shm/delete)
- (insert "\"\"")
- (forward-char -1)
- (save-excursion
- (font-lock-fontify-region (line-beginning-position)
- (line-end-position)))
- (shm-insert-indented (lambda () (insert finish-string)))
- (forward-char -1)))
-
-(provide 'shm-strings)
diff --git a/elisp/shm-test.el b/elisp/shm-test.el
--- a/elisp/shm-test.el
+++ b/elisp/shm-test.el
@@ -21,15 +21,15 @@
;;; Code:
-(require 'shm)
(require 'shm-tests)
-(require 'shm-overlays)
+(require 'shm)
(defvar shm-test-eob nil)
(defun shm-test/run-all ()
"Run all tests."
(interactive)
+ (setq shm-colon-enabled t)
(when (remove-if-not #'identity
(mapcar #'shm-test/run shm-tests))
(message "All tests passed OK.")))
@@ -117,27 +117,70 @@
(defun shm-test/run (test)
"Run the given test and validate it."
- (message "Running %s ..." (plist-get test :name))
+ (message "Testing %s..." (plist-get test :name))
(switch-to-buffer-other-window (get-buffer-create "*shm-test*"))
(erase-buffer)
+ (kill-all-local-variables)
(when (fboundp 'god-local-mode)
(god-local-mode -1))
+ (let ((customizations (plist-get test :customizations)))
+ (when customizations
+ (dolist (entry customizations)
+ (set (make-local-variable (car entry))
+ (cdr entry)))))
(structured-haskell-mode 1)
(insert (plist-get test :start-buffer-content))
(goto-char (plist-get test :start-cursor))
(shm/reparse)
(execute-kbd-macro (plist-get test :kbd))
- (shm-test-validate test))
+ (shm-test-validate test)
+ (shm-mode-stop))
(defun shm-test-validate (test)
"Validate the given test."
- (assert (string= (buffer-substring-no-properties (point-min) (point-max))
- (plist-get test :end-buffer-content)))
- (assert (= (plist-get test :finish-cursor)
- (point)))
- (message "%s: OK" (plist-get test :name))
+ (let ((name (plist-get test :name)))
+ (let ((actual (buffer-substring-no-properties (point-min) (point-max)))
+ (expected (plist-get test :end-buffer-content)))
+ (unless (string= actual expected)
+ (error "\nTest failed, differing buffer contents.
+
+Original:
+
+%s
+
+Expected (quoted):
+
+%s
+
+Actual (quoted):
+
+%s\n"
+ (plist-get test :start-buffer-content)
+ (shm-test-exact-quote expected)
+ (shm-test-exact-quote actual))))
+ (let ((actual (point))
+ (expected (plist-get test :finish-cursor)))
+ (unless (= actual expected)
+ (error "\nTest failed, differing cursor positions.
+
+Expected:
+
+%d
+
+Actual:
+
+%d\n"
+ expected actual))))
(kill-buffer)
t)
+
+(defun shm-test-exact-quote (s)
+ "Quote a string exactly, so you can see any details or differences in whitespace."
+ (mapconcat 'identity
+ (mapcar (lambda (l)
+ (concat "\"" l "\""))
+ (split-string s "\n"))
+ "\n"))
(provide 'shm-test)
diff --git a/elisp/shm-tests.el b/elisp/shm-tests.el
--- a/elisp/shm-tests.el
+++ b/elisp/shm-tests.el
@@ -21,8 +21,138 @@
;;; Code:
+(defvar shm-tests-that-dont-run-in-batch-mode
+ (list
+ (list :name "yanking"
+ :start-buffer-content "main = (case undefined of
+ _ -> undefined
+ ,putStrLn (if undefined
+ then undefined
+ else undefined)
+ ,23 * 45)
+"
+ :start-cursor 9
+ :finish-cursor 9
+ :current-node-overlay '(9 11)
+ :end-buffer-content "main = (23 * 45
+ ,putStrLn (if undefined
+ then undefined
+ else undefined)
+ ,case undefined of
+ _ -> undefined)
+"
+ :kbd " \371\371\371\371\371\371")))
+
(defvar shm-tests
(list
+ (list :name "don't re-indent dependent rhs"
+ :start-buffer-content "foo bar baz =
+ bar + baz
+"
+ :start-cursor 4
+ :finish-cursor 9
+ :current-node-overlay '(1 9)
+ :end-buffer-content "foohello bar baz =
+ bar + baz
+"
+ :kbd "hello")
+ (list :name "add-initial-type-constraint"
+ :start-buffer-content "fn :: a -> b
+"
+ :start-cursor 13
+ :finish-cursor 7
+ :current-node-overlay '(7 12)
+ :end-buffer-content "fn :: => a -> b
+"
+ :kbd [41 134217848 115 104 109 47 109 111 100 tab return])
+
+ (list :name "add-additional-type-constraint-no-parens"
+ :start-buffer-content "fn :: Eq a => a -> a
+"
+ :start-cursor 21
+ :finish-cursor 14
+ :current-node-overlay '(11 15)
+ :end-buffer-content "fn :: (Eq a, ) => a -> a
+"
+ :kbd [41 41 134217848 115 104 109 47 109 111 tab return])
+
+ (list :name "add-addtional-type-constraint-parens"
+ :start-buffer-content "fn :: (Ord s, Eq a, Monad m) => StateT s m a
+"
+ :start-cursor 45
+ :finish-cursor 30
+ :current-node-overlay '(27 30)
+ :end-buffer-content "fn :: (Ord s, Eq a, Monad m, ) => StateT s m a
+"
+ :kbd [41 41 134217848 115 104 109 47 109 111 tab return])
+
+ (list :name "newline-indent-type-sig-arrows"
+ :start-buffer-content "outputWith :: Show a => String -> String -> String -> IO ()
+"
+ :start-cursor 22
+ :finish-cursor 56
+ :current-node-overlay '(37 84)
+ :end-buffer-content "outputWith :: Show a \n => String \n -> String -> String -> IO ()
+"
+ :kbd "
+\346
+")
+ (list :name "newline-indent-type-sig"
+ :start-buffer-content "outputWith :: String -> String -> String -> IO ()
+"
+ :start-cursor 25
+ :finish-cursor 40
+ :current-node-overlay '(40 46)
+ :end-buffer-content "outputWith :: String -> \n String -> String -> IO ()
+"
+ :kbd "
+")
+ (list :name "qualify-import"
+ :start-buffer-content "import qualified Data.Conduit.List as CL
+"
+ :start-cursor 31
+ :finish-cursor 31
+ :current-node-overlay '(18 35)
+ :end-buffer-content "import qualified Data.Conduit.List as CL
+"
+ :kbd "")
+ (list :name "split-list"
+ :start-buffer-content "main = print [foo,bar,mu]
+"
+ :start-cursor 19
+ :finish-cursor 21
+ :current-node-overlay '(21 24)
+ :end-buffer-content "main = print [foo] [bar,mu]
+"
+ :kbd [134217848 115 104 109 47 115 112 108 105 116 45 108 105 115 116 return])
+ (list :name "wrap-delimiters"
+ :start-buffer-content "main = do bar
+ mu
+ zot
+"
+ :start-cursor 8
+ :finish-cursor 9
+ :current-node-overlay '(9 44)
+ :end-buffer-content "main = [do bar
+ mu
+ zot]
+"
+ :kbd [201326624 91])
+ (list :name "move-by-paragraphs"
+ :start-buffer-content "clockOut config project task reason = foo
+-- | Clock in or out.
+clock :: Config -> Entry -> IO ()
+
+"
+ :start-cursor 1
+ :finish-cursor 1
+ :current-node-overlay '(1 9)
+ :end-buffer-content "clockOut config project task reason = foo
+-- | Clock in or out.
+clock :: Config -> Entry -> IO ()
+
+"
+ :kbd "\375\375\375\375\375\373\373\373\373\373")
(list :name "skip-trailing-comments"
:start-buffer-content "foo = do foo
let bar = 23
@@ -241,18 +371,27 @@
"
:kbd [delete backspace])
(list :name "kill-line"
- :start-buffer-content "main = do putStrLn (foo bar mu)
- case x y z of
- Just p -> x
+ :start-buffer-content "main = do putStrLn (f bar mu)
"
:start-cursor 21
- :finish-cursor 38
- :current-node-overlay '(38 38)
+ :finish-cursor 21
+ :current-node-overlay '(20 22)
:end-buffer-content "main = do putStrLn ()
- case of
+"
+ :kbd " ")
+ (list :name "kill-line-rest"
+ :start-buffer-content "main = do putStrLn
+ (foo bar mu)
+ case x y z of
Just p -> x
+
"
- :kbd " ")
+ :start-cursor 56
+ :finish-cursor 56
+ :current-node-overlay 'nil
+ :end-buffer-content "main = do putStrLn
+ (foo bar mu)\n \n"
+ :kbd " ")
(list :name "isearch"
:start-buffer-content "main = do foo
bar
@@ -407,11 +546,38 @@
:start-buffer-content "{}
"
:start-cursor 2
- :finish-cursor 5
+ :finish-cursor 23
:current-node-overlay 'nil
- :end-buffer-content "{-# #-}
+ :end-buffer-content "{-# LANGUAGE Haskell98 #-}
"
- :kbd "-#")))
+ :kbd "-#")
+ (list :name "where-clause"
+ :start-buffer-content "fn :: a -> b
+fn x = y + y
+"
+ :start-cursor 19
+ :finish-cursor 36
+ :current-node-overlay 'nil
+ :end-buffer-content "fn :: a -> b
+fn x = y + y
+ where y
+"
+ :kbd [?\M-x ?s ?h ?m ?/ ?g ?o ?t ?o ?- ?w ?h ?e ?r ?e return ?y])
+ (list :name "where-clause with indentation"
+ :start-buffer-content "fn :: a -> b
+fn x = y + y
+"
+ :start-cursor 19
+ :finish-cursor 40
+ :current-node-overlay 'nil
+ :end-buffer-content "fn :: a -> b
+fn x = y + y
+ where
+ y
+"
+ :kbd [?\M-x ?s ?h ?m ?/ ?g ?o ?t ?o ?- ?w ?h ?e ?r ?e return ?y]
+ :customizations
+ '((shm-indent-point-after-adding-where-clause t)))))
(provide 'shm-tests)
diff --git a/elisp/shm-transform.el b/elisp/shm-transform.el
deleted file mode 100644
--- a/elisp/shm-transform.el
+++ /dev/null
@@ -1,84 +0,0 @@
-;;; shm-transform.el --- General code transformations
-
-;; 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 .
-
-;;; Code:
-
-(defun shm/add-operand ()
- "When in an infix application, figure out the operator and add
-a new operand. E.g.
-
-foo <> bar|
-
-will give you
-
-foo <> bar <> |
-
-or
-
-foo <> |bar
-
-will give you
-
-foo <> | <> bar
-
-This is more convenient than typing out the same operator."
- (interactive)
- (let* ((current-pair (shm-current-node-pair))
- (current (cdr current-pair))
- (parent-pair (shm-node-parent current-pair))
- (parent (cdr parent-pair)))
- (cond
- ((eq 'InfixApp (shm-node-cons parent))
- (let ((qop
- (or (shm-get-qop-string (cdr (shm-node-previous current-pair)))
- (shm-get-qop-string (cdr (shm-node-next current-pair))))))
- (cond
- (qop
- (cond
- ((= (point) (shm-node-start current))
- (let ((point (point)))
- (shm-insert-string (concat " " qop " "))
- (goto-char point)))
- ((= (point) (shm-node-end current))
- (shm-insert-string (concat " " qop " ")))
- (t (error "Please go to the start or end of the node to indicate direction."))))
- (t (error "Unable to figure out the operator.")))))
- (t (error "Not in an infix application.")))))
-
-(defun shm/raise ()
- "Raise the expression up one, replacing its parent."
- (interactive)
- (let* ((current-pair (shm-current-node-pair))
- (current (cdr current-pair))
- (parent-pair (shm-node-parent current-pair (shm-node-type current)))
- (parent (cdr parent-pair)))
- (if parent
- (if (string= (shm-node-type current)
- (shm-node-type parent))
- (let ((shm/raise-code (shm-kill-node 'buffer-substring-no-properties nil nil t)))
- (shm-kill-node 'buffer-substring-no-properties parent)
- (shm-insert-indented (lambda () (insert shm/raise-code)))
- (shm/reparse)))
- (error "No matching parent!"))))
-
-(defun shm-get-qop-string (node)
- "Get the string of the operator, if the node is an operator."
- (when (string= (shm-node-type-name node) "QOp")
- (buffer-substring-no-properties (shm-node-start node)
- (shm-node-end node))))
-
-(provide 'shm-transform)
diff --git a/elisp/shm-type.el b/elisp/shm-type.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-type.el
@@ -0,0 +1,116 @@
+;;; shm-type.el --- Type info for nodes
+
+;; 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 .
+
+;;; Code:
+
+(require 'shm-layout)
+
+(defun shm/type-of-node ()
+ (interactive)
+ (let ((current (shm-current-node)))
+ (cond
+ ((or (string= (shm-node-type-name current) "Exp")
+ (string= (shm-node-type-name current) "Decl")
+ (string= (shm-node-type-name current) "Pat")
+ (string= (shm-node-type-name current) "QOp"))
+ (let ((type-info (shm-node-type-info current)))
+ (if type-info
+ (shm-present-type-info current type-info)
+ (if (and shm-type-info-fallback-to-ghci
+ (fboundp 'haskell-process-do-type))
+ (haskell-process-do-type)
+ (error "Unable to get type information for that node.")))))
+ ((and (string= (shm-node-type-name current) "Name")
+ (let ((parent-name (shm-node-type-name (cdr (shm-node-parent (shm-current-node-pair))))))
+ (or (string= parent-name "Match")
+ (string= parent-name "Decl"))))
+ (let* ((node (cdr (shm-node-parent (shm-current-node-pair))))
+ (type-info (shm-node-type-info node)))
+ (if type-info
+ (shm-present-type-info node type-info)
+ (if (and shm-type-info-fallback-to-ghci
+ (fboundp 'haskell-process-do-type))
+ (haskell-process-do-type)
+ (error "Unable to get type information for that node (tried the whole decl, too).")))))
+ (t (error "Not an expression, operator, pattern binding or declaration.")))))
+
+(defun shm-present-type-info (node info)
+ "Present type info to the user."
+ (let ((info. (concat (shm-kill-node 'buffer-substring-no-properties node nil t)
+ " :: "
+ info)))
+ (if shm-use-presentation-mode
+ (if (fboundp 'haskell-present)
+ (haskell-present "SHM-Node"
+ nil
+ info.)
+ (message "%s" info))
+ (message "%s" info))))
+
+(defun shm-type-of-region (beg end)
+ "Get a type for the region."
+ (let ((types (shm-types-at-point beg)))
+ (loop for type
+ in types
+ do (when (and (= (elt type 0) beg)
+ (= (elt type 1)
+ end))
+ (return (elt type 2))))))
+
+(defun shm-types-at-point (point)
+ "Get a list of spans and types for the current point."
+ (save-excursion
+ (goto-char point)
+ (let ((line (line-number-at-pos))
+ (col (1+ (current-column)))
+ (file-name (buffer-file-name)))
+ (cond
+ (shm-use-hdevtools
+ (shm-parse-hdevtools-type-info
+ (with-temp-buffer
+ (call-process "hdevtools" nil t nil "type" "-g" "-fdefer-type-errors"
+ file-name
+ (number-to-string line)
+ (number-to-string col))
+ (buffer-string))))))))
+
+(defun shm-parse-hdevtools-type-info (string)
+ "Parse type information from the output of hdevtools."
+ (let ((lines (split-string string "\n+")))
+ (loop for line
+ in lines
+ while (string-match "\\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\) \"\\(.+\\)\"$"
+ line)
+ do (goto-char (point-min))
+ collect
+ (let ((start-line (string-to-number (match-string 1 line)))
+ (end-line (string-to-number (match-string 3 line))))
+ (vector (progn (forward-line (1- start-line))
+ (+ (line-beginning-position)
+ (1- (string-to-number (match-string 2 line)))))
+ (progn (when (/= start-line end-line)
+ (forward-line (1- (- start-line end-line))))
+ (+ (line-beginning-position)
+ (1- (string-to-number (match-string 4 line)))))
+ (match-string 5 line))))))
+
+(defun shm-node-type-info (node)
+ "Get the type of the given node."
+ (shm-type-of-region (shm-node-start node)
+ (shm-node-end node)))
+
+(provide 'shm-type)
diff --git a/elisp/shm-types.el b/elisp/shm-types.el
deleted file mode 100644
--- a/elisp/shm-types.el
+++ /dev/null
@@ -1,90 +0,0 @@
-;;; shm-types.el --- Type info/type-directed things
-
-;; 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 .
-
-;;; Code:
-
-
-;; Requirements
-
-(require 'shm-customizations)
-
-(defun shm-present-type-info (node info)
- "Present type info to the user."
- (let ((info. (concat (shm-kill-node 'buffer-substring-no-properties node nil t)
- " :: "
- info)))
- (if shm-use-presentation-mode
- (if (fboundp 'haskell-present)
- (haskell-present "SHM-Node"
- nil
- info.)
- (message "%s" info))
- (message "%s" info))))
-
-(defun shm-node-type-info (node)
- "Get the type of the given node."
- (shm-type-of-region (shm-node-start node)
- (shm-node-end node)))
-
-(defun shm-type-of-region (beg end)
- "Get a type for the region."
- (let ((types (shm-types-at-point beg)))
- (loop for type
- in types
- do (when (and (= (elt type 0) beg)
- (= (elt type 1)
- end))
- (return (elt type 2))))))
-
-(defun shm-types-at-point (point)
- "Get a list of spans and types for the current point."
- (save-excursion
- (goto-char point)
- (let ((line (line-number-at-pos))
- (col (1+ (current-column)))
- (file-name (buffer-file-name)))
- (cond
- (shm-use-hdevtools
- (shm-parse-hdevtools-type-info
- (with-temp-buffer
- (call-process "hdevtools" nil t nil "type" "-g" "-fdefer-type-errors"
- file-name
- (number-to-string line)
- (number-to-string col))
- (buffer-string))))))))
-
-(defun shm-parse-hdevtools-type-info (string)
- "Parse type information from the output of hdevtools."
- (let ((lines (split-string string "\n+")))
- (loop for line
- in lines
- while (string-match "\\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\) \"\\(.+\\)\"$"
- line)
- do (goto-char (point-min))
- collect
- (let ((start-line (string-to-number (match-string 1 line)))
- (end-line (string-to-number (match-string 3 line))))
- (vector (progn (forward-line (1- start-line))
- (+ (line-beginning-position)
- (1- (string-to-number (match-string 2 line)))))
- (progn (when (/= start-line end-line)
- (forward-line (1- (- start-line end-line))))
- (+ (line-beginning-position)
- (1- (string-to-number (match-string 4 line)))))
- (match-string 5 line))))))
-
-(provide 'shm-types)
diff --git a/elisp/shm-yank-kill.el b/elisp/shm-yank-kill.el
--- a/elisp/shm-yank-kill.el
+++ b/elisp/shm-yank-kill.el
@@ -1,4 +1,4 @@
-;;; shm-yank-kill.el --- Killing and yanking operations
+;;; shm-yank-kill.el --- Yanking/killing operations
;; Copyright (c) 2014 Chris Done. All rights reserved.
@@ -17,11 +17,16 @@
;;; Code:
-
-;; Requirements
-
(require 'shm-macros)
+(require 'shm-layout)
+(defun shm/mark-node ()
+ "Set the active mark to the current node."
+ (interactive)
+ (let ((current (shm-current-node)))
+ (goto-char (shm-node-start current))
+ (set-mark (shm-node-end current))))
+
(defun shm/kill-region (beg end)
"Kill the region, and save it in the clipboard."
(interactive "r")
@@ -74,7 +79,8 @@
(goto-char (+ (line-beginning-position)
column))))
(shm-kill-to-end-of-line t)))
- ((shm-current-node) (shm-kill-to-end-of-line))
+ ((shm-current-node)
+ (shm-kill-to-end-of-line))
(t (kill-line)))))
(defun shm/kill-node ()
@@ -104,127 +110,15 @@
yank-pop
(if (not (eq last-command 'yank))
(error "Previous command was not a yank (error from shm/yank-pop)"))
- (apply #'delete-region shm-last-yanked)
(shm-insert-indented #'yank-pop)))
-(defun shm-kill-node (&optional save-it node start do-not-delete)
- "Kill the current node.
-
-See documentation of `shm-kill-region' for the transformations
-this does."
+(defun shm/backward-kill-word ()
+ "Kill the word backwards."
(interactive)
- (let* ((current (or node (shm-current-node))))
- (shm-kill-region save-it
- (or start (shm-node-start current))
- (shm-node-end current)
- do-not-delete)))
-
-(defun shm-kill-region (save-it start end do-not-delete)
- "Kill the given region, dropping any redundant indentation.
-
-This normalizes everything it kills assuming what has been killed
-is a node or set of nodes. Indentation is stripped off and
-preserved appropriately so that if we kill e.g.
-
-foo = {do bar
- mu}
-
-where {} indicates the current node, then what is put into the kill ring is:
-
-do bar
- mu
-
-rather than what is normally put there,
-
-do bar
- mu
-
-So this is nice to paste elsewhere outside of Emacs, but it's
-especially nice for pasting back into other parts of code,
-because the yank function will take advantage of this
-normalization and paste and re-indent to fit into the new
-location. See `shm/yank' for documentation on that."
- (goto-char start)
- (let* ((start-col (current-column))
- (multi-line (/= (line-beginning-position)
- (save-excursion (goto-char end)
- (line-beginning-position))))
- (string (buffer-substring-no-properties
- start
- end))
- (result
- (unless (string= string "")
- (with-temp-buffer
- (erase-buffer)
- (when multi-line
- (insert (make-string start-col ? )))
- (insert string)
- ;; This code de-indents code until a single line is hitting column zero.
- (let ((indent-tabs-mode nil))
- (while (progn (goto-char (point-min))
- (not (and (search-forward-regexp "^[^ ]" nil t 1)
- (forward-line -1)
- ;; If there are empty lines, they
- ;; don't count as hitting column zero.
- (if (/= (line-beginning-position)
- (line-end-position))
- t
- ;; And we should actually delete empty lines.
- (progn (if (bobp)
- (delete-region (point) (1+ (point)))
- (delete-region (1- (point)) (point)))
- nil)))))
- ;; Bring everything back one.
- (indent-rigidly (point-min) (point-max)
- -1)))
- ;; If there's an empty line at the end, then strip that
- ;; out. It's just bothersome when pasting back in.
- (goto-char (point-max))
- (when (looking-at "^$")
- (delete-region (1- (point))
- (point)))
- ;; Finally, the actual save.
- (funcall (if save-it save-it 'clipboard-kill-ring-save)
- (point-min)
- (point-max))))))
- (let ((inhibit-read-only t))
- (unless do-not-delete
- (delete-region start
- end)))
- result))
-
-(defun shm-kill-to-end-of-line (&optional prepend-newline)
- "Kill everything possible to kill after point before the end of
-the line."
- (let* ((vector (shm-decl-ast))
- (current-pair (shm-current-node-pair))
- (current (cdr current-pair))
- (parent-pair (shm-node-ancestor-at-point current-pair (point)))
- (parent (cdr parent-pair)))
- (loop for i
- from 0
- to (length vector)
- until (or (>= i (length vector))
- (let ((node (elt vector i)))
- (and (>= (shm-node-start node)
- (shm-node-start parent))
- (<= (shm-node-end node)
- (shm-node-end parent)))))
- finally (return
- (let ((last-command (if prepend-newline 'kill-region last-command)))
- (when prepend-newline
- (kill-append "\n" nil))
- (if (< i (length vector))
- (shm-kill-node 'clipboard-kill-ring-save
- parent
- (point))
- (let ((line-end-position (if prepend-newline
- (save-excursion (forward-line)
- (line-end-position))
- (line-end-position))))
- (when (= (point)
- line-end-position)
- (kill-region (point)
- line-end-position)))))))))
+ (let ((to-be-deleted (save-excursion (backward-word)
+ (point))))
+ (save-excursion
+ (shm-adjust-dependents (point) (* -1 (- (point) to-be-deleted))))
+ (backward-kill-word 1)))
(provide 'shm-yank-kill)
diff --git a/elisp/shm.el b/elisp/shm.el
--- a/elisp/shm.el
+++ b/elisp/shm.el
@@ -5,7 +5,7 @@
;; Author: Chris Done
;; Created: 19-Oct-2013
-;; Version: 1.0.0
+;; Version: 1.0.2
;; Keywords: development, haskell, structured
;; Stability: unstable
@@ -28,23 +28,17 @@
;;; Code:
-
-;; Requirements
-
-(require 'shm-ast-documentation)
-(require 'shm-evaporate)
-
-(require 'cl)
-
-
-;; Groups
-
-(defgroup shm nil
- "Structured editing mode for Haskell"
- :group 'haskell)
-
-
-;; Mode
+(require 'shm-edit-string)
+(require 'shm-constraint)
+(require 'shm-type)
+(require 'shm-simple-indent)
+(require 'shm-yank-kill)
+(require 'shm-slot)
+(require 'shm-indent)
+(require 'shm-insert-del)
+(require 'shm-nav)
+(require 'shm-manipulation)
+(require 'shm-debug)
(defvar shm-map
(let ((map (make-sparse-keymap)))
@@ -60,6 +54,8 @@
(define-key map (kbd ":") 'shm/:)
(define-key map (kbd "SPC") 'shm/space)
(define-key map (kbd "C-c C-u") 'shm/insert-undefined)
+ (define-key map (kbd "M-;") 'shm/comment)
+ (define-key map (kbd "C-c C-e") 'shm/export)
;; Indentation
(define-key map (kbd "C-j") 'shm/newline-indent)
(define-key map (kbd "M-)") 'paredit-close-round-and-newline)
@@ -97,11 +93,16 @@
;; Splitting, slurping, barfing, etc.
(define-key map (kbd "C-+") 'shm/add-operand)
(define-key map (kbd "M-r") 'shm/raise)
+ (define-key map (kbd "C-c C-q") 'shm/qualify-import)
map)
"Structural editing operations keymap. Any key bindings in this
map are intended to be only structural operations which operate
with the tree in mind.")
+(defvar shm-parsing-timer nil
+ "The timer used to re-parse every so often. The idle time can
+ be configured with `shm-idle-timeout'.")
+
;;;###autoload
(define-minor-mode structured-haskell-mode
"Structured editing for Haskell."
@@ -111,23 +112,67 @@
(shm-mode-start)
(shm-mode-stop)))
-
-;; Modules
-
-(require 'shm-generic)
-(require 'shm-insertion)
-(require 'shm-indentation)
-(require 'shm-navigation)
-(require 'shm-transform)
-(require 'shm-yank-kill)
-(require 'shm-strings)
-(require 'shm-skeletons)
-(require 'shm-types)
-(require 'shm-ast)
-(require 'shm-nodes)
+(defvar shm-repl-map
+ (let ((map (make-sparse-keymap)))
+ ;; Insertion
+ (define-key map (kbd "\"") 'shm/double-quote)
+ (define-key map (kbd "(") 'shm/open-paren)
+ (define-key map (kbd "M-(") 'shm/wrap-parens)
+ (define-key map (kbd "[") 'shm/open-bracket)
+ (define-key map (kbd "{") 'shm/open-brace)
+ (define-key map (kbd "-") 'shm/hyphen)
+ (define-key map (kbd "#") 'shm/hash)
+ (define-key map (kbd ",") 'shm/comma)
+ (define-key map (kbd ":") 'shm/:)
+ (define-key map (kbd "SPC") 'shm/space)
+ (define-key map (kbd "C-c C-u") 'shm/insert-undefined)
+ (define-key map (kbd "M-;") 'shm/comment)
+ ;; Navigation
+ (define-key map (kbd "C-M-f") 'shm/forward-node)
+ (define-key map (kbd "C-M-b") 'shm/backward-node)
+ (define-key map (kbd "M-a") 'shm/goto-parent)
+ (define-key map (kbd ")") 'shm/close-paren)
+ (define-key map (kbd "]") 'shm/close-bracket)
+ (define-key map (kbd "}") 'shm/close-brace)
+ (define-key map (kbd "M-}") 'shm/forward-paragraph)
+ (define-key map (kbd "M-{") 'shm/backward-paragraph)
+ (define-key map (kbd "C-M-SPC") 'shm/mark-node)
+ (define-key map (kbd "TAB") 'shm/tab)
+ (define-key map (kbd "") 'shm/backtab)
+ ;; Killing / yanking
+ (define-key map (kbd "C-k") 'shm/kill-line)
+ (define-key map (kbd "M-k") 'shm/kill-node)
+ (define-key map (kbd "C-w") 'shm/kill-region)
+ (define-key map (kbd "M-w") 'shm/copy-region)
+ (define-key map (kbd "C-M-k") 'shm/kill-node)
+ (define-key map (kbd "C-y") 'shm/yank)
+ (define-key map (kbd "M-y") 'shm/yank-pop)
+ ;; Deletion
+ (define-key map (kbd "DEL") 'shm/del)
+ (define-key map (kbd "") 'shm/delete)
+ (define-key map (kbd "M-^") 'shm/delete-indentation)
+ (define-key map (kbd "M-DEL") 'shm/backward-kill-word)
+ (define-key map (kbd "C-") 'shm/backward-kill-word)
+ ;; Splitting, slurping, barfing, etc.
+ (define-key map (kbd "C-+") 'shm/add-operand)
+ (define-key map (kbd "M-r") 'shm/raise)
+ (define-key map (kbd "C-c C-q") 'shm/qualify-import)
+ map)
+ "Structural editing operations keymap for in the REPL. This
+ differs to `shm-map' by having keybindings more appropriate for
+ a REPL, with inappropriate ones removed.")
-
-;; Internal mode functions
+(define-minor-mode structured-haskell-repl-mode
+ "Structured editing for Haskell inside a REPL."
+ :lighter shm-lighter
+ :keymap shm-repl-map
+ (cond
+ ((eq major-mode 'haskell-interactive-mode)
+ (if structured-haskell-repl-mode
+ (shm-mode-start)
+ (shm-mode-stop)))
+ (t (structured-haskell-repl-mode -1)
+ (error "Unsupported REPL mode: %S" major-mode))))
(defun shm-mode-start ()
"Start the minor mode."
@@ -140,13 +185,6 @@
(setq shm-parsing-timer
(run-with-idle-timer shm-idle-timeout t 'shm-reparsing-timer))))
-(defun shm-post-self-insert ()
- "Self-insertion handler."
- (save-excursion
- (shm-appropriate-adjustment-point)
- (forward-char -1)
- (shm-adjust-dependents (point) 1)))
-
(defun shm-mode-stop ()
"Stop the minor mode. Restore various settings and clean up any
state that will hopefully be garbage collected."
@@ -171,28 +209,30 @@
(defun shm-reparsing-timer ()
"Re-parse the tree on the idle timer."
- (when structured-haskell-mode
+ (when (or structured-haskell-mode
+ structured-haskell-repl-mode)
(shm/reparse)))
-
-;; Faces
-
-(defface shm-quarantine-face
- '((((class color)) :background "#443333"))
- "Face for quarantines."
- :group 'shm)
-
-(defface shm-current-face
- '((((class color)) :background "#373737"))
- "Face for the current node."
- :group 'shm)
+(defun shm/tab ()
+ "Either indent if at the start of a line, or jump to the next
+ slot."
+ (interactive)
+ (cond
+ ((save-excursion (goto-char (line-beginning-position))
+ (looking-at "^[ ]*$"))
+ (shm/simple-indent))
+ (t
+ (shm/jump-to-slot))))
-
-;; Provide
+(defun shm/backtab ()
+ "Either de-indent if at the start of a line, or jump to the previous
+ slot."
+ (interactive)
+ (cond
+ ((save-excursion (goto-char (line-beginning-position))
+ (looking-at "^[ ]*$"))
+ (shm/simple-indent-backtab))
+ (t
+ (shm/jump-to-previous-slot))))
(provide 'shm)
-
-;;; shm.el ends here
-;; Local Variables:
-;; byte-compile-warnings: (not cl-functions)
-;; End:
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,81 +1,103 @@
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
-- | Take in Haskell code and output a vector of source spans and
-- their associated node type and case.
module Main (main) where
import Control.Applicative
-import Data.Char
import Data.Data
import Data.Maybe
import Language.Haskell.Exts.Annotated
-import Language.Haskell.Exts.Annotated.Fixity
import System.Environment
-import System.IO
+-- | A generic Dynamic-like constructor -- but more convenient to
+-- write and pattern match on.
+data D = forall a. Data a => D a
+
+-- | A parser. Presently there is only 'parseTopLevel', but in the
+-- past, and in the future, there will be the facility to parse
+-- specific parse of declarations, rather than re-parsing the whole
+-- declaration which can be both slow and brittle.
type Parser = ParseMode -> String -> ParseResult D
-data D = forall a. Data a => D a
+-- | The 'empty' method isn't (shouldn't be) used, so this isn't a
+-- real Alternative instance (perhaps a Semigroup might do?). But it's
+-- handy.
+instance Alternative ParseResult where
+ empty = ParseFailed undefined undefined
+ ParseFailed{} <|> x = x
+ x <|> _ = x
--- | Main entry point.
+--- | Main entry point.
main :: IO ()
main = do
code <- getContents
action:typ:_ <- getArgs
outputWith action typ code
+-- | Output some result with the given action (check/parse/etc.),
+-- parsing the given type of AST node. In the past, the type was any
+-- kind of AST node. Today, it's just a "decl" which is covered by
+-- 'parseTopLevel'.
outputWith :: String -> String -> String -> IO ()
outputWith action typ code =
case typ of
"decl" ->
- output action
- (\mode code ->
- fmap D (fmap fix (parseDeclWithMode mode code)) <|>
- fmap D (parseImport mode code) <|>
- fmap D (fmap fix (parseModuleWithMode mode code)) <|>
- fmap D (parseModulePragma mode code))
- code
+ output action parseTopLevel code
+ "stmt" ->
+ output action parseSomeStmt code
_ -> error "Unknown parser type."
- where fix ast = fromMaybe ast (applyFixities baseFixities ast)
-instance Alternative ParseResult where
- empty = ParseFailed undefined undefined
- ParseFailed{} <|> x = x
- x <|> _ = x
-
--- | Get the type of the parser.
-parserRep :: Typeable ast => ast -> String
-parserRep = show . head . typeRepArgs . typeOf
-
-- | Output AST info for the given Haskell code.
output :: String -> Parser -> String -> IO ()
-output action parseWithMode code = do
- case parseWithMode parseMode code of
+output action parser code =
+ case parser parseMode code of
ParseFailed _ e -> error e
- ParseOk (D ast) -> case action of
+ ParseOk (D ast) ->
+ case action of
"check" -> return ()
"parse" -> putStrLn ("[" ++ concat (genHSE ast) ++ "]")
_ -> error "unknown action"
+-- | An umbrella parser to parse:
+--
+-- * A declaration.
+--
+-- * An import line (not normally counted as a declaration).
+--
+-- * A module header (not normally counted either).
+--
+-- * A module pragma (normally part of the module header).
+--
+parseTopLevel :: ParseMode -> String -> ParseResult D
+parseTopLevel mode code =
+ D . fix <$> parseDeclWithMode mode code <|>
+ D <$> parseImport mode code <|>
+ D . fix <$> parseModuleWithMode mode code <|>
+ D <$> parseModulePragma mode code
+
+-- | Parse a do-notation statement.
+parseSomeStmt :: ParseMode -> String -> ParseResult D
+parseSomeStmt mode code =
+ D . fix <$> parseStmtWithMode mode code <|>
+ D . fix <$> parseExpWithMode mode code <|>
+ D <$> parseImport mode code
+
+fix ast = fromMaybe ast (applyFixities baseFixities ast)
+
-- | Parse mode, includes all extensions, doesn't assume any fixities.
parseMode :: ParseMode
parseMode =
defaultParseMode { extensions = allExtensions
, fixities = Nothing
}
- where allExtensions =
- filter (\x ->
- case x of
- DisableExtension x -> False
- _ -> True)
- knownExtensions
+ where allExtensions = filter isDisabledExtention knownExtensions
+ isDisabledExtention (DisableExtension _) = False
+ isDisabledExtention _ = True
-- | Generate a list of spans from the HSE AST.
genHSE :: Data a => a -> [String]
@@ -87,50 +109,63 @@
spanHSE (show (show (typeOf x)))
(showConstr (toConstr x))
(srcInfoSpan s) :
- concat (map (\(i,(D d)) -> pre x i ++ genHSE d)
- (zip [0..] ys))
+ concatMap (\(i,D d) -> pre x i ++ genHSE d)
+ (zip [0..] ys)
_ ->
concatMap (\(D d) -> genHSE d) zs
_ -> []
-- | Pre-children tweaks for a given parent at index i.
--
--- }> becomes }>>
---
pre :: (Typeable a) => a -> Integer -> [String]
pre x i =
- case cast x of
+ case cast x of
+ -- }> becomes }>>
Just (RecUpdate SrcSpanInfo{srcInfoPoints=(start:_),srcInfoSpan=end} _ _)
| i == 1 ->
- [spanHSE (show "RecUpdates SrcSpanInfo")
+ [spanHSE (show "RecUpdates")
"RecUpdates"
(SrcSpan (srcSpanFilename start)
(srcSpanStartLine start)
(srcSpanStartColumn start)
(srcSpanEndLine end)
(srcSpanEndColumn end))]
- _ -> []
+ _ -> case cast x :: Maybe (Deriving SrcSpanInfo) of
+ -- becomes )
+ Just (Deriving _ ds@(_:_)) ->
+ [spanHSE (show "InstHeads")
+ "InstHeads"
+ (SrcSpan (srcSpanFilename start)
+ (srcSpanStartLine start)
+ (srcSpanStartColumn start)
+ (srcSpanEndLine end)
+ (srcSpanEndColumn end))
+ |Just (IHead (SrcSpanInfo start _) _ _) <- [listToMaybe ds]
+ ,Just (IHead (SrcSpanInfo end _) _ _) <- [listToMaybe (reverse ds)]]
+ _ -> []
-- | Generate a span from a HSE SrcSpan.
spanHSE :: String -> String -> SrcSpan -> String
-spanHSE typ cons (SrcSpan _ a b c d) =
- concat ["["
- ,unwords [unqualify typ
+spanHSE typ cons SrcSpan{..} = "[" ++ spanContent ++ "]"
+ where unqualify = dropUntilLast '.'
+ spanContent =
+ unwords [unqualify typ
,cons
- ,show a
- ,show b
- ,show c
- ,show d]
- ,"]"]
- where unqualify = go [] where
- go acc ('.':cs) = go [] cs
- go acc (c:cs) = go (c:acc) cs
- go acc [] = reverse acc
+ ,show srcSpanStartLine
+ ,show srcSpanStartColumn
+ ,show srcSpanEndLine
+ ,show srcSpanEndColumn]
--- | Pretty print a source location.
-printSrcLoc :: SrcLoc -> String
-printSrcLoc SrcLoc{..} =
- srcFilename ++ ":" ++ show srcLine ++ ":" ++ show srcColumn
+------------------------------------------------------------------------------
+-- General Utility
+
+-- | Like 'dropWhile', but repeats until the last match.
+dropUntilLast :: Char -> String -> String
+dropUntilLast ch = go []
+ where
+ go _ (c:cs) | c == ch = go [] cs
+ go acc (c:cs) = go (c:acc) cs
+ go acc [] = reverse acc
--------------------------------------------------------------------------------
-- Parsers that HSE hackage doesn't have
diff --git a/structured-haskell-mode.cabal b/structured-haskell-mode.cabal
--- a/structured-haskell-mode.cabal
+++ b/structured-haskell-mode.cabal
@@ -1,5 +1,5 @@
name: structured-haskell-mode
-version: 1.0.2
+version: 1.0.3
synopsis: Structured editing Emacs mode for Haskell
description: Structured editing Emacs mode for Haskell.
homepage: https://github.com/chrisdone/structured-haskell-mode
@@ -11,31 +11,34 @@
category: Development
build-type: Simple
cabal-version: >=1.8
-data-files: elisp/shm-ast-documentation.el
- elisp/shm-ast.el
- elisp/shm-customizations.el
- elisp/shm-deletion.el
+data-files: elisp/shm-case-split.el
+ elisp/shm-constraint.el
+ elisp/shm-yank-kill.el
+ elisp/shm-indent.el
elisp/shm.el
- elisp/shm-evaporate.el
- elisp/shm-generic.el
- elisp/shm-globals.el
- elisp/shm-indentation.el
- elisp/shm-insertion.el
+ elisp/shm-debug.el
+ elisp/shm-customizations.el
elisp/shm-macros.el
- elisp/shm-navigation.el
- elisp/shm-nodes.el
+ elisp/shm-layout.el
+ elisp/shm-ast.el
+ elisp/shm-evaporate.el
+ elisp/shm-simple-indent.el
+ elisp/shm-type.el
+ elisp/shm-node.el
+ elisp/shm-edit-string.el
+ elisp/shm-in.el
+ elisp/shm-tests.el
elisp/shm-overlays.el
- elisp/shm-skeletons.el
- elisp/shm-strings.el
elisp/shm-test.el
- elisp/shm-tests.el
- elisp/shm-transform.el
- elisp/shm-types.el
- elisp/shm-yank-kill.el
+ elisp/shm-manipulation.el
+ elisp/shm-slot.el
+ elisp/shm-insert-del.el
+ elisp/shm-nav.el
+ elisp/shm-ast-documentation.el
executable structured-haskell-mode
main-is: Main.hs
- ghc-options: -O2
+ ghc-options: -O2 -Wall
hs-source-dirs: src
build-depends: base >= 4 && < 5,
haskell-src-exts >= 1.14.0