diff --git a/elisp/shm-case-split.el b/elisp/shm-case-split.el index 15d263e..4641ce6 100644 --- a/elisp/shm-case-split.el +++ b/elisp/shm-case-split.el @@ -226,4 +226,93 @@ White space here is any of: space, tab, emacs newline (line feed, ASCII 10)." (shm-case-split-alts-from-data-decl (haskell-process-get-data-type name))))) +(defun shm/case-split-completing-read (&optional expr-string) + (interactive) + "Using whichever `completing-read' function is available, this +will gather all the data types currently within the current +buffer (and also those given in the imports) that is loaded into +an interactive haskell session and present them in a list (the +manner in which is specified by `completing-read'). Upon +selection of a data type, the corresponding case statement for +that type will be inserted into the buffer. EXPR-STRING will be +used as the variable to match on in the case statement when it is +non-nil." + (let* ((err "Can't work with this type.") + (execute + (condition-case nil + (shm/case-split + (completing-read + "Choose a type: " + (shm-haskell-interactive-get-types)) + expr-string) + (error err)))) + (when execute + (delete-region (point-at-bol) (point-at-eol)) + (delete-char 1) + execute))) + +(defun shm-haskell-interactive-get-types () + "When an interactive-haskell session is currently loaded, +gather all the data types necessarily loaded in the current +session." + (if (haskell-process) + (progn + (require 'rx) + (require 'dash) + (let* ((imports + (save-excursion + (goto-char (point-min)) + (let (collect) + (while (re-search-forward + "^import \\(qualified\\)*\\s-+" nil t) + (setq collect + (cons + (buffer-substring-no-properties + (point) + (skip-chars-forward + (rx (or alphanumeric (any "."))) + (point-at-eol))) + collect))) + collect)))) + (-filter + (lambda (str) (not (string= "" str))) + (split-string + (mapconcat + 'identity + (-filter + (lambda (str) (not (string= "" str))) + (mapcar + (lambda (import) + (let ((reply + (haskell-process-queue-sync-request + (haskell-process) + (concat ":browse " import)))) + (with-temp-buffer + (insert reply) + (keep-lines "^data" (point-min) (point-max)) + (goto-char (point-min)) + (haskell-mode) + (structured-haskell-mode -1) + (while (/= (point) (point-max)) + (delete-char 5) + (forward-sexp 1) + (delete-region (point) (point-at-eol)) + (forward-line 1)) + (fundamental-mode) + (eod-region-remove-properties (point-min) (point-max)) + (buffer-string)))) + (cons "" ;the empty string is necessary + ;so that the current module is + ;searched + (if (member "Prelude" imports) + imports + (cons "Prelude" imports))))) + "") + "\n")))) + (error + "You do not have an interactive haskell session + loaded. Load an interactive haskell process by executing + M-x `haskell-session' or by pressing C-c + C-z (or M-x `haskell-interactive-switch')."))) + (provide 'shm-case-split) diff --git a/elisp/shm-customizations.el b/elisp/shm-customizations.el index bd4198f..f5b13f6 100644 --- a/elisp/shm-customizations.el +++ b/elisp/shm-customizations.el @@ -144,6 +144,78 @@ syntax." :group 'shm :type 'string) +(defcustom shm-skeleton-alist + '(((looking-back "[[ (,]\\\\") + (shm-auto-insert-lambda)) + ((and + (looking-back "[^a-zA-Z0-9_]do") + (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)))))) + (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)) + ((and + (looking-back "[^a-zA-Z0-9_]if") + (shm-nothing-following-p)) + (shm-auto-insert-if)) + ((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)) + ((not + (bound-and-true-p structured-haskell-repl-mode)) + (shm-auto-insert-stmt 'let)))) + ((and + (looking-back "module") + (= + (line-beginning-position) + (- + (point) + 6)) + (looking-at "[ ]*$")) + (shm-auto-insert-module)) + (t + (shm-insert-string " "))) + "Association list of rules of which skeleton to produce based +on what has been typed in the buffer. The key of an element in +the association list is a predicate. The value of an element in +the association list is the action(s) to perform if the +corresponding predicate is satisfied." + :group 'shm + :type '(alist :key-type (list :tag "Complete Predicate Expression" (sexp :tag "Individual Predicate Expression")) + :value-type (list :tag "Complete Action" (sexp :tag "Individual Action")))) + (defcustom shm-indent-point-after-adding-where-clause nil "Whether to indent point to the next line when inseting where clause, e.g. diff --git a/elisp/shm-insert-del.el b/elisp/shm-insert-del.el index fcd69cd..e67e080 100644 --- a/elisp/shm-insert-del.el +++ b/elisp/shm-insert-del.el @@ -22,6 +22,7 @@ (require 'shm-layout) (require 'shm-indent) (require 'shm-languages) +(require 'shm-customizations) (defun shm-post-self-insert () "Self-insertion handler." @@ -62,44 +63,7 @@ (shm-in-string)) (insert " ")) (shm-auto-insert-skeletons - (cond - ((looking-back "[[ (,]\\\\") - (shm-auto-insert-lambda)) - ((and (looking-back "[^a-zA-Z0-9_]do") - (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)))))) - (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)) - ((and (looking-back "[^a-zA-Z0-9_]if") - (shm-nothing-following-p)) - (shm-auto-insert-if)) - ((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)) - ((not (bound-and-true-p structured-haskell-repl-mode)) - (shm-auto-insert-stmt 'let)))) - ((and (looking-back "module") - (= (line-beginning-position) - (- (point) 6)) - (looking-at "[ ]*$")) - (shm-auto-insert-module)) - (t (shm-insert-string " "))) + (shm-cond-wrapper shm-skeleton-alist) ) (t (shm-insert-string " ")))))) diff --git a/elisp/shm-macros.el b/elisp/shm-macros.el index 478ad31..81074cf 100644 --- a/elisp/shm-macros.el +++ b/elisp/shm-macros.el @@ -31,4 +31,7 @@ ',fallback) (call-interactively ',fallback)))))) +(defmacro shm-cond-wrapper (alist) + `(cond ,@(symbol-value alist))) + (provide 'shm-macros) diff --git a/elisp/shm-manipulation.el b/elisp/shm-manipulation.el index a2ac1c8..6be4cb6 100644 --- a/elisp/shm-manipulation.el +++ b/elisp/shm-manipulation.el @@ -564,8 +564,9 @@ data JSValue (funcall bail)))))) (defun shm-add-deriving-clause () - "Add deriving clause to data type declaration. If successful, - the point should be at the beginning of an evaporating undefined." + "Add a deriving clause to the data type declaration. If successful, +the point should be at the beginning of an evaporating undefined." + (interactive) (shm/goto-topmost-parent) (let ((current (shm-current-node))) (cond ((eq (elt current 1) 'DataDecl) @@ -579,4 +580,12 @@ data JSValue (insert ")")))) (t (message "The point is not contained within a data type declaration."))))) +(defun shm/goto-topmost-parent () + "Go to the topmost parent of the current node." + (let ((loc (point))) + (shm/goto-parent) + (while (< (point) loc) + (shm/goto-parent) + (setq loc (point))))) + (provide 'shm-manipulation)