diff --git a/elisp/evaporate.el b/elisp/evaporate.el deleted file mode 100644 --- a/elisp/evaporate.el +++ /dev/null @@ -1,35 +0,0 @@ -(defface evaporate-face - '((((class color)) :foreground "#666666")) - "Face for text that will evaporate when modified/overwritten." - :group 'evaporate) - -(defun evaporate (beg end) - "Make the region evaporate when typed over." - (interactive "r") - (let ((o (make-overlay beg end nil nil nil))) - (overlay-put o 'evaporate-overlay t) - (overlay-put o 'face 'evaporate-face) - (overlay-put o 'evaporate t) - (overlay-put o 'priority 2) - (overlay-put o 'modification-hooks '(evaporate-modification-hook)) - (overlay-put o 'insert-in-front-hooks '(evaporate-insert-before-hook)))) - -(defun evaporate-modification-hook (o changed beg end &optional len) - "Remove the overlay after a modification occurs." - (let ((inhibit-modification-hooks t)) - (when (and changed - (overlay-start o)) - (delete-region (overlay-start o) - (overlay-end o)) - (delete-overlay o)))) - -(defun evaporate-insert-before-hook (o changed beg end &optional len) - "Remove the overlay before inserting something at the start." - (let ((inhibit-modification-hooks t)) - (when (and (not changed) - (overlay-start o)) - (delete-region (overlay-start o) - (overlay-end o)) - (delete-overlay o)))) - -(provide 'evaporate) diff --git a/elisp/shm-ast-documentation.el b/elisp/shm-ast-documentation.el --- a/elisp/shm-ast-documentation.el +++ b/elisp/shm-ast-documentation.el @@ -2,42 +2,18 @@ ;; Copyright (c) 2013, Niklas Broberg, Chris Done. All rights reserved. -;; Author: Chris Done -;; Created: 11-Oct-2013 -;; Version: 0.0.0 -;; Keywords: development, haskell, structured -;; Stability: unstable - -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions -;; are met: - -;; * Redistributions of source code must retain the above -;; copyright notice, this list of conditions and the following -;; disclaimer. - -;; * Redistributions in binary form must reproduce the above -;; copyright notice, this list of conditions and the following -;; disclaimer in the documentation and/or other materials -;; provided with the distribution. +;; 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. -;; * Neither the name of Niklas Broberg, Chris Done nor the names -;; of other contributors may be used to endorse or promote -;; products derived from this software without specific prior -;; written permission. +;; 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. -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS -;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, -;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED -;; OF THE POSSIBILITY OF SUCH DAMAGE. +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . ;;; Commentary: @@ -371,3 +347,5 @@ "Documentation describing every node type and every constructor in the AST") (provide 'shm-ast-documentation) + +;;; shm-ast-documentation.el ends here diff --git a/elisp/shm-ast.el b/elisp/shm-ast.el new file mode 100644 --- /dev/null +++ b/elisp/shm-ast.el @@ -0,0 +1,229 @@ +;;; shm-ast.el --- AST generation functions + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'shm-globals) +(require 'shm-nodes) +(require 'shm-ast-documentation) +(require 'shm-customizations) +(require 'shm-yank-kill) + +(require 'cl) + +(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 +wasteful and expensive to lookup nodes every time we want a +node. So it's cheaper to have the granularity of lookup start at +the declaration's point and the node's span. + +Second it's better because a module may have unparseable content +in it, but that doesn't mean we don't want structured editing to +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))))) + +(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 +and instate this one." + (setq shm-decl-asts + (cons + (cons (set-marker (make-marker) point) ast) + (remove-if (lambda (pair) + (when (= (marker-position (car pair)) + point) + (set-marker (car pair) nil) + t)) + shm-decl-asts))) + ast) + +(defun shm-get-decl-ast (start end &optional reparse) + "Get the AST of the declaration starting at POINT." + (let ((pair (car (remove-if-not (lambda (pair) + (= (marker-position (car pair)) + start)) + shm-decl-asts)))) + (if (and (not reparse) + pair) + (cdr pair) + (progn + (when (or (/= start shm-last-parse-start) + (/= 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)))))))) + +(defun shm-delete-markers (decl) + "Delete the markers in DECL." + (mapc #'shm-node-delete-markers + (cdr decl))) + +(defun shm-get-ast (type start end) + "Get the AST for the given region at START and END. Parses with TYPE. + +This currently launches a fresh process and uses this buffer +nonsense, for any parse, which sucks, but is fast enough _right +now_. Later on a possibility to make this much faster is to have +a persistent running parser server and than just send requests to +it, that should bring down the roundtrip time significantly, I'd +imagine." + (let ((message-log-max nil) + (buffer (current-buffer))) + (when (> end (1+ start)) + (with-temp-buffer + (let ((temp-buffer (current-buffer))) + (with-current-buffer buffer + (condition-case e + (call-process-region start + end + shm-program-name + nil + temp-buffer + nil + "parse" + type) + ((file-error) + (error "Unable to find structured-haskell-mode executable! See README for help."))))) + (read (buffer-string)))))) + +(defun shm-check-ast (type start end) + "Check whether the region of TYPE from START to END parses. + +This doesn't generate or return an AST, it just checks whether it +parses." + (let ((message-log-max nil) + (buffer (current-buffer))) + (with-temp-buffer + (let ((temp-buffer (current-buffer))) + (with-current-buffer buffer + (call-process-region start + end + shm-program-name + nil + temp-buffer + nil + "check" + ;; In other words, always parse with + ;; the more generic “decl” when + ;; something starts at column 0, + ;; because HSE distinguishes between a + ;; “declaration” and an import, a + ;; module declaration and a language + ;; pragma. + (if (save-excursion (goto-char start) + (= (point) (line-beginning-position))) + "decl" + type)))) + (string= "" (buffer-string))))) + +(defun shm-get-nodes (ast start end) + "Get the nodes of the given AST. + +We convert all the line-col numbers to Emacs points and then +create markers out of them. We also store the type of the node, +e.g. Exp, and the case of the node, e.g. Lit or Case or Let, +which is helpful for doing node-specific operations like +indentation. + +Any optimizations welcome." + (let* ((start-end (cons start end)) + (start-column (save-excursion (goto-char start) + (current-column)))) + (cond ((vectorp ast) + (save-excursion + (map 'vector + (lambda (node) + (vector + (elt node 0) + (elt node 1) + (progn (goto-char (car start-end)) + (forward-line (1- (elt node 2))) + ;; This trick is to ensure that the first + ;; line's columns are offsetted for + ;; regions that don't start at column + ;; zero. + (goto-char (+ (if (= (elt node 2) 1) + start-column + 0) + (1- (+ (point) (elt node 3))))) + (let ((marker (set-marker (make-marker) (point)))) + marker)) + (progn (goto-char (car start-end)) + (forward-line (1- (elt node 4))) + ;; Same logic as commented above. + (goto-char (+ (if (= (elt node 4) 1) + start-column + 0) + (1- (+ (point) (elt node 5))))) + ;; This avoids the case of: + (while (save-excursion (goto-char (line-beginning-position)) + (or (looking-at "[ ]+-- ") + (looking-at "[ ]+$"))) + (forward-line -1) + (goto-char (line-end-position))) + (let ((marker (set-marker (make-marker) (point)))) + (set-marker-insertion-type marker t) + marker)))) + ast))) + (t nil)))) + +(provide 'shm-ast) diff --git a/elisp/shm-customizations.el b/elisp/shm-customizations.el new file mode 100644 --- /dev/null +++ b/elisp/shm-customizations.el @@ -0,0 +1,103 @@ +;;; shm-customizations.el --- Customizations for structured-haskell-mode + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(defcustom shm-auto-insert-skeletons + t + "Auto-insert skeletons for case, if, etc." + :group 'shm + :type 'boolean) + +(defcustom shm-auto-insert-bangs + t + "Auto-insert bangs when inserting :: in record fields." + :group 'shm + :type 'boolean) + +(defcustom shm-skip-applications + t + "Skip successive applications to the top parent. + +So if you have + +foo| bar mu + +And go up a parent, it will go to + +foo bar mu| + +instead of + +foo bar| mu + +I tend to want the former behaviour more often than the latter, +but others may differ." + :group 'shm + :type 'boolean) + +(defcustom shm-program-name + "structured-haskell-mode" + "The path to call for parsing Haskell syntax." + :group 'shm + :type 'string) + +(defcustom shm-indent-spaces + (if (boundp 'haskell-indent-spaces) + haskell-indent-spaces + 2) + "The number of spaces to indent by default." + :group 'shm + :type 'string) + +(defcustom shm-lambda-indent-style + nil + "Specify a particular style for indenting lambdas?" + :group 'shm + :type '(choice (const leftmost-parent) (const nil))) + +(defcustom shm-use-presentation-mode + nil + "Use haskell-presentation-mode?" + :group 'shm + :type 'boolean) + +(defcustom shm-display-quarantine + t + "Display quarantine?" + :group 'shm + :type 'boolean) + +(defcustom shm-use-hdevtools + nil + "Use hdevtools for type information?" + :group 'shm + :type 'boolean) + +(defcustom shm-type-info-fallback-to-ghci + t + "Fallback to GHCi when the type-info backend returns nothing?" + :group 'shm + :type 'boolean) + +(defcustom shm-idle-timeout + 0.2 + "Number of seconds before re-parsing." + :group 'shm + :type 'string) + +(provide 'shm-customizations) diff --git a/elisp/shm-deletion.el b/elisp/shm-deletion.el new file mode 100644 --- /dev/null +++ b/elisp/shm-deletion.el @@ -0,0 +1,182 @@ +;;; shm-deletion.el --- Deletion operations + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'shm-indentation) +(require 'shm-nodes) +(require 'shm-macros) +(require 'shm-generic) +(require 'shm-globals) +(require 'shm-insertion) + +(defun shm/backward-kill-word () + "Kill the word backwards." + (interactive) + (let ((to-be-deleted (save-excursion (backward-word) + (point)))) + (save-excursion + (shm-appropriate-adjustment-point) + (shm-adjust-dependents (point) (* -1 (- (point) to-be-deleted)))) + (backward-kill-word 1))) + +(defun shm/delete () + "Delete the current node." + (interactive) + (let ((current (shm-current-node)) + (inhibit-read-only t)) + (delete-region (shm-node-start current) + (shm-node-end current)))) + +(defun shm/del () + "Character deletion handler. + +Generally, we delete things in the current node. BUT, there are +some things that we shouldn't delete, because they would cause +parse errors that are rarely useful. For example: + + (|case x of _ -> _) -- where | indicates cursor. + +" + (interactive) + (shm-with-fallback + delete-backward-char + (cond + ;; These cases are “gliders”. They simply move over the character + ;; backwards. These could be handled all as one regular + ;; expression, but in the interest of clarity—for now—they are left + ;; as separate cases. + ((and (shm-in-string) + (looking-back "^[ ]*\\\\")) + (let ((here (point))) + (delete-region (search-backward-regexp "\\\\$") + here))) + ((and (looking-back "{-[ ]*") + (looking-at "[ ]*-}")) + (delete-region (search-backward-regexp "-") + (progn (forward-char 1) + (search-forward-regexp "-")))) + ((and (looking-back "^{-#[ ]*") + (looking-at "[ ]*#-}$")) + (delete-region (search-backward-regexp "#") + (progn (forward-char 1) + (search-forward-regexp "#")))) + ((looking-back "[()]") (shm-delete-or-glide "(" ")")) + ((looking-back "[[]") (shm-delete-or-glide "\\[" "\\]")) + ((looking-back "[]]") (shm-delete-or-glide "\\[" "\\]")) + ((looking-back "[{}]") (shm-delete-or-glide "{" "}")) + ((looking-back "[\"]") (shm-delete-or-glide "\"" "\"")) + ;; These kind of patterns block the parens of syntaxes that would + ;; otherwise break everything, so, "if", "of", "case", "do", + ;; etc. if deleted. + ((and (looking-back "[^A-Zaz0-9_]do ?") + (not (or (eolp) + (looking-at "[])}]")))) + nil) ; do nothing + ((and (looking-back " <-") + (not (or (eolp) + (looking-at "[])}]")))) + (forward-char -3)) + ((and (looking-back " <- ") + (not (or (eolp) + (looking-at "[])}]")))) + (forward-char -4)) + ((looking-back "[^A-Zaz0-9_]of ?") + (search-backward-regexp "[ ]*of")) + ((or (looking-at "of$") + (looking-at "of ")) + (forward-char -1)) + ((looking-back "[_ ]-> ?") (forward-char -3)) + ((looking-at "-> ?") + (forward-char -1)) + ((looking-back "[^A-Zaz0-9_]then ?") + (search-backward-regexp "[^ ][ ]*then") + (unless (or (looking-at "$") (looking-at " ")) + (forward-char 1))) + ((looking-back "[^A-Zaz0-9_]else ?") + (search-backward-regexp "[^ ][ ]*else") + (unless (or (looking-at "$") (looking-at " ")) + (forward-char 1))) + ((looking-back "^module ?") + (when (looking-at "[ ]*where$") + (delete-region (line-beginning-position) (line-end-position)))) + ((looking-back "[^A-Zaz0-9_]if ?") + nil) ; do nothing + ((looking-back "[^A-Zaz0-9_]case ?") + nil) ; do nothing + ((and (looking-at "= ") + (looking-back " ")) + (forward-char -1)) + ((or (and (looking-back " = ") + (not (looking-at "$")) + (not (looking-at " "))) + (and (looking-back "=") + (looking-at " "))) + (search-backward-regexp "[ ]+=[ ]*" + (line-beginning-position) + t + 1) + (when (looking-back " ") + (when (search-backward-regexp "[^ ]" (line-beginning-position) + t 1) + (forward-char 1)))) + ;; This is the base case, we assume that we can freely delete + ;; whatever we're looking back at, and that the node will be able + ;; to re-parse it. + (t (save-excursion + (shm-appropriate-adjustment-point) + (shm-adjust-dependents (point) -1)) + (shm-delete-char)))) + (shm/init t)) + +(defun shm-delete-or-glide (open close) + "Delete the given OPEN/CLOSE delimiter, or simply glide over it + if it isn't empty." + (cond + ;; If the delimiters are empty, we can delete the whole thing. + ((shm-delimiter-empty open close) + (let ((inhibit-read-only t)) + (shm-adjust-dependents (point) -2) + (delete-region (1- (point)) + (1+ (point))))) + ;; If the delimiters aren't empty and we're in a literal, then go + ;; ahead and elete the character. + ((and (shm-literal-insertion) + (not (= (point) (1+ (shm-node-start (shm-current-node)))))) + (shm-delete-char)) + ;; Otherwise just glide over the character. + (t + (when (looking-back close) + (forward-char -1))))) + +(defun shm-delete-char () + "Delete a character backwards or delete the region, if there is +one active." + (if (region-active-p) + (delete-region (region-beginning) + (region-end)) + (delete-region (1- (point)) + (point)))) + +(defun shm-delimiter-empty (open close) + "Is the current expression delimited by OPEN and CLOSE empty?" + (and (looking-back open) + (not (save-excursion (forward-char (* -1 (length open))) + (looking-back "\\\\"))) + (looking-at close))) + +(provide 'shm-deletion) diff --git a/elisp/shm-evaporate.el b/elisp/shm-evaporate.el new file mode 100644 --- /dev/null +++ b/elisp/shm-evaporate.el @@ -0,0 +1,60 @@ +;;; shm-evaporate.el --- Evaporating overlays + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Support for evaporating pieces of code. + +;;; Code: + +(defface shm-evaporate-face + '((((class color)) :foreground "#666666")) + "Face for text that will evaporate when modified/overwritten." + :group 'shm-evaporate) + +(defun shm-evaporate (beg end) + "Make the region evaporate when typed over." + (interactive "r") + (let ((o (make-overlay beg end nil nil nil))) + (overlay-put o 'shm-evaporate-overlay t) + (overlay-put o 'face 'shm-evaporate-face) + (overlay-put o 'shm-evaporate t) + (overlay-put o 'priority 2) + (overlay-put o 'modification-hooks '(shm-evaporate-modification-hook)) + (overlay-put o 'insert-in-front-hooks '(shm-evaporate-insert-before-hook)))) + +(defun shm-evaporate-modification-hook (o changed beg end &optional len) + "Remove the overlay after a modification occurs." + (let ((inhibit-modification-hooks t)) + (when (and changed + (overlay-start o)) + (delete-region (overlay-start o) + (overlay-end o)) + (delete-overlay o)))) + +(defun shm-evaporate-insert-before-hook (o changed beg end &optional len) + "Remove the overlay before inserting something at the start." + (let ((inhibit-modification-hooks t)) + (when (and (not changed) + (overlay-start o)) + (delete-region (overlay-start o) + (overlay-end o)) + (delete-overlay o)))) + +(provide 'shm-evaporate) + +;;; shm-evaporate.el ends here diff --git a/elisp/shm-generic.el b/elisp/shm-generic.el new file mode 100644 --- /dev/null +++ b/elisp/shm-generic.el @@ -0,0 +1,111 @@ +;;; shm-generic.el --- Generic mode functions + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'shm-types) +(require 'shm-ast) + +(defun shm/reparse () + "Re-parse the current node. + +This is used on the reparsing timer, but also on commands that +really need accurate AST information *right now*, so this will +force a reparse immediately (if necessary)." + (interactive) + (shm-decl-ast t) + (when (/= shm-last-point (point)) + (shm-set-node-overlay))) + +(defun shm/mark-node () + "Set the active mark to the current node." + (interactive) + (let ((current (shm-current-node))) + (goto-char (shm-node-start current)) + (set-mark (shm-node-end current)))) + +(defun shm/test-exe () + "Test that the executable is working properly." + (interactive) + (let ((region (shm-decl-points))) + (when (get-buffer "*shm-scratch-test*") + (with-current-buffer + (switch-to-buffer "*shm-scratch-test*") + (erase-buffer))) + (call-process-region (car region) + (cdr region) + shm-program-name + nil + "*shm-scratch-test*" + nil + "parse" + "decl") + (switch-to-buffer "*shm-scratch-test*") + (when (save-excursion (goto-char (point-min)) + (looking-at "structured-haskell-mode:")) + (insert "\nNote: If you got a parse error for valid code +that is using fairly new (read: couple years) a GHC extension, +you are probably hitting the fact that haskell-src-exts doesn't +parse a bunch of newer GHC extensions. SHM does not do any +parsing itself, it uses HSE. There are some patches in the HSE +repo, provided as pull requests, which you can try applying to a +local copy of HSE and then recompile SHM with the new version. + +See also: https://github.com/haskell-suite/haskell-src-exts/issues/19 + +And: https://github.com/chrisdone/structured-haskell-mode/blob/master/src/Main.hs")))) + +(defun shm/type-of-node () + (interactive) + (let ((current (shm-current-node))) + (cond + ((or (string= (shm-node-type-name current) "Exp") + (string= (shm-node-type-name current) "Decl") + (string= (shm-node-type-name current) "Pat") + (string= (shm-node-type-name current) "QOp")) + (let ((type-info (shm-node-type-info current))) + (if type-info + (shm-present-type-info current type-info) + (if (and shm-type-info-fallback-to-ghci + (fboundp 'haskell-process-do-type)) + (haskell-process-do-type) + (error "Unable to get type information for that node."))))) + ((and (string= (shm-node-type-name current) "Name") + (let ((parent-name (shm-node-type-name (cdr (shm-node-parent (shm-current-node-pair)))))) + (or (string= parent-name "Match") + (string= parent-name "Decl")))) + (let* ((node (cdr (shm-node-parent (shm-current-node-pair)))) + (type-info (shm-node-type-info node))) + (if type-info + (shm-present-type-info node type-info) + (if (and shm-type-info-fallback-to-ghci + (fboundp 'haskell-process-do-type)) + (haskell-process-do-type) + (error "Unable to get type information for that node (tried the whole decl, too)."))))) + (t (error "Not an expression, operator, pattern binding or declaration."))))) + +(defun shm/describe-node (&optional node) + "Present a description of the current node in the minibuffer. + +Very useful for debugging and also a bit useful for newbies." + (interactive) + (let ((node (or node (shm-current-node)))) + (if node + (message "%s" (shm-node-description node)) + (error "No current node.")))) + +(provide 'shm-generic) diff --git a/elisp/shm-globals.el b/elisp/shm-globals.el new file mode 100644 --- /dev/null +++ b/elisp/shm-globals.el @@ -0,0 +1,47 @@ +;;; shm-globals.el --- Global variables shared among modules + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(defvar shm-lighter " SHM?" + "The lighter for structured Haskell mode.") + +(defvar shm-last-point 0 + "When moving around, the current node overlay will update + according to where you are. But often you can shrink/expand the + scope of the current node. This variable lets us avoid the node + being reset by realising we haven't actually moved the point.") + +(defvar shm-parsing-timer nil + "The timer used to re-parse every so often. The idle time can + be configured with `shm-idle-timeout'.") + +(defvar shm-last-parse-start 0 + "This is used to avoid unnecessary work, if the start of the + declaration hasn't changed, and the end (see + `shm-last-parse-end') since we last parsed, don't bother + re-parsing.") + +(defvar shm-last-parse-end 0 + "See `shm-last-parse-start' for explanation.") + +(defvar shm-last-yanked (list 0 0) + "When yanking, some text will be inserted, when popping a + yank (i.e. with M-y), you need to be able to erase the previous + yank. This is simply a region.") + +(provide 'shm-globals) diff --git a/elisp/shm-indentation.el b/elisp/shm-indentation.el new file mode 100644 --- /dev/null +++ b/elisp/shm-indentation.el @@ -0,0 +1,636 @@ +;;; shm-indentation.el --- Indentation functions + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'shm-nodes) +(require 'shm-navigation) + +(defun shm/delete-indentation () + "Send the node up one line." + (interactive) + (if (looking-back "^[ ]+") + (cond + ((or (looking-at "then[] [{}\"'()]") + (looking-at "else[] [{}\"'()]")) + (delete-indentation)) + ((looking-at "[ ]*$") + (delete-indentation)) + (t (let ((string (shm-kill-node 'buffer-substring-no-properties))) + (delete-indentation) + (insert " ") + (shm-insert-indented + (lambda () + (insert string)))))) + (delete-indentation))) + +(defun shm/swing-down () + "Swing the children of the current node downwards. + +hai = do foo bar + mu zot + +With the cursor on `do', this will produce: + +hai = do + foo bar + mu zot +" + (interactive) + (let* ((current-pair (shm-current-node-pair)) + (current (cdr current-pair))) + (cond + ((eq (shm-node-cons current) + 'Do) + (let ((swing-string + (shm-kill-node 'buffer-substring-no-properties + current + (shm-node-start (shm-node-child current-pair))))) + (shm/newline-indent) + (shm-insert-indented (lambda () (insert swing-string))))) + ((eq (shm-node-cons current) + 'Var) + (let* ((next-pair (shm-node-next current-pair)) + (parent-pair (shm-node-parent current-pair)) + (start (shm-node-start-column (cdr parent-pair)))) + (let ((swing-string + (shm-kill-region 'buffer-substring-no-properties + (shm-node-start (cdr next-pair)) + (shm-node-end (cdr parent-pair)) + nil))) + (shm/reparse) + (forward-char -1) + (newline) + (indent-to (+ (shm-indent-spaces) + start)) + (shm-insert-indented (lambda () (insert swing-string)))))) + (t + (error "Don't know how to swing that kind of expression."))))) + +(defun shm/swing-up () + "Swing the children of the current node upwards. + +hai = do + foo bar + mu zot + +With the cursor on `do', this will produce: + +hai = do foo bar + mu zot +" + (interactive) + (let* ((current-pair (shm-current-node-pair)) + (current (cdr current-pair))) + (cond + ((eq (shm-node-cons current) + 'Do) + (let ((swing-string + (shm-kill-node 'buffer-substring-no-properties + current + (shm-node-start (shm-node-child current-pair))))) + (delete-indentation) + (if (looking-at " ") + (forward-char 1) + (insert " ")) + (shm-insert-indented (lambda () (insert swing-string))))) + (t + (error "Don't know how to swing that kind of expression."))))) + +(defun shm/newline-indent () + "Make a newline and indent, making sure to drag anything down, re-indented + with it." + (interactive) + (cond + ((and (shm-in-string) + (not (= (shm-node-start (shm-current-node)) + (point)))) + (let ((column (shm-node-start-column (shm-current-node)))) + (insert "\\") + (newline) + (indent-to column) + (insert "\\"))) + ((and (looking-at "[^])}\"]") ;; This is a cheap solution. It + ;; could use node boundaries + ;; instead. + (not (looking-at "$")) + (looking-back " ")) + ;; If there's some stuff trailing us, then drag that with us. + (let ((newline-string (shm-kill-node 'buffer-substring-no-properties)) + (point (point))) + (shm-newline-indent t) + (shm-insert-indented + (lambda () + (insert newline-string))))) + ;; Otherwise just do the indent. + (t (shm-newline-indent nil)))) + +(defun shm/goto-where () + "Either make or go to a where clause of the current right-hand-side." + (interactive) + (let ((node-pair (shm-current-node-pair)) + (vector (shm-decl-ast))) + (loop for i + downfrom (car node-pair) + to -1 + until (or (= i -1) + (let ((node (elt vector i))) + (and (string= "Rhs" + (shm-node-type-name node)) + (<= (shm-node-start node) + (shm-node-start (cdr node-pair))) + (>= (shm-node-end node) + (shm-node-end (cdr node-pair)))))) + finally (return + (when (>= i 0) + (let ((rhs (elt vector i))) + (goto-char (shm-node-end rhs)) + (cond + ((looking-at "[\n ]*where") + (search-forward-regexp "where[ \n]*")) + (t + (unless (= (line-beginning-position) (point)) + (newline)) + (indent-to + (+ 2 + (shm-node-start-column + (cdr (shm-node-parent (cons i rhs)))))) + (insert "where "))))))))) + +(defun shm/tab () + "Either indent if at the start of a line, or jump to the next + slot." + (interactive) + (cond + ((save-excursion (goto-char (line-beginning-position)) + (looking-at "^[ ]*$")) + (shm/simple-indent)) + (t + (shm/jump-to-slot)))) + +(defun shm/backtab () + "Either de-indent if at the start of a line, or jump to the previous + slot." + (interactive) + (cond + ((save-excursion (goto-char (line-beginning-position)) + (looking-at "^[ ]*$")) + (shm/simple-indent-backtab)) + (t + (shm/jump-to-previous-slot)))) + +(defun shm/simple-indent () + "Space out to under next visible indent point. +Indent points are positions of non-whitespace following whitespace in +lines preceeding point. A position is visible if it is to the left of +the first non-whitespace of every nonblank line between the position and +the current line. If there is no visible indent point beyond the current +column, `tab-to-tab-stop' is done instead." + (interactive) + (let* ((start-column (current-column)) + (invisible-from nil) ; `nil' means infinity here + (indent + (catch 'shm-simple-indent-break + (save-excursion + (while (progn (beginning-of-line) + (not (bobp))) + (forward-line -1) + (if (not (looking-at "[ \t]*\n")) + (let ((this-indentation (current-indentation))) + (if (or (not invisible-from) + (< this-indentation invisible-from)) + (if (> this-indentation start-column) + (setq invisible-from this-indentation) + (let ((end (line-beginning-position 2))) + (move-to-column start-column) + ;; Is start-column inside a tab on this line? + (if (> (current-column) start-column) + (backward-char 1)) + (or (looking-at "[ \t]") + (skip-chars-forward "^ \t" end)) + (skip-chars-forward " \t" end) + (let ((col (current-column))) + (throw 'shm-simple-indent-break + (if (or (= (point) end) + (and invisible-from + (> col invisible-from))) + invisible-from + col))))))))))))) + (if indent + (let ((opoint (point-marker))) + (indent-line-to indent) + (if (> opoint (point)) + (goto-char opoint)) + (set-marker opoint nil)) + (tab-to-tab-stop)))) + +(defun shm/simple-indent-backtab () + "Indent backwards. Dual to `shm-simple-indent'." + (interactive) + (let ((current-point (point)) + (i 0) + (x 0)) + (goto-char (line-beginning-position)) + (save-excursion + (while (< (point) current-point) + (shm/simple-indent) + (setq i (+ i 1)))) + (while (< x (- i 1)) + (shm/simple-indent) + (setq x (+ x 1))))) + +(defun shm/simple-indent-newline-same-col () + "Make a newline and go to the same column as the current line." + (interactive) + (let ((point (point))) + (let ((start-end + (save-excursion + (let* ((start (line-beginning-position)) + (end (progn (goto-char start) + (search-forward-regexp + "[^ ]" (line-end-position) t 1)))) + (when end (cons start (1- end))))))) + (if start-end + (progn (newline) + (insert (buffer-substring-no-properties + (car start-end) (cdr start-end)))) + (newline))))) + +(defun shm/simple-indent-newline-indent () + "Make a newline on the current column and indent on step." + (interactive) + (shm/simple-indent-newline-same-col) + (insert (make-string (shm-indent-spaces) ? ))) + +(defun shm-appropriate-adjustment-point () + "Go to the appropriate adjustment point. + +This is called before calling `shm-adjust-dependents', because some places, e.g. + +zoo = do + bar + mu + +If the point is at 'z', then we should *not* move 'bar' or 'mu', +even though we normally would. To avoid doing this, we use a very +simple but 90% effective (100% is rather hard, will not be +appearing in a beta version) heuristic. We jump to here: + +zoo| = do + bar + mu + +And use our normal adjustment test there. After all, only thing +after 'zoo' are *really* dependent." + (let ((current (shm-current-node))) + (when (and current + (<= (shm-node-end current) (line-end-position))) + (goto-char (shm-node-end current))))) + +(defun shm-newline-indent (dragging) + "Go to the next logical line from the current node at the right column. + +This function uses the node's type to decode how to indent, and +in some cases will insert commas and things like for tuples and +lists. + +DRAGGING indicates whether this indent will drag a node downwards." + (let* ((current-pair (shm-current-node-pair)) + (current (cdr current-pair)) + (parent-pair (shm-node-parent current-pair)) + (parent (cdr parent-pair)) + (inhibit-read-only t)) + (cond + ((or (string= (shm-node-type-name current) + "ImportSpecList") + (and (string= (shm-node-type-name current) + "ModuleName") + (looking-at "$") + parent + (string= (shm-node-type-name parent) + "ImportDecl"))) + (newline) + (insert "import ")) + ;; When inside a list, indent to the list's position with an + ;; auto-inserted comma. + ((and parent + (eq 'List (shm-node-cons parent))) + (newline) + (indent-to (shm-node-start-column parent)) + (insert ",") + (shm-set-node-overlay parent-pair)) + ;; Lambdas indents k spaces inwards + ((eq 'Lambda (shm-node-cons current)) + (newline) + (indent-to (+ (shm-indent-spaces) (shm-node-start-column current)))) + ;; Indentation for function application. + ((and parent + (or (eq 'App (shm-node-cons parent)) + (eq 'TyApp (shm-node-cons parent)))) + (let ((column + (save-excursion + (shm/goto-parent) + (forward-sexp) + (1+ (current-column))))) + (cond + + ((and (or (= column (current-column)) + (= column (+ (shm-node-start-column parent) + (shm-indent-spaces)))) + (/= column (shm-node-start-column parent))) + (newline) + (indent-to (+ (shm-node-start-column parent) + (shm-indent-spaces)))) + (t + (newline) + (indent-to column))))) + ;; Indent for sum types + ((or (and parent + (eq 'DataDecl (shm-node-cons parent))) + (eq 'ConDecl (shm-node-cons current))) + (newline) + (indent-to (shm-node-start-column current)) + (delete-char -2) + (insert "| ")) + ;; Auto-insert commas for field updates + ((or (string= "FieldUpdate" (shm-node-type-name current)) + (string= "FieldDecl" (shm-node-type-name current)) + (string= "ExportSpec" (shm-node-type-name current)) + (string= "ImportSpec" (shm-node-type-name current))) + ;; This is hacky because HSE doesn't have special nodes for the + ;; record and the update in record {update} and so we have to + ;; figure out where the { starts. There is some additional + ;; information in HSE's trees, but I haven't thought of a nice + ;; way to extract that yet. + (goto-char (shm-node-end parent)) + (backward-sexp) + (let ((column (current-column))) + (goto-char (shm-node-end current)) + (newline) + (indent-to column) + (insert ",") + (insert (make-string (abs (- (shm-node-start-column current) + (1+ column))) + ? )) + (shm/init))) + ((and parent + (eq 'Lambda (shm-node-cons parent))) + (cond + ((eq shm-lambda-indent-style 'leftmost-parent) + (let ((leftmost-parent (cdr (shm-find-furthest-parent-on-line parent-pair)))) + (newline) + (indent-to (+ (shm-indent-spaces) + (shm-node-indent-column leftmost-parent))))) + (t (newline) + (indent-to (+ (shm-indent-spaces) + (shm-node-start-column parent)))))) + ;; Guards | foo = … + ((or (string= "GuardedRhs" (shm-node-type-name current)) + (string= "GuardedAlt" (shm-node-type-name current))) + (newline) + (indent-to (shm-node-start-column current)) + (insert "| ")) + ;; Indent after or at the = (an rhs). + ((and parent + (or (string= "Rhs" (shm-node-type-name parent)) + (string= "Rhs" (shm-node-type-name current)) + (string= "GuardedAlt" (shm-node-type-name parent)) + (string= "GuardedRhs" (shm-node-type-name parent)))) + (newline) + (indent-to (+ (shm-indent-spaces) + (shm-node-start-column (cdr (shm-node-parent parent-pair)))))) + ;; When in a field update. + ((and parent + (string= "FieldUpdate" (shm-node-type-name parent))) + (newline) + (indent-to (+ (shm-node-start-column parent) + (shm-indent-spaces)))) + ;; When in an alt list + ((and parent + (string= "GuardedAlts" (shm-node-type-name current))) + (newline) + (indent-to (+ (shm-node-start-column parent) + (shm-indent-spaces)))) + ;; When in a case alt. + ((and parent + (string= "GuardedAlts" (shm-node-type-name parent))) + (newline) + (let ((alt (cdr (shm-node-parent parent-pair)))) + (indent-to (+ (shm-node-start-column alt) + (shm-indent-spaces))))) + ;; Copy infix operators similar to making new list/tuple + ;; separators + ((and parent + (eq 'InfixApp (shm-node-cons parent))) + (let* ((operand-pair (shm-node-previous current-pair)) + (operand (cdr operand-pair)) + (string (buffer-substring-no-properties (shm-node-start operand) + (shm-node-end operand)))) + (cond + (dragging + (newline) + (indent-to (shm-node-start-column parent))) + ((save-excursion (goto-char (shm-node-end operand)) + (= (point) (line-end-position))) + (insert " " string) + (newline) + (indent-to (shm-node-start-column current))) + (t + (newline) + (indent-to (shm-node-start-column operand)) + (insert string " "))))) + ;; Infix operators + ((and parent + (eq 'InfixApp (shm-node-cons parent))) + (newline) + (indent-to (+ (shm-node-start-column parent)))) + ;; Commenting out this behaviour for now + ;; ((string= "Match" (shm-node-type-name current)) + ;; (let ((name (cdr (shm-node-child-pair current-pair)))) + ;; (newline) + ;; (indent-to (shm-node-start-column current)) + ;; (insert (buffer-substring-no-properties (shm-node-start name) + ;; (shm-node-end name)) + ;; " "))) + ;; Default indentation just copies the current node's indentation + ;; level. Generally works reliably, but has less than favourable + ;; indentation sometimes. It just serves as a catch-all. + (t + (newline) + (indent-to (shm-node-start-column current)))))) + +(defun shm-adjust-dependents (end-point n) + "Adjust dependent lines by N characters that depend on this +line after END-POINT." + (let ((line (line-number-at-pos))) + (when (and (not (and (looking-back "^[ ]+") + (looking-at "[ ]*"))) + (save-excursion (goto-char end-point) + (forward-word) + (= (line-number-at-pos) line))) + (shm-move-dependents n + end-point)))) + +(defun shm-move-dependents (n point) + "Move dependent-with-respect-to POINT lines N characters forwards or backwards. + +This is purely based on alignments. If anything is aligned after +the current column, then it's assumed to be a child of whatever +has recently changed at POINT, and thus we 'bring it along' +either forwards or backwards. + +The algorithm isn't quite comprehensive, it needs special cases +for top-level functions and things like that." + (save-excursion + (let ((column (progn (goto-char point) + (current-column))) + (point nil) + (end-point nil)) + (while (and (= 0 (forward-line 1)) + (or (not end-point) + (/= end-point (line-end-position)))) + (if (shm-line-indented-past (1+ column)) + (progn (unless point + (setq point (goto-char (line-beginning-position)))) + (setq end-point (line-end-position))) + (goto-char (point-max)))) + (when end-point + (indent-rigidly point end-point n))))) + +(defun shm-line-indented-past (n) + "Is the current line indented past N?" + (goto-char (line-beginning-position)) + (let ((column (search-forward-regexp "[^ ]" (line-end-position) t 1))) + (if column + (>= (1- (current-column)) n) + t))) + +(defun shm-insert-string (string) + "Insert the given string." + (save-excursion + (shm-appropriate-adjustment-point) + (shm-adjust-dependents (point) (length string))) + (insert string) + (shm/init t)) + +(defun shm-insert-indented (do-insert) + "Insert, indented in The Right Way. Calls DO-INSERT to do the insertion. + +This function assumes a certain semantic meaning towards the +contents of the kill ring. That is, + +do bar + mu + +Is an expression which, when pasted, into + +main = + +should yield, + +main = do bar + mu + +Which is so convenient it changes the way you work. However, +there is also the other case: + + do +bar +mu + +This is what happens when you have expressions whose children +hang on the underside, and thus pasting these can be done in two +ways: (1) the above way, (2) or like this: + +main = do + bar + mu + +I.e. take the parent into account and try to re-paste an +underside dangling expression. I don't like this style. With SHM +this style becomes pointless and in fact detrimental. It's much +easier to read and manipulate children who are next to their +parents. But one must compromise and conform to some styles no +matter how poorly reasoned. + +We can actually give the option for people to pick and choose +this underside dangling vs not. But that will be implemented as a +separate function rather than hard-coded into this one specific +operation." + (let ((column (current-column)) + (line (line-beginning-position)) + (start (point)) + (in-string (shm-in-string))) + (let ((string (with-temp-buffer + (funcall do-insert) + (buffer-string)))) + (insert + ;; Pasting inside a string should escape double quotes and + ;; convert newlines to multiline strings. + (if in-string + (replace-regexp-in-string + "\"" "\\\\\"" + (replace-regexp-in-string + "\n" "\\\\n\\\\\n\\\\" + string)) + string))) + (when (= line (line-beginning-position)) + (shm-adjust-dependents start (- (current-column) + column))) + (let ((end (point))) + (cond + ((progn (goto-char start) + (looking-at " ")) + (let ((node (cdr (shm-find-furthest-parent-on-line (shm-current-node-pair))))) + (goto-char end) + (indent-rigidly start + end + (+ (shm-indent-spaces) + (shm-node-indent-column node))) + (delete-region start + (save-excursion + (goto-char start) + (search-forward-regexp "[ ]+" (line-end-position) t 1))))) + (t (goto-char end) + (indent-rigidly start end + (if in-string + (1- column) + column)))) + (setq shm-last-yanked (list start (point))) + (goto-char start)))) + +(defun shm-find-furthest-parent-on-line (current) + "Find the parent which starts nearest to column 0 on the +current line. + +This is used when indenting dangling expressions." + (let ((parent (shm-node-parent current))) + (if parent + (if (= (line-beginning-position) + (save-excursion (goto-char (shm-node-start (cdr parent))) + (line-beginning-position))) + (shm-find-furthest-parent-on-line parent) + current) + current))) + +(defun shm-indent-spaces () + "Get the number of spaces to indent." + (if (boundp 'haskell-indent-spaces) + haskell-indent-spaces + shm-indent-spaces)) + +(provide 'shm-indentation) diff --git a/elisp/shm-insertion.el b/elisp/shm-insertion.el new file mode 100644 --- /dev/null +++ b/elisp/shm-insertion.el @@ -0,0 +1,339 @@ +;;; shm-insertion.el --- Operations to insert things + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'shm-evaporate) +(require 'shm-skeletons) +(require 'shm-nodes) + +(defun shm/insert-undefined () + "Insert undefined." + (interactive) + (save-excursion + (let ((point (point))) + (shm-insert-string "undefined") + (shm-evaporate point (point))))) + +(defun shm/wrap-parens () + "Wrap the node in parentheses." + (interactive) + (cond + ((region-active-p) + (let ((beg (region-beginning)) + (end (region-end))) + (goto-char beg) + (insert "(") + (goto-char (1+ end)) + (insert ")") + (goto-char (1+ beg)))) + (t (let ((line (line-number-at-pos)) + (node (shm-current-node))) + (save-excursion + (goto-char (shm-node-start node)) + (insert "(") + (goto-char (shm-node-end node)) + (when (/= line (line-number-at-pos)) + (indent-rigidly (shm-node-start node) + (shm-node-end node) + 1)) + (insert ")")) + (forward-char 1))))) + +(defun shm/space () + "Insert a space but sometimes do something more clever, like + inserting skeletons." + (interactive) + (if (and (bound-and-true-p god-local-mode) + (fboundp 'god-mode-self-insert)) + (god-mode-self-insert) + (cond + ((shm-in-comment) + (insert " ")) + (shm-auto-insert-skeletons + (cond + ((and (looking-back "[^a-zA-Z0-9_]do") + (or (eolp) + (looking-at "[])}]"))) + (shm-auto-insert-do)) + ((and (looking-back " <-") + (let ((current (shm-current-node))) + (when current + (or (eq 'Do (shm-node-cons current)) + (string= "Stmt" (shm-node-type-name current)))))) + (shm-auto-insert-stmt 'qualifier)) + ((looking-back "[^a-zA-Z0-9_]case") + (shm-auto-insert-case)) + ((looking-back "[^a-zA-Z0-9_]if") + (shm-auto-insert-if)) + ((looking-back "[^a-zA-Z0-9_]let") + (cond + ((let ((current (shm-current-node))) + (not (or (eq 'Do (shm-node-cons current)) + (eq 'BDecls (shm-node-cons current)) + (string= "Stmt" (shm-node-type-name current))))) + (shm-auto-insert-let)) + (t (shm-auto-insert-stmt 'let)))) + ((and (looking-back "module") + (= (line-beginning-position) + (- (point) 6)) + (looking-at "[ ]*$")) + (shm-auto-insert-module)) + (t (insert " ")))) + (t (insert " "))))) + +(defun shm/jump-to-slot () + "Jump to the next skeleton slot." + (interactive) + (let ((os (sort (remove-if-not (lambda (o) (overlay-get o 'shm-evaporate-overlay)) + (overlays-in (point) (point-max))) + (lambda (a b) + (< (overlay-start a) + (overlay-start b)))))) + (when os + (if (= (overlay-start (car os)) + (point)) + (when (cadr os) + (goto-char (overlay-start (cadr os)))) + (goto-char (overlay-start (car os))))))) + +(defun shm/jump-to-previous-slot () + "Jump to the previous skeleton slot." + (interactive) + (let ((os (sort (remove-if-not (lambda (o) (overlay-get o 'shm-evaporate-overlay)) + (overlays-in (point-min) (point))) + (lambda (a b) + (> (overlay-start a) + (overlay-start b)))))) + (when os + (if (= (overlay-start (car os)) + (point)) + (when (cadr os) + (goto-char (overlay-start (cadr os)))) + (goto-char (overlay-start (car os))))))) + +(defun shm/double-quote () + "Insert double quotes. + +This tries to be clever about insertion. If already in a string, +it will insert \", if at the end of a string, it will glide over +the ending quote. If not in a string, it will insert \"\", and +also space out any neccessary spacing." + (interactive) + (shm/reparse) + (if (shm-in-comment) + (insert "\"") + (let* ((current-node (shm-current-node)) + (node (if (eq 'Lit (shm-node-cons current-node)) + (shm-actual-node) + current-node))) + (cond + ((shm-find-overlay 'shm-quarantine) + (insert "\"\"") + (forward-char -1)) + ;; "…|…" + ((shm-in-string) + (cond + ;; "…|" + ((= (point) + (1- (shm-node-end node))) + (forward-char 1)) + ;; "…|…" + ((= (point) (shm-node-end node)) + (if (looking-back "\"") + (shm-delimit "\"" "\"") + (progn (insert "\"")))) + (t (let ((inhibit-read-only t)) + (shm-adjust-dependents (point) 2) + (insert "\\\""))))) + ;; '|' + ((save-excursion (forward-char -1) + (looking-at "''")) + (let ((inhibit-read-only t)) + (shm-adjust-dependents (point) 1) + (insert "\""))) + ;; anywhere + (t + (shm-delimit "\"" "\"")))))) + +(defun shm/comma (n) + "Insert a comma. In a list it tries to help a bit by setting +the current node to the parent." + (interactive "p") + (if (shm-in-comment) + (self-insert-command n) + (let* ((current-pair (shm-current-node-pair)) + (current (cdr current-pair)) + (parent-pair (shm-node-parent current-pair)) + (parent (cdr parent-pair))) + (cond + ;; When inside a list, indent to the list's position with an + ;; auto-inserted comma. + ((eq 'List (shm-node-cons parent)) + (shm-insert-string ",") + (shm-set-node-overlay parent-pair)) + (t + (shm-insert-string ",") + (shm-set-node-overlay parent-pair)))))) + +(defun shm/single-quote () + "Delimit single quotes." + (interactive) + (shm-delimit "'" "'")) + +(defun shm/= () + "Insert equal." + (interactive) + (cond + ((shm-literal-insertion) + (insert "=")) + (t (unless (looking-back " ") + (shm-insert-string " ")) + (shm-insert-string "=") + (unless (looking-at " ") + (shm-insert-string " "))))) + +(defun shm/: () + "Insert colon." + (interactive) + (if (shm-literal-insertion) + (call-interactively 'self-insert-command) + (let ((current (shm-current-node))) + (cond + ((and current + (or (eq (shm-node-cons current) + 'SpliceDecl) + (string= (shm-node-type-name current) + "BangType") + (string= (shm-node-type-name current) + "FieldDecl"))) + (unless (looking-back "[ ]+") + (insert " ")) + (unless (looking-back "::[ ]+") + (shm-insert-string ":: a") + (forward-word -1) + (shm-evaporate (point) (1+ (point))))) + (t + (shm-insert-string ":")))))) + +(defun shm/hyphen (n) + "The - hyphen." + (interactive "p") + (if (and (looking-back "{") + (looking-at "}")) + (progn (insert "--") + (forward-char -1)) + (self-insert-command n))) + +(defun shm/hash (n) + "The # hash." + (interactive "p") + (if (and (looking-back "{-") + (looking-at "-}")) + (progn (insert "# #") + (forward-char -2)) + (self-insert-command n))) + +(defun shm/open-paren () + "Delimit parentheses." + (interactive) + (let ((current (shm-current-node))) + (cond + ((and current + (or (string= "ExportSpec" (shm-node-type-name current)) + (string= "ImportSpec" (shm-node-type-name current)))) + (insert "()") + (forward-char -1)) + (t + (shm-delimit "(" ")"))))) + +(defun shm/open-bracket () + "Delimit brackets." + (interactive) + (shm-delimit "[" "]")) + +(defun shm/open-brace () + "Delimit braces." + (interactive) + (let ((current (shm-current-node))) + (cond + ((and current + (string= "Pat" (shm-node-type-name current))) + (shm-insert-string "{}") + (forward-char -1)) + (t + (shm-delimit "{" "}"))))) + +(defun shm-delimit (open close) + "Insert the given delimiters. + +This is a special function because it will do different things +depending on the context. + +If we're in a string, it just inserts OPEN. If we're in an +expression, it will insert OPEN and CLOSE and put the point +between them. It will also space out so that there is space +between previous nodes and the next. E.g. + +foo|(bar) + +If you hit \" at | then you will get: + +foo \"\" (bar) + +It saves one having to type spaces; it's obvious what to do +here." + (cond + ((and (shm-literal-insertion) + (not (string= open "\""))) + (shm-insert-string open)) + (t + (shm/reparse) + (let ((current (shm-actual-node))) + (cond + ((shm-find-overlay 'shm-quarantine) + (if (not (or (looking-back "[ ,[({]") + (bolp))) + (progn (shm-insert-string " ") 1) + 0) + (shm-insert-string open) + (let ((point (point))) + (shm-insert-string close) + (when (and (/= (point) (line-end-position)) + (not (looking-at "[]){} ,]"))) + (shm-insert-string " ")) + (goto-char point))) + (t + (if (not (or (looking-back "[ ,[({]") + (bolp))) + (progn (shm-insert-string " ") 1) + 0) + (shm-insert-string open) + (let ((point (point))) + (shm-insert-string close) + (when (and (/= (point) (line-end-position)) + (not (looking-at "[]){} ,]"))) + (shm-insert-string " ")) + (goto-char point) + (shm/init t)))))))) + +(defun shm-literal-insertion () + "Should a node have literal insertion?" + (or (shm-in-string) + (shm-in-comment))) + +(provide 'shm-insertion) diff --git a/elisp/shm-macros.el b/elisp/shm-macros.el new file mode 100644 --- /dev/null +++ b/elisp/shm-macros.el @@ -0,0 +1,34 @@ +;;; shm-macros.el --- Macros + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(defmacro shm-with-fallback (fallback &rest body) + "Perform the given action unless we're in a comment, in which + case run the fallback function insteaad." + `(if (shm-in-comment) + (call-interactively ',fallback) + (if debug-on-error + (progn ,@body) + (condition-case e + (progn ,@body) + (error + (message "(SHM command failed, falling back to %S. Run M-: (setq debug-on-error t) to see the error.)" + ',fallback) + (call-interactively ',fallback)))))) + +(provide 'shm-macros) diff --git a/elisp/shm-navigation.el b/elisp/shm-navigation.el new file mode 100644 --- /dev/null +++ b/elisp/shm-navigation.el @@ -0,0 +1,117 @@ +;;; shm-navigation.el --- Navigation functions that don't change the buffer + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(defun shm/forward-paragraph () + "Go forward one declaration." + (interactive) + (unless (/= (point) + (goto-char (cdr (shm-decl-points)))) + (search-forward-regexp "[^\n ]" nil t 1) + (backward-char))) + +(defun shm/backward-paragraph () + "Go backward one declaration." + (interactive) + (unless (/= (point) + (goto-char (car (shm-decl-points)))) + (search-backward-regexp "[^\n ]" nil t 1) + (forward-char))) + +(defun shm/close-paren () + "Either insert a close paren or go to the end of the node." + (interactive) + (shm-with-fallback + self-insert-command + (if (shm-literal-insertion) + (shm-insert-string ")") + (progn (shm/reparse) + (shm/goto-parent-end))))) + +(defun shm/close-bracket () + "Either insert a close bracket or go to the end of the node." + (interactive) + (shm-with-fallback + self-insert-command + (if (shm-literal-insertion) + (shm-insert-string "]") + (progn (shm/reparse) + (shm/goto-parent-end))))) + +(defun shm/close-brace () + "Either insert a close brace or go to the end of the node." + (interactive) + (shm-with-fallback + self-insert-command + (if (shm-literal-insertion) + (shm-insert-string "}") + (progn (shm/reparse) + (shm/goto-parent-end))))) + +(defun shm/goto-parent-end () + "Set the current node overlay to the parent node, but go to the + end rather than the start." + (interactive) + (shm/goto-parent nil 'end)) + +(defun shm/forward-node () + "Go forward by node, i.e. go to the next of the current node. If +we're already at the end of the current node, jump to the next +node." + (interactive) + (let* ((current-pair (shm-current-node-pair)) + (current (cdr current-pair))) + (if (= (point) (shm-node-end current)) + (let ((next-pair (shm-node-next current-pair))) + (goto-char (shm-node-start (cdr next-pair)))) + (goto-char (shm-node-end current))))) + +(defun shm/backward-node () + "Go backward by node, i.e. go to the previous of the current node. If +we're already at the start of the current node, jump to the previous +node." + (interactive) + (let* ((current-pair (shm-current-node-pair)) + (current (cdr current-pair))) + (if (= (point) (shm-node-start current)) + (let ((prev-pair (shm-node-previous current-pair))) + (goto-char (shm-node-start (cdr prev-pair)))) + (goto-char (shm-node-start current))))) + +(defun shm/goto-parent (&optional node-pair direction) + "Set the current node overlay to the parent node-pair" + (interactive) + (let ((direction (or direction 'start))) + (if shm-current-node-overlay + (let* ((o shm-current-node-overlay) + (parent-pair (shm-node-parent (or node-pair + (shm-current-workable-node))))) + (when parent-pair + (let ((parent (cdr parent-pair))) + (if (and o + (overlay-buffer o) + (>= (shm-node-start parent) + (overlay-start o)) + (<= (shm-node-end parent) + (overlay-end o))) + (shm/goto-parent parent-pair direction) + (shm-set-node-overlay parent-pair direction))))) + (when node-pair + (shm-set-node-overlay node-pair direction))))) + +(provide 'shm-navigation) diff --git a/elisp/shm-nodes.el b/elisp/shm-nodes.el new file mode 100644 --- /dev/null +++ b/elisp/shm-nodes.el @@ -0,0 +1,348 @@ +;;; shm-nodes.el --- Node operations + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'shm-overlays) + +(require 'cl) + +(defun shm-decl-ast (&optional reparse) + "Return the AST representing the current declaration at point. + +If the AST has already been loaded, that is returned immediately, +otherwise it's regenerated. See the Internal AST section below +for more information." + (let ((p (shm-decl-points))) + (when p + (shm-get-decl-ast (car p) + (cdr p) + reparse)))) + +(defun shm-current-node () + "Return just the current node, without its index. + +See `shm-current-node-pair' for what 'current' means." + (cdr (shm-current-node-pair))) + +(defun shm-actual-node () + "Return just the actual current node, without its index. + +Normally node functions only care about the current workable +node. This function will return the *actual* node at point. See +`shm-current-node-pair' for what 'workable' means." + (cdr (shm-node-backwards))) + +(defun shm-current-node-pair () + "Return the current workable node at point. + +Workable means that it is something that we want to be able to +parse. + +For example, if we're looking at a Name, + +foobar + +then that is all well and good, but we don't want to edit a Name, +nor a QName (the parent), we want to edit an Exp (parent-parent) +whose constructor will be a Var." + (let ((current (shm-node-backwards))) + (when current + (if (and shm-current-node-overlay + (overlay-buffer shm-current-node-overlay) + (or (= (shm-node-start (cdr current)) + (overlay-start shm-current-node-overlay)) + (= (shm-node-end (cdr current)) + (overlay-end shm-current-node-overlay)))) + (overlay-get shm-current-node-overlay 'node-pair) + (shm-workable-node current))))) + +(defun shm-current-workable-node () + "Returns the same as `shm-current-node' but including the index." + (let ((current (shm-node-backwards))) + (when current + (shm-workable-node current)))) + +(defun shm-decl-node (start) + "Get the top-level node of the declaration." + (let* ((vector (save-excursion (goto-char start) + (shm-decl-ast)))) + (elt vector 0))) + +(defun shm-workable-node (current-pair) + "Assume that the given CURRENT node is not workable, and look +at the parent. If the parent has the same start/end position, +then the parent is the correct one to work with." + (let* ((parent-pair (shm-node-parent current-pair)) + (parent (cdr parent-pair)) + (current (cdr current-pair))) + (cond + + (t (if parent + (if (and (= (shm-node-start current) + (shm-node-start parent)) + (= (shm-node-end current) + (shm-node-end parent))) + (if (string= (shm-node-type current) (shm-node-type parent)) + current-pair + (shm-workable-node parent-pair)) + current-pair) + current-pair))))) + +(defun shm-node-previous (node-pair) + "Get the previous node of NODE-PAIR." + (let ((vector (shm-decl-ast))) + (loop for i + downfrom (car node-pair) + to -1 + until (or (= i -1) + (let ((node (elt vector i))) + (<= (shm-node-end node) + (shm-node-start (cdr node-pair))))) + finally (return + (when (>= i 0) + (shm-workable-node (cons i + (elt vector i)))))))) + +(defun shm-node-next (node-pair) + "Get the next node of NODE-PAIR." + (let ((vector (shm-decl-ast))) + (loop for i + from 0 + to (length vector) + until (or (= i (length vector)) + (let ((node (elt vector i))) + (>= (shm-node-start node) + (shm-node-end (cdr node-pair))))) + finally (return + (when (< i (length vector)) + (shm-workable-node (cons i + (elt vector i)))))))) + +(defun shm-node-backwards (&optional start type bound) + "Get the current node searching bottom up starting from START, +and optionally just searching for nodes of type TYPE. BOUND +restricts how far to look back. + +This is the fundamental way to look for a node in the declaration +vector. + +Backwards means we go from the last node in the list and go +backwards up the list, it doesn't mean backwards as in up the +tree." + (let* ((vector (shm-decl-ast)) + (point (point))) + (loop for i + downfrom (if start + (max -1 start) + (1- (length vector))) + to -1 + until (or (= i -1) + (let ((node (elt vector i))) + (or (and bound + (< (shm-node-start node) + bound)) + (and (>= point (shm-node-start node)) + (<= point (shm-node-end node)) + (or (not type) + (string= type + (shm-node-type node))))))) + finally (return + (when (and (>= i 0) + (not (and bound + (< (shm-node-start (elt vector i)) + bound)))) + (cons i + (elt vector i))))))) + +(defun shm-node-child-pair (node-pair) + "Return the immediate child-pair of the given parent." + (let ((vector (shm-decl-ast)) + (i (car node-pair))) + (when (< i (1- (length vector))) + (cons (1+ i) + (elt vector (1+ i)))))) + +(defun shm-node-child (node-pair) + "Return the immediate child of the given parent." + (cdr (shm-node-child-pair node-pair))) + +(defun shm-node-ancestor-at-point (node-pair point) + "Find the highest up ancestor that still starts at this point." + (let ((parent-pair (shm-node-parent node-pair))) + (if parent-pair + (if (= (shm-node-start (cdr parent-pair)) + point) + (shm-node-ancestor-at-point parent-pair point) + node-pair) + node-pair))) + +(defun shm-node-parent (node-pair &optional type bound) + "Return the direct parent of the given node-pair. + +The start and end point of the parent can be the same as the +child, and in fact is common." + (save-excursion + (goto-char (shm-node-start (cdr node-pair))) + (let* ((actual-parent-pair (shm-node-backwards (1- (car node-pair)) + type + bound)) + (maybe-parent-parent-pair (when (car actual-parent-pair) + (shm-node-backwards (1- (car actual-parent-pair))))) + (actual-parent (cdr actual-parent-pair)) + (maybe-parent-parent (cdr maybe-parent-parent-pair))) + (cond ((and actual-parent-pair + maybe-parent-parent-pair + (string= (shm-node-type-name actual-parent) + (shm-node-type-name maybe-parent-parent)) + (and shm-skip-applications + (or (eq (shm-node-cons actual-parent) 'App) + (eq (shm-node-cons actual-parent) 'InfixApp) + (eq (shm-node-cons actual-parent) 'TyApp))) + (eq (shm-node-cons actual-parent) + (shm-node-cons maybe-parent-parent))) + (shm-node-parent actual-parent-pair)) + (t actual-parent-pair))))) + +(defun shm-decl-points () + "Get the start and end position of the current +declaration. This assumes that declarations start at column zero +and that the rest is always indented by one space afterwards, so +Template Haskell uses with it all being at column zero are not +expected to work." + (cond + ;; If we're in a block comment spanning multiple lines then let's + ;; see if it starts at the beginning of the line (or if any comment + ;; is at the beginning of the line, we don't care to treat it as a + ;; proper declaration. + ((and (shm-in-comment) + (save-excursion (goto-char (line-beginning-position)) + (shm-in-comment))) + nil) + ((save-excursion + (goto-char (line-beginning-position)) + (or (looking-at "^-}$") + (looking-at "^{-$"))) + nil) + ;; Otherwise we just do our line-based hack. + (t + (save-excursion + (let ((start (or (progn (goto-char (line-end-position)) + (search-backward-regexp "^[^ \n]" nil t 1) + (unless (or (looking-at "^-}$") + (looking-at "^{-$")) + (point))) + 0)) + (end (progn (goto-char (1+ (point))) + (or (when (search-forward-regexp "[\n]+[^ \n]" nil t 1) + (forward-char -1) + (search-backward-regexp "[^\n ]" nil t) + (forward-char) + (point)) + (point-max))))) + (cons start end)))))) + +(defun shm-node-type (n) + "Get the AST type of N." + (elt n 0)) + +(defun shm-node-type-name (n) + "Get just the constructor name part of N. + +This doesn't always return the correct thing, e.g. [Foo Bar] will +return [Foo. It's just a convenience function to get things like +Case or whatnot" + (nth 0 (split-string (elt n 0) " "))) + +(defun shm-node-cons (n) + "Get the constructor name of N." + (elt n 1)) + +(defun shm-node-start (n) + "Get the start position of N in its buffer." + (marker-position (elt n 2))) + +(defun shm-node-end (n) + "Get the end position of N in its buffer." + (marker-position (elt n 3))) + +(defun shm-node-set-start (n x) + "Set the start position of N." + (set-marker (elt n 2) x)) + +(defun shm-node-set-end (n x) + "Set the end position of N." + (set-marker (elt n 3) x)) + +(defun shm-node-delete-markers (n) + "Set the markers to NIL, which is about the best we can do for +deletion. The markers will be garbage collected eventually." + (set-marker (elt n 2) nil) + (set-marker (elt n 3) nil)) + +(defun shm-node-start-column (n) + "Get the starting column of N." + (save-excursion (goto-char (shm-node-start n)) + (current-column))) + +(defun shm-node-indent-column (n) + "Get the starting column of N." + (+ (shm-node-start-column n) + (if (or (string= "Tuple" (shm-node-cons n)) + (string= "Paren" (shm-node-cons n)) + (string= "List" (shm-node-cons n))) + 1 + 0))) + +(defun shm-node-end-column (n) + "Get the end column of N." + (save-excursion (goto-char (shm-node-end n)) + (current-column))) + +(defun shm-node-empty (n) + "Is the node empty of any text?" + (= (shm-node-start n) + (shm-node-end n))) + +(defun shm-node-pp (n) + "Pretty print the node." + (format "%s: %S: %d—%d" + (shm-node-type-name n) + (shm-node-cons n) + (shm-node-start n) + (shm-node-end n))) + +(defun shm-in-comment () + "Are we currently in a comment?" + (or (and (eq 'font-lock-comment-delimiter-face + (get-text-property (point) 'face)) + ;; This is taking liberties, but I'm not too sad about it. + (not (save-excursion (goto-char (line-beginning-position)) + (looking-at "{-")))) + (eq 'font-lock-doc-face + (get-text-property (point) 'face)) + (and (eq 'font-lock-comment-face + (get-text-property (point) 'face)) + (not (save-excursion (goto-char (line-beginning-position)) + (looking-at "{-")))))) + +(defun shm-in-string () + "Are we in a string?" + (or (eq 'font-lock-string-face + (get-text-property (point) 'face)))) + +(provide 'shm-nodes) diff --git a/elisp/shm-overlays.el b/elisp/shm-overlays.el new file mode 100644 --- /dev/null +++ b/elisp/shm-overlays.el @@ -0,0 +1,96 @@ +;;; shm-overlays.el --- Error and current node overlays + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + + +;; Requirements + +(require 'shm-globals) + + +;; Buffer locals + +(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)) + +(defun shm-delete-overlays (start end type) + "Delete overlays of the given type. This is used for both +current overlay and quarantines." + (mapc (lambda (o) + (when (overlay-get o type) + (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." + (let ((o (make-overlay start end nil nil t))) + (overlay-put o 'shm-current-overlay t) + (overlay-put o 'face 'shm-current-face) + (overlay-put o 'node-pair node-pair) + (overlay-put o 'priority 1) + o)) + +(defun shm-quarantine-overlay (start end) + "Make a quarantine from START to END." + (let ((o (make-overlay start end nil nil t))) + (overlay-put o 'shm-quarantine t) + (overlay-put o 'face 'shm-quarantine-face) + (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))))) + +(provide 'shm-overlays) diff --git a/elisp/shm-skeletons.el b/elisp/shm-skeletons.el new file mode 100644 --- /dev/null +++ b/elisp/shm-skeletons.el @@ -0,0 +1,163 @@ +;;; shm-skeletons.el --- Skeleton syntax templates + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'shm-evaporate) + +(defun shm-auto-insert-stmt (type) + "Insert template + +do x <- | + {undefined} +" + (let* ((current (shm-current-node)) + (column (save-excursion + (case type + ('let (backward-word 1) + (current-column)) + ('qualifier + (cond + ((eq 'Do (shm-node-cons current)) + (goto-char (shm-node-start current)) + (forward-char 2) + (search-forward-regexp "[^ \n]") + (1- (current-column))) + (t (goto-char (shm-node-start current)) + (current-column)))))))) + (unless (save-excursion + (let ((current-line (line-number-at-pos))) + (forward-line 1) + (goto-char (+ (line-beginning-position) + column)) + (and (not (bolp)) + (/= current-line (line-number-at-pos)) + (= (point) + (save-excursion (back-to-indentation) + (point)))))) + (save-excursion + (newline) + (indent-to column) + (insert "undefined") + (forward-word -1) + (shm/reparse) + (shm-evaporate (point) + (progn (forward-word 1) + (point))))) + (insert " "))) + +(defun shm-auto-insert-do () + "Insert template + +do {undefined} + {undefined} +" + (insert " ") + (let ((point (point)) + (column (current-column))) + (insert "undefined") + (newline) + (indent-to column) + (let ((next-point (point))) + (insert "undefined") + (goto-char point) + (shm/reparse) + (save-excursion + (shm-evaporate (point) (+ (point) (length "undefined"))) + (goto-char next-point) + (shm-evaporate (point) (+ (point) (length "undefined"))))))) + +(defun shm-auto-insert-case () + "Insert template + +case {undefined} of + {_} -> {undefined} +" + (let ((start (save-excursion (forward-char -1) + (search-backward-regexp "[^a-zA-Z0-9_]") + (forward-char 1) + (point))) + (template "case undefined of\n _ -> undefined")) + (shm-adjust-dependents (point) (- start (point))) + (delete-region start (point)) + (shm-adjust-dependents (point) (length (car (last (split-string template "\n"))))) + (shm-insert-indented + (lambda () + (insert template))) + (forward-char 5) + (shm/reparse) + (save-excursion + (shm-evaporate (point) (+ (point) (length "undefined"))) + (search-forward-regexp "_" nil nil 1) + (shm-evaporate (1- (point)) (point)) + (forward-char 4) + (shm-evaporate (point) (+ (point) (length "undefined")))))) + +(defun shm-auto-insert-if () + "Insert template + +if {undefined} + then {undefined} + else {undefined} + +or + +if {undefined} then {undefined} else {undefined} + +if inside parentheses." + (let ((start (save-excursion (forward-char -1) + (search-backward-regexp "[^a-zA-Z0-9_]") + (forward-char 1) + (point))) + (template (if (looking-at "$") + "if undefined\n then undefined\n else undefined" + "if undefined then undefined else undefined"))) + (shm-adjust-dependents (point) (- start (point))) + (delete-region start (point)) + (shm-adjust-dependents (point) (length (car (last (split-string template "\n"))))) + (shm-insert-indented + (lambda () + (insert template))) + (forward-char 3) + (save-excursion + (shm-evaporate (point) (+ (point) (length "undefined"))) + (search-forward-regexp "then ") + (shm-evaporate (point) (+ (point) (length "undefined"))) + (search-forward-regexp "else ") + (shm-evaporate (point) (+ (point) (length "undefined")))))) + +(defun shm-auto-insert-let () + "Insert template + +let | in {undefined}" + (delete-region (- (point) 3) (point)) + (shm-insert-indented (lambda () (insert "let \nin undefined"))) + (forward-char 4) + (save-excursion + (forward-word) + (forward-char 1) + (shm-evaporate (point) (+ (point) (length "undefined"))))) + +(defun shm-auto-insert-module () + "Insert template + +module | where" + (insert " where") + (backward-word 1) + (forward-char -1)) + +(provide 'shm-skeletons) diff --git a/elisp/shm-strings.el b/elisp/shm-strings.el new file mode 100644 --- /dev/null +++ b/elisp/shm-strings.el @@ -0,0 +1,88 @@ +;;; shm-strings.el --- String literal editing + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + + +;; Requirements + +(require 'shm-nodes) +(require 'shm-yank-kill) +(require 'shm-deletion) + + +;; Globals + +(defvar shm-string-node nil + "The string node that's currently being edited.") + +(defvar shm-string-buffer nil + "The buffer of the string node that's currently being edited.") + + +;; Mode + +(define-derived-mode shm-edit-string-mode + text-mode "String" + "Major mode for editing string content from a Haskell string.") + +(define-key shm-edit-string-mode-map (kbd "C-c C-c") 'shm-finish-editing-string) + +(defun shm/edit-string () + "Edit the string at point." + (interactive) + (let ((current (shm-current-node)) + (buffer (current-buffer)) + (string (shm-kill-node 'buffer-substring-no-properties nil nil t))) + (goto-char (shm-node-start current)) + (switch-to-buffer (get-buffer-create "*shm-string*")) + (erase-buffer) + (insert + (replace-regexp-in-string + "\\\\\"" "\"" + (replace-regexp-in-string + "\\\\n" "\n" + (replace-regexp-in-string + "^\"\\(.*\\)\"$" "\\1" + (replace-regexp-in-string + "\\\\\n\\\\" "" + string))))) + (shm-edit-string-mode) + (set (make-local-variable 'shm-string-node) + current) + (set (make-local-variable 'shm-string-buffer) + buffer) + (goto-char (point-min)))) + +(defun shm-finish-editing-string () + "Take the contents of the buffer and insert it back into the +original node in the Haskell buffer, replacing the old one." + (interactive) + (let ((finish-string (buffer-string)) + (buffer shm-string-buffer)) + (quit-window) + (switch-to-buffer buffer) + (shm/delete) + (insert "\"\"") + (forward-char -1) + (save-excursion + (font-lock-fontify-region (line-beginning-position) + (line-end-position))) + (shm-insert-indented (lambda () (insert finish-string))) + (forward-char -1))) + +(provide 'shm-strings) diff --git a/elisp/shm-test.el b/elisp/shm-test.el --- a/elisp/shm-test.el +++ b/elisp/shm-test.el @@ -1,5 +1,29 @@ +;;; shm-test.el --- Testing suite + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Simple test writing and running suite. + +;;; Code: + (require 'shm) (require 'shm-tests) +(require 'shm-overlays) (defvar shm-test-eob nil) @@ -116,7 +140,6 @@ t) (provide 'shm-test) - ;;; shm-test.el ends here ;; Local Variables: diff --git a/elisp/shm-tests.el b/elisp/shm-tests.el --- a/elisp/shm-tests.el +++ b/elisp/shm-tests.el @@ -1,18 +1,81 @@ +;;; shm.el --- Tests for structured-haskell-mode + +;; Copyright (c) 2013 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; A big list of tests. + +;;; Code: + (defvar shm-tests (list + (list :name "skip-trailing-comments" + :start-buffer-content "foo = do foo + let bar = 23 + bob = 23 + -- bar + -- test + bar + +" + :start-cursor 23 + :finish-cursor 57 + :current-node-overlay '(55 57) + :end-buffer-content "foo = do foo + let bar = 23 + bob = 23 + -- bar + -- test + bar + +" + :kbd "\206") + (list :name "kill-with-whitespace" + :start-buffer-content "foo = 123 + +bar = 123 + +mu = 123 + +" + :start-cursor 11 + :finish-cursor 22 + :current-node-overlay '(22 25) + :end-buffer-content "foo = 123 + +mu = 123 + +bar = 123 + +" + :kbd [67108896 14 5 23 4 14 5 return return 25]) (list :name "space-reindent" - :start-buffer-content "main = do let x = 123 + :start-buffer-content "main = do let x = 123 undefined " - :start-cursor 5 - :finish-cursor 6 - :current-node-overlay '(1 6) - :end-buffer-content "main = do let x = 123 + :start-cursor 5 + :finish-cursor 6 + :current-node-overlay '(1 6) + :end-buffer-content "main = do let x = 123 undefined " - :kbd " ") + :kbd " ") (list :name "goto-parent" :end-buffer-content "main = x " @@ -351,3 +414,5 @@ :kbd "-#"))) (provide 'shm-tests) + +;;; shm-tests.el ends here diff --git a/elisp/shm-transform.el b/elisp/shm-transform.el new file mode 100644 --- /dev/null +++ b/elisp/shm-transform.el @@ -0,0 +1,84 @@ +;;; shm-transform.el --- General code transformations + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(defun shm/add-operand () + "When in an infix application, figure out the operator and add +a new operand. E.g. + +foo <> bar| + +will give you + +foo <> bar <> | + +or + +foo <> |bar + +will give you + +foo <> | <> bar + +This is more convenient than typing out the same operator." + (interactive) + (let* ((current-pair (shm-current-node-pair)) + (current (cdr current-pair)) + (parent-pair (shm-node-parent current-pair)) + (parent (cdr parent-pair))) + (cond + ((eq 'InfixApp (shm-node-cons parent)) + (let ((qop + (or (shm-get-qop-string (cdr (shm-node-previous current-pair))) + (shm-get-qop-string (cdr (shm-node-next current-pair)))))) + (cond + (qop + (cond + ((= (point) (shm-node-start current)) + (let ((point (point))) + (shm-insert-string (concat " " qop " ")) + (goto-char point))) + ((= (point) (shm-node-end current)) + (shm-insert-string (concat " " qop " "))) + (t (error "Please go to the start or end of the node to indicate direction.")))) + (t (error "Unable to figure out the operator."))))) + (t (error "Not in an infix application."))))) + +(defun shm/raise () + "Raise the expression up one, replacing its parent." + (interactive) + (let* ((current-pair (shm-current-node-pair)) + (current (cdr current-pair)) + (parent-pair (shm-node-parent current-pair (shm-node-type current))) + (parent (cdr parent-pair))) + (if parent + (if (string= (shm-node-type current) + (shm-node-type parent)) + (let ((shm/raise-code (shm-kill-node 'buffer-substring-no-properties nil nil t))) + (shm-kill-node 'buffer-substring-no-properties parent) + (shm-insert-indented (lambda () (insert shm/raise-code))) + (shm/reparse))) + (error "No matching parent!")))) + +(defun shm-get-qop-string (node) + "Get the string of the operator, if the node is an operator." + (when (string= (shm-node-type-name node) "QOp") + (buffer-substring-no-properties (shm-node-start node) + (shm-node-end node)))) + +(provide 'shm-transform) diff --git a/elisp/shm-types.el b/elisp/shm-types.el new file mode 100644 --- /dev/null +++ b/elisp/shm-types.el @@ -0,0 +1,90 @@ +;;; shm-types.el --- Type info/type-directed things + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + + +;; Requirements + +(require 'shm-customizations) + +(defun shm-present-type-info (node info) + "Present type info to the user." + (let ((info. (concat (shm-kill-node 'buffer-substring-no-properties node nil t) + " :: " + info))) + (if shm-use-presentation-mode + (if (fboundp 'haskell-present) + (haskell-present "SHM-Node" + nil + info.) + (message "%s" info)) + (message "%s" info)))) + +(defun shm-node-type-info (node) + "Get the type of the given node." + (shm-type-of-region (shm-node-start node) + (shm-node-end node))) + +(defun shm-type-of-region (beg end) + "Get a type for the region." + (let ((types (shm-types-at-point beg))) + (loop for type + in types + do (when (and (= (elt type 0) beg) + (= (elt type 1) + end)) + (return (elt type 2)))))) + +(defun shm-types-at-point (point) + "Get a list of spans and types for the current point." + (save-excursion + (goto-char point) + (let ((line (line-number-at-pos)) + (col (1+ (current-column))) + (file-name (buffer-file-name))) + (cond + (shm-use-hdevtools + (shm-parse-hdevtools-type-info + (with-temp-buffer + (call-process "hdevtools" nil t nil "type" "-g" "-fdefer-type-errors" + file-name + (number-to-string line) + (number-to-string col)) + (buffer-string)))))))) + +(defun shm-parse-hdevtools-type-info (string) + "Parse type information from the output of hdevtools." + (let ((lines (split-string string "\n+"))) + (loop for line + in lines + while (string-match "\\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\) \"\\(.+\\)\"$" + line) + do (goto-char (point-min)) + collect + (let ((start-line (string-to-number (match-string 1 line))) + (end-line (string-to-number (match-string 3 line)))) + (vector (progn (forward-line (1- start-line)) + (+ (line-beginning-position) + (1- (string-to-number (match-string 2 line))))) + (progn (when (/= start-line end-line) + (forward-line (1- (- start-line end-line)))) + (+ (line-beginning-position) + (1- (string-to-number (match-string 4 line))))) + (match-string 5 line)))))) + +(provide 'shm-types) diff --git a/elisp/shm-yank-kill.el b/elisp/shm-yank-kill.el new file mode 100644 --- /dev/null +++ b/elisp/shm-yank-kill.el @@ -0,0 +1,230 @@ +;;; shm-yank-kill.el --- Killing and yanking operations + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + + +;; Requirements + +(require 'shm-macros) + +(defun shm/kill-region (beg end) + "Kill the region, and save it in the clipboard." + (interactive "r") + (shm-kill-region nil beg end nil)) + +(defun shm/copy-region (beg end) + "Copy the region, and save it in the clipboard." + (interactive "r") + (save-excursion + (shm-kill-region 'clipboard-kill-ring-save beg end t))) + +(defun shm/kill-line () + "Kill everything possible to kill after point before the end of +the line. + +Successive kills will also work, for example: + +do |foo + bar + mu + +Hitting C-k C-k C-k here will killall three lines, and then C-y +will insert them back verbatim." + (interactive) + (shm-with-fallback + kill-line + (shm/reparse) + (cond + ((looking-at "^[ ]+$") + (delete-region (point) (line-end-position))) + ((= (line-end-position) (line-beginning-position)) + (delete-char -1) + (forward-char 1)) + ((and (shm-in-string) + (not (= (point) + (shm-node-start (shm-current-node))))) + (let ((current (shm-current-node))) + (if (and (> (shm-node-end current) + (line-end-position)) + (save-excursion (goto-char (line-end-position)) + (looking-back "\\\\"))) + (kill-region (point) (1- (line-end-position))) + (kill-region (point) + (1- (shm-node-end current)))))) + ((and (= (point) (line-end-position)) + (not (looking-at "\n[^ ]"))) + (let ((column (current-column))) + (delete-region (point) + (save-excursion (forward-line 1) + (goto-char (+ (line-beginning-position) + column)))) + (shm-kill-to-end-of-line t))) + ((shm-current-node) (shm-kill-to-end-of-line)) + (t (kill-line))))) + +(defun shm/kill-node () + "Kill the current node." + (interactive) + (shm-kill-node)) + +(defun shm/yank () + "Yank from the kill ring and insert indented with `shm-insert-indented'." + (interactive) + (shm-with-fallback + yank + ;; This avoids merging two identifiers together accidentally. + (unless (or (shm-in-comment) + (shm-in-string)) + (when (looking-back "[a-zA-Z0-9]+_*") + (shm-insert-string " ")) + (when (looking-at "[a-zA-Z0-9]+_*") + (shm-insert-string " ") + (forward-char -1))) + (shm-insert-indented #'clipboard-yank))) + +(defun shm/yank-pop () + "Yank from the kill ring and insert indented with `shm-insert-indented'." + (interactive) + (shm-with-fallback + 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." + (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))))))))) + +(provide 'shm-yank-kill) diff --git a/elisp/shm.el b/elisp/shm.el --- a/elisp/shm.el +++ b/elisp/shm.el @@ -1,2704 +1,198 @@ -;;; structured-haskell-mode --- Structured editing for Haskell - -;; Copyright (c) 2013 Chris Done. All rights reserved. -;; Copyright (c) 1998 Heribert Schuetz, Graeme E Moss - -;; Author: Chris Done -;; Created: 19-Oct-2013 -;; Version: 1.0.0 -;; Keywords: development, haskell, structured -;; Stability: unstable - -;; This file is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; A minor mode for adding structured editing to Haskell. - -;;; Code: - - -;; Requirements - -(require 'shm-ast-documentation) -(require 'cl) -(require 'evaporate) - - -;; Groups - -(defgroup shm nil - "Structured editing mode for Haskell" - :group 'haskell) - - -;; Mode - -(defvar shm-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) - ;; Indentation - (define-key map (kbd "C-j") 'shm/newline-indent) - (define-key map (kbd "M-)") 'paredit-close-round-and-newline) - (define-key map (kbd "C-c C-^") 'shm/swing-up) - (define-key map (kbd "C-c C-j") 'shm/swing-down) - (define-key map (kbd "TAB") 'shm/tab) - (define-key map (kbd "") 'shm/backtab) - (define-key map (kbd "RET") 'shm/simple-indent-newline-same-col) - (define-key map (kbd "C-") 'shm/simple-indent-newline-indent) - ;; Deletion - (define-key map (kbd "DEL") 'shm/del) - (define-key map (kbd "") 'shm/delete) - (define-key map (kbd "M-^") 'shm/delete-indentation) - (define-key map (kbd "M-DEL") 'shm/backward-kill-word) - (define-key map (kbd "C-") 'shm/backward-kill-word) - ;; 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 "C-M-k") 'shm/kill-node) - (define-key map (kbd "C-y") 'shm/yank) - (define-key map (kbd "M-y") 'shm/yank-pop) - ;; 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 "C-c C-w") 'shm/goto-where) - ;; Splitting, slurping, barfing, etc. - (define-key map (kbd "C-+") 'shm/add-operand) - (define-key map (kbd "M-r") 'shm/raise) - 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-lighter " SHM?" - "The lighter for structured Haskell mode.") - -(define-minor-mode structured-haskell-mode - "Structured editing for Haskell." - :lighter shm-lighter - :keymap shm-map - (if structured-haskell-mode - (shm-mode-start) - (shm-mode-stop))) - - -;; Macros - -(defmacro shm-with-fallback (fallback &rest body) - "Perform the given action unless we're in a comment, in which - case run the fallback function insteaad." - `(if (shm-in-comment) - (call-interactively ',fallback) - (if debug-on-error - (progn ,@body) - (condition-case e - (progn ,@body) - (error - (message "(SHM command failed, falling back to %S. Run M-: (setq debug-on-error t) to see the error.)" - ',fallback) - (call-interactively ',fallback)))))) - - -;; Buffer-local variables - -(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 -wasteful and expensive to lookup nodes every time we want a -node. So it's cheaper to have the granularity of lookup start at -the declaration's point and the node's span. - -Second it's better because a module may have unparseable content -in it, but that doesn't mean we don't want structured editing to -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.") - -(defvar shm-current-node-overlay nil - "Overlay to highlight the current node.") - - -;; Globals - -(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-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-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.") - - -;; Customization - -(defcustom shm-auto-insert-skeletons - t - "Auto-insert skeletons for case, if, etc." - :group 'shm - :type 'boolean) - -(defcustom shm-auto-insert-bangs - t - "Auto-insert bangs when inserting :: in record fields." - :group 'shm - :type 'boolean) - -(defcustom shm-skip-applications - t - "Skip successive applications to the top parent. - -So if you have - -foo| bar mu - -And go up a parent, it will go to - -foo bar mu| - -instead of - -foo bar| mu - -I tend to want the former behaviour more often than the latter, -but others may differ." - :group 'shm - :type 'boolean) - -(defcustom shm-program-name - "structured-haskell-mode" - "The path to call for parsing Haskell syntax." - :group 'shm - :type 'string) - -(defcustom shm-indent-spaces - (if (boundp 'haskell-indent-spaces) - haskell-indent-spaces - 2) - "The number of spaces to indent by default." - :group 'shm - :type 'string) - -(defcustom shm-lambda-indent-style - nil - "Specify a particular style for indenting lambdas?" - :group 'shm - :type '(choice (const leftmost-parent) (const nil))) - -(defcustom shm-use-presentation-mode - nil - "Use haskell-presentation-mode?" - :group 'shm - :type 'boolean) - -(defcustom shm-display-quarantine - t - "Display quarantine?" - :group 'shm - :type 'boolean) - -(defcustom shm-use-hdevtools - nil - "Use hdevtools for type information?" - :group 'shm - :type 'boolean) - -(defcustom shm-type-info-fallback-to-ghci - t - "Fallback to GHCi when the type-info backend returns nothing?" - :group 'shm - :type 'boolean) - -(defcustom shm-idle-timeout - 0.2 - "Number of seconds before re-parsing." - :group 'shm - :type 'string) - - -;; Internal mode functions - -(defun shm-mode-start () - "Start the minor mode." - (set (make-local-variable 'shm-decl-asts) - nil) - (set (make-local-variable 'shm-current-node-overlay) - nil) - (add-hook 'post-self-insert-hook 'shm-post-self-insert nil t) - (unless shm-parsing-timer - (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." - ;; Kill the timer. - (cancel-timer shm-parsing-timer) - (setq shm-parsing-timer nil) - ;; Delete all markers. - (mapc (lambda (pair) - (mapc #'shm-node-delete-markers - (cdr pair)) - (set-marker (car pair) nil)) - shm-decl-asts) - ;; Delete all overlays. - (shm-delete-overlays (point-min) (point-max) 'shm-current-overlay) - (shm-delete-overlays (point-min) (point-max) 'shm-quarantine) - ;; Reset variables. - (setq shm-decl-asts nil) - (setq shm-current-node-overlay nil) - (setq shm-last-parse-start 0) - (setq shm-last-parse-end 0) - (setq shm-last-point 0)) - -(defun shm-reparsing-timer () - "Re-parse the tree on the idle timer." - (when structured-haskell-mode - (shm/reparse))) - -(defun shm-indent-spaces () - "Get the number of spaces to indent." - (if (boundp 'haskell-indent-spaces) - haskell-indent-spaces - shm-indent-spaces)) - - -;; 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) - - -;; Public commands - -;;; Generic node operations - -(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/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))) - (call-process-region (car region) - (cdr region) - shm-program-name - nil - "*shm-scratch-test*" - nil - "parse" - "decl") - (switch-to-buffer "*shm-scratch-test*"))) - -(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.")))) - -;;; Insertion - -(defun shm/insert-undefined () - "Insert undefined." - (interactive) - (save-excursion - (let ((point (point))) - (shm-insert-string "undefined") - (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 '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 '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) - (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 "{" "}"))))) - -;;; Indentation - -(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) - (shm-insert-indented - (lambda () - (insert newline-string))))) - ;; Otherwise just do the indent. - (t (shm-newline-indent)))) - -(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 "))))))))) - -;;; Navigation - -(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))))) - -;;; Splitting, slurping, barfing - -(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!")))) - -;;; Killing and yanking - -(defun shm/kill-region (beg end) - "Kill the region, and save it in the clipboard." - (interactive "r") - (shm-kill-region nil beg end nil)) - -(defun shm/kill-line () - "Kill everything possible to kill after point before the end of -the line. - -Successive kills will also work, for example: - -do |foo - bar - mu - -Hitting C-k C-k C-k here will killall three lines, and then C-y -will insert them back verbatim." - (interactive) - (shm-with-fallback - kill-line - (shm/reparse) - (when (looking-at "[ ]+$") - (delete-region (point) (line-end-position))) - (cond - ((and (shm-in-string) - (not (= (point) - (shm-node-start (shm-current-node))))) - (let ((current (shm-current-node))) - (if (and (> (shm-node-end current) - (line-end-position)) - (save-excursion (goto-char (line-end-position)) - (looking-back "\\\\"))) - (kill-region (point) (1- (line-end-position))) - (kill-region (point) - (1- (shm-node-end current)))))) - ((and (= (point) (line-end-position)) - (not (looking-at "\n[^ ]"))) - (let ((column (current-column))) - (delete-region (point) - (save-excursion (forward-line 1) - (goto-char (+ (line-beginning-position) - column)))) - (shm-kill-to-end-of-line t))) - ((shm-current-node) (shm-kill-to-end-of-line)) - (t (kill-line))))) - -(defun shm/kill-node () - "Kill the current node." - (interactive) - (shm-kill-node)) - -(defun shm/yank () - "Yank from the kill ring and insert indented with `shm-insert-indented'." - (interactive) - (shm-with-fallback - yank - ;; This avoids merging two identifiers together accidentally. - (unless (or (shm-in-comment) - (shm-in-string)) - (when (looking-back "[a-zA-Z0-9]+_*") - (shm-insert-string " ")) - (when (looking-at "[a-zA-Z0-9]+_*") - (shm-insert-string " ") - (forward-char -1))) - (shm-insert-indented #'clipboard-yank))) - -(defun shm/yank-pop () - "Yank from the kill ring and insert indented with `shm-insert-indented'." - (interactive) - (shm-with-fallback - 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))) - -;;; Deletion - -(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)) - - -;; Overlays - -(defun shm-delete-overlays (start end type) - "Delete overlays of the given type. This is used for both -current overlay and quarantines." - (mapc (lambda (o) - (when (overlay-get o type) - (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." - (let ((o (make-overlay start end nil nil t))) - (overlay-put o 'shm-current-overlay t) - (overlay-put o 'face 'shm-current-face) - (overlay-put o 'node-pair node-pair) - (overlay-put o 'priority 1) - o)) - -(defun shm-quarantine-overlay (start end) - "Make a quarantine from START to END." - (let ((o (make-overlay start end nil nil t))) - (overlay-put o 'shm-quarantine t) - (overlay-put o 'face 'shm-quarantine-face) - (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))))) - - -;; Indentation - -(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 haskell-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 () - "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." - (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 - ((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))) - - -;; Strings - -(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))) - - -;; Killing - -(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))) - -(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 (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)) - - -;; Templates - -(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) - (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 - (evaporate (point) (+ (point) (length "undefined"))) - (goto-char next-point) - (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 - (evaporate (point) (+ (point) (length "undefined"))) - (search-forward-regexp "_" nil nil 1) - (evaporate (1- (point)) (point)) - (forward-char 4) - (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 - (evaporate (point) (+ (point) (length "undefined"))) - (search-forward-regexp "then ") - (evaporate (point) (+ (point) (length "undefined"))) - (search-forward-regexp "else ") - (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) - (evaporate (point) (+ (point) (length "undefined"))))) - -(defun shm-auto-insert-module () - "Insert template - -module | where" - (insert " where") - (backward-word 1) - (forward-char -1)) - - -;; Type information operations - -(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)))))) - - -;; Internal buffer operations - -(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-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))))))))) - -(defun shm-literal-insertion () - "Should a node have literal insertion?" - (or (shm-in-string) - (shm-in-comment))) - -(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)))) - -(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-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-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-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-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)))))) - - -;; Internal AST information acquisition functions - -(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))))) - -(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 -and instate this one." - (setq shm-decl-asts - (cons - (cons (set-marker (make-marker) point) ast) - (remove-if (lambda (pair) - (when (= (marker-position (car pair)) - point) - (set-marker (car pair) nil) - t)) - shm-decl-asts))) - ast) - -(defun shm-get-decl-ast (start end &optional reparse) - "Get the AST of the declaration starting at POINT." - (let ((pair (car (remove-if-not (lambda (pair) - (= (marker-position (car pair)) - start)) - shm-decl-asts)))) - (if (and (not reparse) - pair) - (cdr pair) - (progn - (when (or (/= start shm-last-parse-start) - (/= 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)))))))) - -(defun shm-delete-markers (decl) - "Delete the markers in DECL." - (mapc #'shm-node-delete-markers - (cdr decl))) - -(defun shm-get-ast (type start end) - "Get the AST for the given region at START and END. Parses with TYPE. - -This currently launches a fresh process and uses this buffer -nonsense, for any parse, which sucks, but is fast enough _right -now_. Later on a possibility to make this much faster is to have -a persistent running parser server and than just send requests to -it, that should bring down the roundtrip time significantly, I'd -imagine." - (let ((message-log-max nil) - (buffer (current-buffer))) - (when (> end (1+ start)) - (with-temp-buffer - (let ((temp-buffer (current-buffer))) - (with-current-buffer buffer - (condition-case e - (call-process-region start - end - shm-program-name - nil - temp-buffer - nil - "parse" - type) - ((file-error) - (error "Unable to find structured-haskell-mode executable! See README for help."))))) - (read (buffer-string)))))) - -(defun shm-check-ast (type start end) - "Check whether the region of TYPE from START to END parses. - -This doesn't generate or return an AST, it just checks whether it -parses." - (let ((message-log-max nil) - (buffer (current-buffer))) - (with-temp-buffer - (let ((temp-buffer (current-buffer))) - (with-current-buffer buffer - (call-process-region start - end - shm-program-name - nil - temp-buffer - nil - "check" - ;; In other words, always parse with - ;; the more generic “decl” when - ;; something starts at column 0, - ;; because HSE distinguishes between a - ;; “declaration” and an import, a - ;; module declaration and a language - ;; pragma. - (if (save-excursion (goto-char start) - (= (point) (line-beginning-position))) - "decl" - type)))) - (string= "" (buffer-string))))) - -(defun shm-get-nodes (ast start end) - "Get the nodes of the given AST. - -We convert all the line-col numbers to Emacs points and then -create markers out of them. We also store the type of the node, -e.g. Exp, and the case of the node, e.g. Lit or Case or Let, -which is helpful for doing node-specific operations like -indentation. - -Any optimizations welcome." - (let* ((start-end (cons start end)) - (start-column (save-excursion (goto-char start) - (current-column)))) - (cond ((vectorp ast) - (save-excursion - (map 'vector - (lambda (node) - (vector - (elt node 0) - (elt node 1) - (progn (goto-char (car start-end)) - (forward-line (1- (elt node 2))) - ;; This trick is to ensure that the first - ;; line's columns are offsetted for - ;; regions that don't start at column - ;; zero. - (goto-char (+ (if (= (elt node 2) 1) - start-column - 0) - (1- (+ (point) (elt node 3))))) - (let ((marker (set-marker (make-marker) (point)))) - ;(set-marker-insertion-type marker t) - marker)) - (progn (goto-char (car start-end)) - (forward-line (1- (elt node 4))) - ;; Same logic as commented above. - (goto-char (+ (if (= (elt node 4) 1) - start-column - 0) - (1- (+ (point) (elt node 5))))) - (let ((marker (set-marker (make-marker) (point)))) - (set-marker-insertion-type marker t) - marker)))) - ast))) - (t nil)))) - - -;; Node accessors - -(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))) - - -;; Provide - -(provide 'shm) - -;;; structured-haskell-mode.el ends here +;;; shm.el --- Structured Haskell Mode + +;; Copyright (c) 2013 Chris Done. All rights reserved. +;; Copyright (c) 1998 Heribert Schuetz, Graeme E Moss + +;; Author: Chris Done +;; Created: 19-Oct-2013 +;; Version: 1.0.0 +;; Keywords: development, haskell, structured +;; Stability: unstable + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; A minor mode for adding structured editing to Haskell. + +;;; Code: + + +;; Requirements + +(require 'shm-ast-documentation) +(require 'shm-evaporate) + +(require 'cl) + + +;; Groups + +(defgroup shm nil + "Structured editing mode for Haskell" + :group 'haskell) + + +;; Mode + +(defvar shm-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) + ;; Indentation + (define-key map (kbd "C-j") 'shm/newline-indent) + (define-key map (kbd "M-)") 'paredit-close-round-and-newline) + (define-key map (kbd "C-c C-^") 'shm/swing-up) + (define-key map (kbd "C-c C-j") 'shm/swing-down) + (define-key map (kbd "TAB") 'shm/tab) + (define-key map (kbd "") 'shm/backtab) + (define-key map (kbd "RET") 'shm/simple-indent-newline-same-col) + (define-key map (kbd "C-") 'shm/simple-indent-newline-indent) + ;; Deletion + (define-key map (kbd "DEL") 'shm/del) + (define-key map (kbd "") 'shm/delete) + (define-key map (kbd "M-^") 'shm/delete-indentation) + (define-key map (kbd "M-DEL") 'shm/backward-kill-word) + (define-key map (kbd "C-") 'shm/backward-kill-word) + ;; 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) + ;; 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 "C-c C-w") 'shm/goto-where) + ;; Splitting, slurping, barfing, etc. + (define-key map (kbd "C-+") 'shm/add-operand) + (define-key map (kbd "M-r") 'shm/raise) + 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.") + +;;;###autoload +(define-minor-mode structured-haskell-mode + "Structured editing for Haskell." + :lighter shm-lighter + :keymap shm-map + (if structured-haskell-mode + (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) + + +;; Internal mode functions + +(defun shm-mode-start () + "Start the minor mode." + (set (make-local-variable 'shm-decl-asts) + nil) + (set (make-local-variable 'shm-current-node-overlay) + nil) + (add-hook 'post-self-insert-hook 'shm-post-self-insert nil t) + (unless shm-parsing-timer + (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." + ;; Kill the timer. + (cancel-timer shm-parsing-timer) + (setq shm-parsing-timer nil) + ;; Delete all markers. + (mapc (lambda (pair) + (mapc #'shm-node-delete-markers + (cdr pair)) + (set-marker (car pair) nil)) + shm-decl-asts) + ;; Delete all overlays. + (shm-delete-overlays (point-min) (point-max) 'shm-current-overlay) + (shm-delete-overlays (point-min) (point-max) 'shm-quarantine) + ;; Reset variables. + (setq shm-decl-asts nil) + (setq shm-current-node-overlay nil) + (setq shm-last-parse-start 0) + (setq shm-last-parse-end 0) + (setq shm-last-point 0)) + +(defun shm-reparsing-timer () + "Re-parse the tree on the idle timer." + (when structured-haskell-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) + + +;; Provide + +(provide 'shm) + +;;; shm.el ends here ;; Local Variables: ;; byte-compile-warnings: (not cl-functions) ;; End: diff --git a/structured-haskell-mode.cabal b/structured-haskell-mode.cabal --- a/structured-haskell-mode.cabal +++ b/structured-haskell-mode.cabal @@ -1,5 +1,5 @@ name: structured-haskell-mode -version: 1.0.1 +version: 1.0.2 synopsis: Structured editing Emacs mode for Haskell description: Structured editing Emacs mode for Haskell. homepage: https://github.com/chrisdone/structured-haskell-mode @@ -11,9 +11,27 @@ category: Development build-type: Simple cabal-version: >=1.8 -data-files: elisp/shm.el elisp/shm-ast-documentation.el - elisp/shm-test.el elisp/shm-tests.el - elisp/evaporate.el +data-files: elisp/shm-ast-documentation.el + elisp/shm-ast.el + elisp/shm-customizations.el + elisp/shm-deletion.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-macros.el + elisp/shm-navigation.el + elisp/shm-nodes.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 executable structured-haskell-mode main-is: Main.hs