packages feed

structured-haskell-mode 1.0.2 → 1.0.3

raw patch · 35 files changed

+3716/−2591 lines, 35 files

Files

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