blob: fe14ae51fc6179780c4dfcde608cd86444c6d479 [file] [log] [blame]
;;; package --- Summary
;;; Commentary:
;;; Code:
(require 'shm-node)
(require 'shm-refactor)
(require 'shm-lambda)
(require 'popup)
(defconst qualify-import "qualify import")
(defconst raise-child "raise child")
(defconst visit-module-definition "visit module definition")
(defconst hlint-suggestion "hlint suggestion")
(defconst create-top-level-function-from-lambda "create top level function from lambda")
(defconst add-type-constraint "add type constraint")
(if (eq window-system 'x)
(define-key shm-map (kbd "M-<return>") 'shm/present-actions-for-node)
(define-key shm-map (kbd "M-]") 'shm/present-actions-for-node))
(defun shm/collapse-nested-lambda ()
(let* ((current-node (shm-current-node))
(refactors (shm-get-refactors current-node))
(refactor (shm-find-refactor-by-name refactors "collapse nested lambdas")))
(when refactor (shm-invoke-hlint-suggestion refactor))))
(defun shm/present-actions-for-node ()
"Display menu of possible actions for node."
(let* ((pair (shm-current-node-pair))
(current (cdr pair))
(cons (shm-node-cons current))
(refactors (shm-get-refactors current))
(menu nil))
(when (shm-node-lambda-p current)
(add-to-list 'menu (shm-item-for-lambda)))
(when (shm-refactors-available-p refactors)
(setq menu (append menu (shm-items-for-refactors refactors))))
(when (shm-top-level-type-decl-p pair)
(add-to-list 'menu (shm-item-for-top-level-type-decl)))
(when (shm-import-decl-p cons)
(add-to-list 'menu (shm-item-for-import-decl)))
(when (shm-has-parent-with-matching-type-p pair)
(add-to-list 'menu (shm-item-for-child-nodes-with-matching-parent)))
(when (and (shm-module-name-p cons)
(fboundp (quote haskell-mode-tag-find)))
(add-to-list 'menu (shm-item-for-module-name)))
(if menu
(cancel-timer shm-parsing-timer)
(shm-invoke-action-for-menu-item (popup-menu* menu))
(setq shm-parsing-timer
(run-with-idle-timer shm-idle-timeout t 'shm-reparsing-timer)))))))
;; collapse any nested lambdas
;; compare arg list to variables in defintion
;; turn free variables into application
;; insert application surrounded by parens
;; check parent node for redundant parens
(defun shm/move-lambda-to-top-level ()
(let* ((function-name (read-from-minibuffer "function name: "))
(current-node-pair (shm-current-node-pair))
(current-node (cdr current-node-pair))
(free-variables (shm-lambda-free-vars current-node))
(lambda-args (shm-lambda-args current-node))
(lambda-body (shm-query-lambda-body current-node))
(current-top-level-node (cdr (shm-get-parent-top-level-decl current-node-pair)))
(replacement (concat function-name " " free-variables)))
(shm-replace-node-syntax current-node replacement)
(goto-char (shm-node-end current-top-level-node))
(insert ?\n?\n)
(insert function-name " " free-variables
" " lambda-args
" = " lambda-body )
(insert ?\n)))
(defun shm-replace-node-syntax (node replacement-syntax)
(let ((start (shm-node-start node))
(end (shm-node-end node)))
(delete-region start end)
(goto-char start)
(insert replacement-syntax))))
(defun shm-get-lambda-args (node)
(car (shm-split-lambda node)))
(defun shm-get-lambda-body (node)
(cdr (shm-split-lambda node)))
(defun shm-split-lambda (node)
(let ((syntax (shm-concrete-syntax-for-node node)))
(string-match "\\\\\\(.*?\\)->\\(.*\\)" syntax)
(let ((lambda-args (match-string 1 syntax))
(lambda-body (match-string 2 syntax)))
(cons (chomp lambda-args) (chomp lambda-body)))))
(defun shm-items-for-refactors (refactors)
"Create a popup menu items from (REFACTORS)."
(mapcar 'shm-item-for-refactor refactors))
(defun shm-invoke-hlint-suggestion (refactor)
"Replace the current node with the suggestion from the (REFACTOR)."
(let* ((current-node (shm-current-node))
(start (shm-refactor-start current-node refactor))
(end (shm-refactor-end current-node refactor)))
(delete-region start end)
(goto-char start)
(insert (elt refactor 3)))))
(defun shm-start-refactor-line (refactor)
"Get the starting line of (REFACTOR) relative to the context in which it was found."
(elt refactor 4))
(defun shm-item-for-refactor (refactor)
"Create the menu item for a particular (REFACTOR)."
(popup-make-item (concat "⚒ " (refactor-name refactor)) :value (cons hlint-suggestion refactor)))
(defun shm-item-for-import-decl ()
(popup-make-item "✎ qualify import" :value qualify-import))
(defun shm-item-for-child-nodes-with-matching-parent ()
(popup-make-item "⚒ raise" :value raise-child))
(defun shm-item-for-module-name ()
(popup-make-item "✈ visit module" :value visit-module-definition))
(defun shm-item-for-top-level-type-decl ()
(popup-make-item "✎ add type constraint" :value add-type-constraint))
(defun shm-item-for-lambda ()
(popup-make-item (concat "⚒ " "create top-level function from lambda") :value create-top-level-function-from-lambda))
(defun shm-invoke-action-for-menu-item (item-value)
"Invoke function on (ITEM-VALUE) chosen from the context menu."
(cond ((selected-item-value-p item-value qualify-import) (invoke-with-suggestion 'shm/qualify-import))
((selected-item-value-p item-value raise-child) (invoke-with-suggestion 'shm/raise))
((selected-item-value-p item-value visit-module-definition) (invoke-with-suggestion 'haskell-mode-tag-find))
((selected-item-value-p item-value hlint-suggestion) (invoke-with-suggestion 'shm-invoke-hlint-suggestion (cdr item-value)))
((selected-item-value-p item-value create-top-level-function-from-lambda) (invoke-with-suggestion 'shm/move-lambda-to-top-level))
((selected-item-value-p item-value add-type-constraint) (invoke-with-suggestion 'shm/modify-type-constraint))))
(defun selected-item-value-p (value match)
;;Basically check to see if the value selected by the menu matches a given string
"Extract String from (VALUE) and check for string equality against (MATCH)."
(or (and (stringp value) (string= value match))
(and (listp value) (string= (car value) match))))
(defun invoke-with-suggestion (function &optional arg)
"Invoke (FUNCTION) with on (ARG) and show its key binding in mini buffer if it has one."
(if arg (funcall function arg) (funcall function))
(let ((binding (where-is-internal function shm-map t)))
(when binding
(format "You can run the command `%s' with %s"
function (key-description binding))
(sit-for (if (numberp suggest-key-bindings)
(defun chomp (str)
"Chomp leading and tailing whitespace from STR."
(while (string-match "\\`\n+\\|^\\s-+\\|\\s-+$\\|\n+\\'"
(setq str (replace-match "" t t str)))
(provide 'shm-context-menu)
;;; shm-context-menu.el ends here