diff --git a/elisp/shm-ast.el b/elisp/shm-ast.el
--- a/elisp/shm-ast.el
+++ b/elisp/shm-ast.el
@@ -114,11 +114,11 @@
"stmt"
"decl")
start end)))
- (cl-flet ((bail ()
- (when shm-display-quarantine
- (shm-quarantine-overlay start end))
- (setq shm-lighter " SHM!")
- nil))
+ (let ((bail (lambda ()
+ (when shm-display-quarantine
+ (shm-quarantine-overlay start end))
+ (setq shm-lighter " SHM!")
+ nil)))
(if parsed-ast
(progn
(when (bound-and-true-p structured-haskell-repl-mode)
@@ -133,8 +133,8 @@
(shm-delete-overlays (point-min) (point-max) 'shm-quarantine)
(shm/init)
ast)
- (bail))))
- (bail)))))))))
+ (funcall bail))))
+ (funcall bail)))))))))
(defun shm-font-lock-region (start end)
"When in a REPL, we don't typically have font locking, so we
@@ -622,5 +622,9 @@
(let* ((vector (save-excursion (goto-char start)
(shm-decl-ast))))
(elt vector 0)))
+
+(defun shm-current-node-string ()
+ "Get the text of the current shm node"
+ (shm-node-string (shm-current-node)))
(provide 'shm-ast)
diff --git a/elisp/shm-case-split.el b/elisp/shm-case-split.el
--- a/elisp/shm-case-split.el
+++ b/elisp/shm-case-split.el
@@ -23,6 +23,7 @@
;;; Code:
(require 'shm)
+(require 'shm-ast)
(require 'haskell-process)
(defun shm-case-split-insert-pattern (alts)
@@ -56,7 +57,7 @@
(let ((column (current-column)))
(loop for alt in alts
do (progn (when (/= column (current-column))
- (newline)
+ (insert "\n")
(indent-to column))
(insert (car alt))
(loop for i from 1 to (cdr alt)
@@ -144,6 +145,31 @@
;; Backend based on haskell-process.el
+(defun shm-trim-string (string)
+ "Remove white spaces in beginning and ending of STRING.
+White space here is any of: space, tab, emacs newline (line feed, ASCII 10)."
+ (replace-regexp-in-string "\\`[ \t\n]*" "" (replace-regexp-in-string "[ \t\n]*\\'" "" string)))
+
+(defun haskell-process-get-type (expr)
+ "Get the type of the given expression or name."
+ (let ((reply
+ (haskell-process-queue-sync-request (haskell-process)
+ (format ":t %s\n" expr))))
+ (shm-trim-string (car (last (split-string reply " :: "))))))
+
+(defun shm-cleanup-type-string-for-case (s)
+ "Remove constraints and replace polymorphic type variables with
+ () to allow shm/case-split to work in more cases."
+ (let* ((clean-s (car
+ (last
+ (mapcar 'shm-trim-string
+ (split-string s "=>"))))))
+ (if s
+ (let ((case-fold-search nil))
+ (replace-regexp-in-string "\\b[a-z_][A-Za-z_]*\\b" "()" clean-s))
+ s)))
+
+
(defun haskell-process-get-data-type (name)
"Get the data type definition of the given name."
(let ((reply
@@ -151,19 +177,43 @@
(format ":i %s\n" name))))
(car (split-string reply "[\n\t ]+-- Defined "))))
-(defun shm/case-split (name)
- "Do a case split on NAME at point."
+(defun shm/case-split (name &optional expr-string)
+ "Prompt for a type then do a case split based on it."
(interactive (list (read-from-minibuffer "Type: ")))
(save-excursion
- (let ((column (current-column)))
- (insert "case undefined ")
- (shm-evaporate (- (point) (+ 1 (length "undefined")))
- (- (point) 1))
+ (let ((column (current-column))
+ (case-expr (if expr-string
+ expr-string
+ "undefined")))
+ (insert (concat "case " case-expr " "))
+ (if (not expr-string)
+ (shm-evaporate (- (point) (+ 1 (length "undefined")))
+ (- (point) 1)))
(insert "of\n")
(indent-to (+ column 2))
(shm-case-split-insert-alts
(shm-case-split-alts-from-data-decl
(haskell-process-get-data-type name))))))
+
+(defun shm/case-split-shm-node ()
+ "Do a case split based on the current node expression type."
+ (interactive)
+ (let* ((expr (shm-current-node-string))
+ (expr-type (haskell-process-get-type expr))
+ (clean-expr (shm-cleanup-type-string-for-case expr-type)))
+ (if expr-type
+ (progn
+ (shm/kill-node)
+ (shm/case-split clean-expr expr)))))
+
+(defun shm/do-case-split (arg)
+ "Without prefix, calculate type of current node expression and replace it
+ with a case expression based on its type. With prefix, insert a case expression based
+ on the type given at the prompt."
+ (interactive "P")
+ (if arg
+ (call-interactively 'shm/case-split)
+ (call-interactively 'shm/case-split-shm-node)))
(defun shm/expand-pattern (name)
"Expand a pattern match on a data type."
diff --git a/elisp/shm-customizations.el b/elisp/shm-customizations.el
--- a/elisp/shm-customizations.el
+++ b/elisp/shm-customizations.el
@@ -158,7 +158,7 @@
(defcustom shm-pragmas
'("LANGUAGE" "OPTIONS_GHC" "INCLUDE" "DEPRECATED" "WARNING"
"INLINE" "NOINLINE" "INLINABLE" "CONLIKE" "LINE" "RULES"
- "SPECIALIZE" "UNPACK" "SOURCE")
+ "SPECIALIZE" "UNPACK" "SOURCE" "SCC")
"Pragmas supported."
:group 'shm
:type 'list)
diff --git a/elisp/shm-fold.el b/elisp/shm-fold.el
new file mode 100644
--- /dev/null
+++ b/elisp/shm-fold.el
@@ -0,0 +1,70 @@
+;;; shm-fold.el --- Code folding.
+
+;; 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-fold ()
+ "Fold either the region or the node at point."
+ (interactive)
+ (if (region-active-p)
+ (shm-fold-region (region-beginning)
+ (region-end))
+ (let ((current (shm-current-node)))
+ (shm-fold-region (shm-node-start current)
+ (shm-node-end current)))))
+
+(defun shm-fold-toggle-decl ()
+ "Toggle the folding or unfolding of the declaration."
+ (interactive)
+ (let* ((points (shm-decl-points))
+ (o (car (remove-if-not (lambda (o)
+ (overlay-get o 'folded-decl))
+ (overlays-in (car points)
+ (cdr points))))))
+ (if o
+ (delete-overlay o)
+ (shm-fold-decl))))
+
+(defun shm-fold-decl ()
+ "Fold the current declaration."
+ (interactive)
+ (let* ((points (shm-decl-points))
+ (beg (save-excursion (goto-char (car points))
+ (line-end-position)))
+ (end (cdr points)))
+ (when (> end beg)
+ (shm-fold-region beg end 'folded-decl))))
+
+(defun shm-fold-region (beg end &optional prop)
+ "Hide region."
+ (let ((o (make-overlay beg end)))
+ (overlay-put o 'invisible t)
+ (overlay-put o 'intangible t)
+ (overlay-put o 'after-string "...")
+ (overlay-put o 'hide-region t)
+ (overlay-put o prop t)))
+
+(defun shm-fold-region-undo ()
+ "Undo the hidden region at point."
+ (interactive)
+ (mapcar (lambda (o)
+ (when (overlay-get o 'hide-region)
+ (delete-overlay o)))
+ (overlays-in (- (point) 1)
+ (+ (point) 1))))
+
+(provide 'shm-fold)
diff --git a/elisp/shm-indent.el b/elisp/shm-indent.el
--- a/elisp/shm-indent.el
+++ b/elisp/shm-indent.el
@@ -18,6 +18,7 @@
;;; Code:
(require 'shm-layout)
+(require 'shm-simple-indent)
(defun shm/delete-indentation ()
"Send the node up one line."
@@ -143,6 +144,8 @@
with it."
(interactive)
(cond
+ ((not (shm-current-node))
+ (shm/simple-indent))
((and (shm-in-string)
(not (= (shm-node-start (shm-current-node))
(point))))
@@ -243,19 +246,7 @@
(or (eq 'List (shm-node-cons parent))
(eq 'Tuple (shm-node-cons parent))
(eq 'QualStmt (shm-node-cons parent))))
- (let* ((first-item-on-line (save-excursion
- (goto-char (shm-node-start current))
- (search-backward-regexp "[[,][ ]*")
- (= (current-column)
- (shm-node-start-column parent)))))
- (shm-newline)
- (indent-to (shm-node-start-column parent))
- (insert ",")
- (when first-item-on-line
- (insert (make-string (- (shm-node-start-column current)
- (current-column))
- ? )))
- (shm-set-node-overlay parent-pair)))
+ (shm-newline-indent-listish current parent parent-pair))
;; Lambdas indents k spaces inwards
((eq 'Lambda (shm-node-cons current))
(shm-newline)
@@ -274,7 +265,8 @@
;; Indentation for function application.
((and parent
(or (eq 'App (shm-node-cons parent))
- (eq 'TyApp (shm-node-cons parent))))
+ (eq 'TyApp (shm-node-cons parent))
+ (eq 'ConDecl (shm-node-cons parent))))
(let ((column
(save-excursion
(if (/= (shm-node-start-line current)
@@ -385,48 +377,14 @@
(let ((alt (cdr (shm-node-parent parent-pair))))
(indent-to (+ (shm-node-start-column alt)
(shm-indent-spaces)))))
- ;; Copy infix operators similar to making new list/tuple
- ;; separators
- ((and parent
- (eq 'InfixApp (shm-node-cons parent)))
- (let* ((operand-pair (shm-node-previous current-pair))
- (operand (cdr operand-pair))
- (string (buffer-substring-no-properties (shm-node-start operand)
- (shm-node-end operand))))
- (cond
- (dragging
- (shm-newline)
- (indent-to (shm-node-start-column parent)))
- ((save-excursion (goto-char (shm-node-end operand))
- (= (point) (line-end-position)))
- (insert " " string)
- (shm-newline)
- (indent-to (shm-node-start-column current)))
- (t
- (shm-newline)
- (indent-to (shm-node-start-column operand))
- (insert string " ")))))
;; Infix operators
((and parent
(eq 'InfixApp (shm-node-cons parent)))
(shm-newline)
(indent-to (+ (shm-node-start-column parent))))
- ;; ((eq 'Alt (shm-node-cons current))
- ;; (shm-newline)
- ;; (indent-to (shm-node-start-column current))
- ;; (when shm-auto-insert-skeletons
- ;; (save-excursion (insert "_ -> undefined"))
- ;; (shm-evaporate (point) (+ (point) 1))
- ;; (shm-evaporate (+ (point) (length "_ -> "))
- ;; (+ (point) (length "_ -> undefined")))))
- ;; Commenting out this behaviour for now
- ;; ((string= "Match" (shm-node-type-name current))
- ;; (let ((name (cdr (shm-node-child-pair current-pair))))
- ;; (shm-newline)
- ;; (indent-to (shm-node-start-column current))
- ;; (insert (buffer-substring-no-properties (shm-node-start name)
- ;; (shm-node-end name))
- ;; " ")))
+ ((and parent
+ (eq 'Paren (shm-node-cons parent)))
+ (shm-newline-indent-listish current parent parent-pair))
;; 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.
@@ -434,6 +392,77 @@
(shm-newline)
(indent-to (shm-node-start-column current))))))
+(defun shm-newline-indent-listish (current parent parent-pair)
+ "Indent and insert a comma for a list-ish syntactical node."
+ (let* ((first-item-on-line (and (not (looking-at ","))
+ (save-excursion
+ (goto-char (shm-node-start current))
+ (search-backward-regexp "[[,][ ]*")
+ (= (current-column)
+ (shm-node-start-column parent)))))
+ (go-back (and first-item-on-line
+ (= (point) (shm-node-start current))))
+ (already-have-comma (looking-back ",")))
+ (shm-newline)
+ (indent-to (shm-node-start-column parent))
+ ;; Don't insert duplicate commas.
+ (unless (or (looking-at ",") already-have-comma)
+ (insert ","))
+ (when go-back
+ (let ((column (current-column)))
+ (forward-line -1)
+ (forward-char column)))
+ (when first-item-on-line
+ (insert (make-string (- (shm-node-start-column current)
+ (current-column))
+ ? )))
+ (unless (or (looking-back ",")
+ (looking-at ","))
+ (insert " "))
+ (shm-set-node-overlay parent-pair)))
+
+;; Copy infix operators similar to making new list/tuple
+;; separators
+;; ((and parent
+;; (eq 'InfixApp (shm-node-cons parent)))
+;; (let* ((operand-pair (shm-node-previous current-pair))
+;; (operand (cdr operand-pair))
+;; (string (buffer-substring-no-properties (shm-node-start operand)
+;; (shm-node-end operand))))
+;; (cond
+;; (dragging
+;; (shm-newline)
+;; (indent-to (shm-node-start-column parent)))
+;; ((save-excursion (goto-char (shm-node-end operand))
+;; (= (point) (line-end-position)))
+;; (insert " " string)
+;; (shm-newline)
+;; (indent-to (shm-node-start-column current)))
+;; (t
+;; (shm-newline)
+;; (indent-to (shm-node-start-column operand))
+;; (insert string " ")))))
+
+;; A case for shm-newline-indent which will copy a case-alt. Not
+;; determined how to best include this feature yet.
+;;
+;; ((eq 'Alt (shm-node-cons current))
+;; (shm-newline)
+;; (indent-to (shm-node-start-column current))
+;; (when shm-auto-insert-skeletons
+;; (save-excursion (insert "_ -> undefined"))
+;; (shm-evaporate (point) (+ (point) 1))
+;; (shm-evaporate (+ (point) (length "_ -> "))
+;; (+ (point) (length "_ -> undefined")))))
+;; Commenting out this behaviour for now
+;; ((string= "Match" (shm-node-type-name current))
+;; (let ((name (cdr (shm-node-child-pair current-pair))))
+;; (shm-newline)
+;; (indent-to (shm-node-start-column current))
+;; (insert (buffer-substring-no-properties (shm-node-start name)
+;; (shm-node-end name))
+;; " ")))
+
(defun shm-auto-insert-field-prefix (current parent)
"Auto insert prefixes of fields in record declarations. Example:
@@ -468,5 +497,15 @@
"Normal `newline' does funny business. What we want is to
literally insert a newline and no more."
(insert "\n"))
+
+(defun shm/split-line ()
+ "Split line."
+ (interactive)
+ (if (shm-literal-insertion)
+ (call-interactively 'split-line)
+ (save-excursion
+ (let ((column (current-column)))
+ (insert "\n")
+ (indent-to column)))))
(provide 'shm-indent)
diff --git a/elisp/shm-insert-del.el b/elisp/shm-insert-del.el
--- a/elisp/shm-insert-del.el
+++ b/elisp/shm-insert-del.el
@@ -63,28 +63,32 @@
(shm-auto-insert-skeletons
(cond
((and (looking-back "[^a-zA-Z0-9_]do")
- (or (eolp)
- (looking-at "[])}]")))
+ (shm-nothing-following-p))
(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")
+ (if (bound-and-true-p structured-haskell-repl-mode)
+ (insert " ")
+ (shm-auto-insert-stmt 'qualifier)))
+ ((and (looking-back "[^a-zA-Z0-9_]case")
+ (shm-nothing-following-p))
(shm-auto-insert-case))
- ((looking-back "[^a-zA-Z0-9_]if")
+ ((and (looking-back "[^a-zA-Z0-9_]if")
+ (shm-nothing-following-p))
(shm-auto-insert-if))
- ((looking-back "[^a-zA-Z0-9_]let")
+ ((and (looking-back "[^a-zA-Z0-9_]let")
+ (shm-nothing-following-p))
(cond
((let ((current (shm-current-node)))
(and current
(or (not (or (eq 'Do (shm-node-cons current))
(eq 'BDecls (shm-node-cons current))
(string= "Stmt" (shm-node-type-name current))))
- (bound-and-true-p structured-haskell-repl-mode)))
- (shm-auto-insert-let)))
+ (bound-and-true-p structured-haskell-repl-mode))))
+ (shm-auto-insert-let))
((not (bound-and-true-p structured-haskell-repl-mode))
(shm-auto-insert-stmt 'let))))
((and (looking-back "module")
@@ -95,6 +99,11 @@
(t (shm-insert-string " "))))
(t (shm-insert-string " "))))))
+(defun shm-nothing-following-p ()
+ "Is there nothing following me (other than closing delimiters)?"
+ (or (eolp)
+ (looking-at "[])},;]")))
+
(defun shm/double-quote ()
"Insert double quotes.
@@ -278,6 +287,9 @@
delete-backward-char
(let ((case-fold-search nil))
(cond
+ ((region-active-p)
+ (delete-region (region-beginning)
+ (region-end)))
;; 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
@@ -306,22 +318,19 @@
;; otherwise break everything, so, "if", "of", "case", "do",
;; etc. if deleted.
((and (shm-prevent-parent-deletion-p)
- (looking-back "[^A-Zaz0-9_]do ?")
- (not (or (eolp)
- (looking-at "[])}]"))))
+ (looking-back "[^A-Za-z0-9_']do ?")
+ (shm-nothing-following-p))
nil) ; do nothing
((and (shm-prevent-parent-deletion-p)
(looking-back " <-")
- (not (or (eolp)
- (looking-at "[])}]"))))
+ (shm-nothing-following-p))
(forward-char -3))
((and (shm-prevent-parent-deletion-p)
(looking-back " <- ")
- (not (or (eolp)
- (looking-at "[])}]"))))
+ (shm-nothing-following-p))
(forward-char -4))
((and (shm-prevent-parent-deletion-p)
- (looking-back "[^A-Zaz0-9_]of ?"))
+ (looking-back "[^A-Za-z0-9_]of ?"))
(search-backward-regexp "[ ]*of"))
((and (shm-prevent-parent-deletion-p)
(or (looking-at "of$")
@@ -333,12 +342,12 @@
(looking-at "-> ?"))
(forward-char -1))
((and (shm-prevent-parent-deletion-p)
- (looking-back "[^A-Zaz0-9_]then ?"))
+ (looking-back "[^A-Za-z0-9_]then ?"))
(search-backward-regexp "[^ ][ ]*then")
(unless (or (looking-at "$") (looking-at " "))
(forward-char 1)))
((and (shm-prevent-parent-deletion-p)
- (looking-back "[^A-Zaz0-9_]else ?"))
+ (looking-back "[^A-Za-z0-9_]else ?"))
(search-backward-regexp "[^ ][ ]*else")
(unless (or (looking-at "$") (looking-at " "))
(forward-char 1)))
@@ -347,10 +356,10 @@
(when (looking-at "[ ]*where$")
(delete-region (line-beginning-position) (line-end-position))))
((and (shm-prevent-parent-deletion-p)
- (looking-back "[^A-Zaz0-9_]if ?"))
+ (looking-back "[^A-Za-z0-9_]if ?"))
nil) ; do nothing
((and (shm-prevent-parent-deletion-p)
- (looking-back "[^A-Zaz0-9_]case ?"))
+ (looking-back "[^A-Za-z0-9_]case ?"))
nil) ; do nothing
((and (shm-prevent-parent-deletion-p)
(and (looking-at "= ")
@@ -360,7 +369,7 @@
(or (and (looking-back " = ")
(not (looking-at "$"))
(not (looking-at " ")))
- (and (looking-back "=")
+ (and (looking-back "[\w ]=")
(looking-at " "))))
(search-backward-regexp "[ ]+=[ ]*"
(line-beginning-position)
@@ -522,7 +531,7 @@
(save-excursion (back-to-indentation)
(point))))))
(save-excursion
- (newline)
+ (insert "\n")
(indent-to column)
(insert "undefined")
(forward-word -1)
diff --git a/elisp/shm-layout.el b/elisp/shm-layout.el
--- a/elisp/shm-layout.el
+++ b/elisp/shm-layout.el
@@ -167,18 +167,28 @@
this underside dangling vs not. But that will be implemented as a
separate function rather than hard-coded into this one specific
operation."
- (let ((column (current-column))
- (line (line-beginning-position))
- (start (point)))
- (let ((string
- (with-temp-buffer
- (funcall do-insert)
- (buffer-string))))
- (insert (if (shm-in-string)
- (replace-regexp-in-string
- "\n" "\\\\n\\\\\n\\\\"
- string)
- string)))
+ (let* ((column (current-column))
+ (line (line-beginning-position))
+ (start (point))
+ (string
+ (with-temp-buffer
+ (funcall do-insert)
+ (buffer-string)))
+ (swinging
+ (with-temp-buffer
+ (insert string)
+ (get-text-property (point-min) 'shm-swinging-expr)))
+ (current-node-pair
+ (when swinging
+ (shm-current-node-pair)))
+ (furthest-parent
+ (when current-node-pair
+ (shm-find-furthest-parent-on-line current-node-pair))))
+ (insert (if (shm-in-string)
+ (replace-regexp-in-string
+ "\n" "\\\\n\\\\\n\\\\"
+ string)
+ string))
(when (and (= line (line-beginning-position))
(not no-adjust-dependents))
(shm-adjust-dependents start (- (current-column)
@@ -187,20 +197,14 @@
(goto-char (region-end)))
(let ((end (point)))
(cond
- ((save-excursion (goto-char start)
- (looking-at " "))
- (let ((current-pair (shm-current-node-pair)))
- (when (and current-pair (= (point-max) (point)) current-pair)
- (let ((node (cdr (shm-find-furthest-parent-on-line current-pair))))
- (goto-char end)
- (indent-rigidly start
- end
- (+ (shm-indent-spaces)
- (shm-node-indent-column node)))
- (delete-region start
- (save-excursion
- (goto-char start)
- (search-forward-regexp "[ ]+" (line-end-position) t 1)))))))
+ (swinging
+ (when furthest-parent
+ (let ((node (cdr furthest-parent)))
+ (goto-char end)
+ (indent-rigidly start
+ end
+ (+ (shm-indent-spaces)
+ (shm-node-indent-column node))))))
(t (goto-char end)
(indent-rigidly start end column)))
(push-mark)
@@ -298,6 +302,25 @@
(when (looking-at "^$")
(delete-region (1- (point))
(point)))
+ (when (> (count-lines (point-min)
+ (point-max))
+ 1)
+ (let* ((first-line-col (save-excursion (goto-char (point-min))
+ (back-to-indentation)
+ (current-column)))
+ (second-line-col (save-excursion (goto-char (point-min))
+ (forward-line)
+ (back-to-indentation)
+ (current-column))))
+ (when (> first-line-col second-line-col)
+ (goto-char (point-min))
+ (indent-rigidly (line-beginning-position)
+ (line-end-position)
+ (- first-line-col))
+ (put-text-property (point-min)
+ (point-max)
+ 'shm-swinging-expr
+ t))))
;; Finally, the actual save.
(funcall (if save-it save-it 'clipboard-kill-ring-save)
(point-min)
diff --git a/elisp/shm-manipulation.el b/elisp/shm-manipulation.el
--- a/elisp/shm-manipulation.el
+++ b/elisp/shm-manipulation.el
@@ -70,13 +70,18 @@
(parent (cdr parent-pair))
(actual-parent-pair (shm-node-parent current-pair)))
(cond
+ ((and parent
+ (or (shm-node-app-p current)
+ (eq (shm-node-cons current) 'TyFun))
+ (shm-node-paren-p parent))
+ (let* ((grandparent-pair (shm-node-parent parent-pair (shm-node-type current)))
+ (grandparent (cdr grandparent-pair)))
+ (when grandparent
+ (shm-raise-to current grandparent))))
(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))))
+ (when (string= (shm-node-type current)
+ (shm-node-type parent))
+ (shm-raise-to current parent)))
((and (eq 'UnGuardedRhs (shm-node-cons (cdr actual-parent-pair)))
(eq 'Lambda (shm-node-cons current)))
(goto-char (shm-node-start current))
@@ -91,6 +96,28 @@
(t
(error "No matching parent!")))))
+(defun shm-raise-to (current parent)
+ "Raise the current node and replace PARENT."
+ (let ((shm/raise-code (shm-kill-node 'buffer-substring-no-properties current nil t)))
+ (shm-kill-node 'buffer-substring-no-properties parent)
+ (shm-insert-indented (lambda () (insert shm/raise-code)))
+ (shm/reparse)))
+
+(defun shm/splice ()
+ "Splice the current children wrapped in parens into the parent.
+
+foo (a b c) -> foo a b c
+
+Only parenthesized nodes are supported at the moment."
+ (interactive)
+ (let* ((current-pair (shm-current-node-pair))
+ (current (cdr current-pair))
+ (parent-pair (shm-node-parent current-pair))
+ (parent (cdr parent-pair)))
+ (if (and parent (shm-node-paren-p parent))
+ (shm-raise-to current parent)
+ (message "Unsupported node type for splicing!"))))
+
(defun shm/split-list ()
"Split the current list into two lists by the nearest comma."
(interactive)
@@ -122,9 +149,9 @@
((shm-in-comment)
(save-excursion
(unless (looking-at "{-")
- (search-backward-regexp "{" nil nil 1))
+ (search-backward-regexp "{-" nil nil 1))
(delete-region (point) (+ 2 (point)))
- (search-forward-regexp "}" nil nil 1)
+ (search-forward-regexp "-}" nil nil 1)
(delete-region (- (point) 2) (point))))
(current
(save-excursion
diff --git a/elisp/shm-nav.el b/elisp/shm-nav.el
--- a/elisp/shm-nav.el
+++ b/elisp/shm-nav.el
@@ -61,7 +61,7 @@
(search-forward-regexp "where[ \n]*"))
(t
(unless (= (line-beginning-position) (point))
- (newline))
+ (insert "\n"))
(let ((indent (shm-node-start-column
(cdr (shm-node-parent (cons i rhs))))))
(indent-to (+ 2 indent))
diff --git a/elisp/shm-node.el b/elisp/shm-node.el
--- a/elisp/shm-node.el
+++ b/elisp/shm-node.el
@@ -106,4 +106,10 @@
(eq (shm-node-cons node) 'InfixApp)
(eq (shm-node-cons node) 'TyApp)))
+(defun shm-node-paren-p (node)
+ "Is the given node a paren of some kind?"
+ (or (eq (shm-node-cons node) 'Paren)
+ (eq (shm-node-cons node) 'PParen)
+ (eq (shm-node-cons node) 'TyParen)))
+
(provide 'shm-node)
diff --git a/elisp/shm-simple-indent.el b/elisp/shm-simple-indent.el
--- a/elisp/shm-simple-indent.el
+++ b/elisp/shm-simple-indent.el
@@ -91,10 +91,10 @@
"[^ ]" (line-end-position) t 1))))
(when end (cons start (1- end)))))))
(if start-end
- (progn (newline)
+ (progn (insert "\n")
(insert (buffer-substring-no-properties
(car start-end) (cdr start-end))))
- (newline)))))
+ (insert "\n")))))
(defun shm/simple-indent-newline-indent ()
"Make a newline on the current column and indent on step."
diff --git a/elisp/shm-slot.el b/elisp/shm-slot.el
--- a/elisp/shm-slot.el
+++ b/elisp/shm-slot.el
@@ -60,6 +60,14 @@
(shm-insert-string "undefined")
(shm-evaporate point (point)))))
+(defun shm/insert-underscore ()
+ "Insert underscore."
+ (interactive)
+ (save-excursion
+ (let ((point (point)))
+ (shm-insert-string "_")
+ (shm-evaporate point (point)))))
+
(defun shm-auto-insert-do ()
"Insert template
@@ -76,7 +84,7 @@
(shm/reparse)
(save-excursion
(shm-evaporate (point) (+ (point) (length "undefined")))))
- (t (newline)
+ (t (insert "\n")
(indent-to column)
(let ((next-point (point)))
(insert "undefined")
@@ -154,32 +162,32 @@
let | in {undefined}"
(delete-region (- (point) 3) (point))
;; If needs to be nested this way. Don't change it.
- (cl-flet
- ((evaporate-in ()
- (forward-char 4)
- (save-excursion
- (forward-word)
- (forward-char 1)
- (shm-evaporate (point) (+ (point) (length "undefined"))))))
+ (let
+ ((evaporate-in (lambda ()
+ (forward-char 4)
+ (save-excursion
+ (forward-word)
+ (forward-char 1)
+ (shm-evaporate (point) (+ (point) (length "undefined")))))))
(if (bound-and-true-p structured-haskell-repl-mode)
(let ((points (shm-decl-points)))
(if points
(if (= (point) (car points))
+ (progn (shm-insert-indented
+ (lambda () (insert "let _ = undefined")))
+ (search-forward "_")
+ (shm-evaporate (1- (point)) (point))
+ (forward-word 1)
+ (forward-word -1)
+ (shm-evaporate (point) (+ (point) (length "undefined")))
+ (search-backward "_"))
(progn (shm-insert-indented
- (lambda () (insert "let _ = undefined")))
- (search-forward "_")
- (shm-evaporate (1- (point)) (point))
- (forward-word 1)
- (forward-word -1)
- (shm-evaporate (point) (+ (point) (length "undefined")))
- (search-backward "_"))
- (progn (shm-insert-indented
- (lambda () (insert "let in undefined")))
- (evaporate-in)))
+ (lambda () (insert "let in undefined")))
+ (funcall evaporate-in)))
(insert "let ")))
(progn (shm-insert-indented
(lambda () (insert "let \nin undefined")))
- (evaporate-in))))
+ (funcall evaporate-in))))
(shm/reparse))
(defun shm-auto-insert-module ()
diff --git a/elisp/shm-tests.el b/elisp/shm-tests.el
--- a/elisp/shm-tests.el
+++ b/elisp/shm-tests.el
@@ -23,6 +23,25 @@
(defvar shm-tests-that-dont-run-in-batch-mode
(list
+ (list :name "swinging-expr-yanking"
+ :start-buffer-content "main = do
+ x
+ z
+ y
+
+foo = undefined
+"
+ :start-cursor 8
+ :finish-cursor 17
+ :current-node-overlay '(17 31)
+ :end-buffer-content "main = a
+
+foo = do
+ x
+ z
+ y
+"
+ :kbd [134217739 97 1 14 14 6 6 6 6 6 6 delete 25])
(list :name "yanking"
:start-buffer-content "main = (case undefined of
_ -> undefined
@@ -421,9 +440,18 @@
:start-cursor 37
:finish-cursor 8
:current-node-overlay '(8 11)
- :end-buffer-content "main = foo bar bu
+ :end-buffer-content "main = bar bu
"
:kbd "\341\362\341\362")
+ (list :name "splice"
+ :start-buffer-content "main = foo (bar)
+"
+ :start-cursor 13
+ :finish-cursor 12
+ :current-node-overlay '(12 15)
+ :end-buffer-content "main = foo bar
+"
+ :kbd "\363")
(list :name "kill-line"
:start-buffer-content "main = do foo
bar
diff --git a/elisp/shm.el b/elisp/shm.el
--- a/elisp/shm.el
+++ b/elisp/shm.el
@@ -54,16 +54,18 @@
(define-key map (kbd ":") 'shm/:)
(define-key map (kbd "SPC") 'shm/space)
(define-key map (kbd "C-c C-u") 'shm/insert-undefined)
+ (define-key map (kbd "C-c C-_") 'shm/insert-underscore)
(define-key map (kbd "M-;") 'shm/comment)
(define-key map (kbd "C-c C-e") 'shm/export)
+ (define-key map (kbd "C-M-o") 'shm/split-line)
;; Indentation
- (define-key map (kbd "C-j") 'shm/newline-indent)
+ (define-key map (kbd "C-j") 'shm/newline-indent-proxy)
(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 "RET") 'shm/ret-proxy)
(define-key map (kbd "C-") 'shm/simple-indent-newline-indent)
;; Deletion
(define-key map (kbd "DEL") 'shm/del)
@@ -93,6 +95,7 @@
;; Splitting, slurping, barfing, etc.
(define-key map (kbd "C-+") 'shm/add-operand)
(define-key map (kbd "M-r") 'shm/raise)
+ (define-key map (kbd "M-s") 'shm/splice)
(define-key map (kbd "C-c C-q") 'shm/qualify-import)
map)
"Structural editing operations keymap. Any key bindings in this
@@ -126,6 +129,7 @@
(define-key map (kbd ":") 'shm/:)
(define-key map (kbd "SPC") 'shm/space)
(define-key map (kbd "C-c C-u") 'shm/insert-undefined)
+ (define-key map (kbd "C-c C-_") 'shm/insert-underscore)
(define-key map (kbd "M-;") 'shm/comment)
;; Navigation
(define-key map (kbd "C-M-f") 'shm/forward-node)
@@ -156,6 +160,7 @@
;; Splitting, slurping, barfing, etc.
(define-key map (kbd "C-+") 'shm/add-operand)
(define-key map (kbd "M-r") 'shm/raise)
+ (define-key map (kbd "M-s") 'shm/splice)
(define-key map (kbd "C-c C-q") 'shm/qualify-import)
map)
"Structural editing operations keymap for in the REPL. This
@@ -191,6 +196,8 @@
;; Kill the timer.
(cancel-timer shm-parsing-timer)
(setq shm-parsing-timer nil)
+ ;; Kill self-insert hooks.
+ (remove-hook 'post-self-insert-hook 'shm-post-self-insert t)
;; Delete all markers.
(mapc (lambda (pair)
(mapc #'shm-node-delete-markers
@@ -234,5 +241,21 @@
(shm/simple-indent-backtab))
(t
(shm/jump-to-previous-slot))))
+
+(defun shm/ret-proxy ()
+ "Run `shm/simple-indent-newline-same-col', or in electric mode
+ run `shm/newline-indent' (swaps behaviour)."
+ (interactive)
+ (if (bound-and-true-p electric-indent-mode)
+ (call-interactively 'shm/newline-indent)
+ (call-interactively 'shm/simple-indent-newline-same-col)))
+
+(defun shm/newline-indent-proxy ()
+ "Run `shm/newline-indent', or in electric mode
+ run `simple-indent-newline-same-col' (swaps behaviour)."
+ (interactive)
+ (if (bound-and-true-p electric-indent-mode)
+ (call-interactively 'shm/simple-indent-newline-same-col)
+ (call-interactively 'shm/newline-indent)))
(provide 'shm)
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.3
+version: 1.0.4
synopsis: Structured editing Emacs mode for Haskell
description: Structured editing Emacs mode for Haskell.
homepage: https://github.com/chrisdone/structured-haskell-mode
@@ -11,34 +11,35 @@
category: Development
build-type: Simple
cabal-version: >=1.8
-data-files: elisp/shm-case-split.el
+data-files: elisp/shm-ast-documentation.el
+ elisp/shm-ast.el
+ elisp/shm-case-split.el
elisp/shm-constraint.el
- elisp/shm-yank-kill.el
- elisp/shm-indent.el
- elisp/shm.el
- elisp/shm-debug.el
elisp/shm-customizations.el
- elisp/shm-macros.el
- elisp/shm-layout.el
- elisp/shm-ast.el
- elisp/shm-evaporate.el
- elisp/shm-simple-indent.el
- elisp/shm-type.el
- elisp/shm-node.el
+ elisp/shm-debug.el
elisp/shm-edit-string.el
+ elisp/shm.el
+ elisp/shm-evaporate.el
+ elisp/shm-fold.el
+ elisp/shm-indent.el
elisp/shm-in.el
- elisp/shm-tests.el
- elisp/shm-overlays.el
- elisp/shm-test.el
- elisp/shm-manipulation.el
- elisp/shm-slot.el
elisp/shm-insert-del.el
+ elisp/shm-layout.el
+ elisp/shm-macros.el
+ elisp/shm-manipulation.el
elisp/shm-nav.el
- elisp/shm-ast-documentation.el
+ elisp/shm-node.el
+ elisp/shm-overlays.el
+ elisp/shm-simple-indent.el
+ elisp/shm-slot.el
+ elisp/shm-test.el
+ elisp/shm-tests.el
+ elisp/shm-type.el
+ elisp/shm-yank-kill.el
executable structured-haskell-mode
main-is: Main.hs
ghc-options: -O2 -Wall
hs-source-dirs: src
build-depends: base >= 4 && < 5,
- haskell-src-exts >= 1.14.0
+ haskell-src-exts == 1.15.*