Add shm/goto-topmost-parent

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)

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.

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 " "))))))
 

elisp/shm-macros.el

@@ -31,4 +31,7 @@
                    ',fallback)
           (call-interactively ',fallback))))))
 
+(defmacro shm-cond-wrapper (alist)
+  `(cond ,@(symbol-value alist)))
+
 (provide 'shm-macros)

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)