Initial commit.
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..d414f22
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,9 @@
+TAGS
+dist/
+.dir-locals.el
+*.elc
+.cabal-sandbox/
+cabal.sandbox.config
+.cabal
+*.orig
+*~
\ No newline at end of file
diff --git a/.gitmodules b/.gitmodules
new file mode 100644
index 0000000..07d2cca
--- /dev/null
+++ b/.gitmodules
@@ -0,0 +1,3 @@
+[submodule "hlint"]
+ path = src-packages/hlint
+ url = https://github.com/ndmitchell/hlint.git
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/LICENSE
diff --git a/elisp/shm-ast-documentation.el b/elisp/shm-ast-documentation.el
new file mode 100644
index 0000000..c34c30c
--- /dev/null
+++ b/elisp/shm-ast-documentation.el
@@ -0,0 +1,351 @@
+;;; shm-ast-documentation.el --- Documentation of the Haskell AST
+
+;; Copyright (c) 2013, Niklas Broberg, 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Documentation for parts of the AST.
+
+;;; Code:
+
+(defvar shm-ast-documentation
+ '(("Module" "A complete Haskell source module"
+ ("Module" "An ordinary Haskell module"))
+
+ ("ModuleHead" "The head of a module, including the name and export specification")
+
+ ("WarningText" "Warning text to optionally use in the module header of e.g. a deprecated module")
+
+ ("ExportSpecList" "An explicit export specification")
+
+ ("ExportSpec" "An item in a module's export specification"
+ ("EVar" "Variable")
+ ("EAbs" "T: a class or datatype exported abstractly, or a type synonym")
+ ("EThingAll" "T(..): a class exported with all of its methods, or a datatype exported with all of its constructors")
+ ("EThingWith" "T(C_1,...,C_n): a class exported with some of its methods, or a datatype exported with some of its constructors")
+ ("EModuleContents" "module M: re-export a module"))
+
+ ("ImportDecl" "An import declaration")
+
+ ("ImportSpecList" "An explicit import specification list")
+
+ ("ImportSpec" "An import specification, representing a single explicit item imported (or hidden) from a module"
+ ("IVar" "Variable")
+ ("IAbs" "T: the name of a class, datatype or type synonym")
+ ("IThingAll" "T(..): a class imported with all of its methods, or a datatype imported with all of its constructors")
+ ("IThingWith" "T(C_1,...,C_n): a class imported with some of its methods, or a datatype imported with some of its constructors"))
+
+ ("Decl" "A top-level declaration"
+ ("TypeDecl" "A type declaration")
+ ("TypeFamDecl" "A type family declaration")
+ ("DataDecl" "A data OR newtype declaration")
+ ("GDataDecl" "A data OR newtype declaration, GADT style")
+ ("DataFamDecl" "A data family declaration")
+ ("TypeInsDecl" "A type family instance declaration")
+ ("DataInsDecl" "A data family instance declaration")
+ ("GDataInsDecl" "A data family instance declaration, GADT style")
+ ("ClassDecl" "A declaration of a type class")
+ ("InstDecl" "An declaration of a type class instance")
+ ("DerivDecl" "A standalone deriving declaration")
+ ("InfixDecl" "A declaration of operator fixity")
+ ("DefaultDecl" "A declaration of default types")
+ ("SpliceDecl" "Template Haskell splicing declaration")
+ ("TypeSig" "A type signature declaration")
+ ("FunBind" "A set of function binding clauses")
+ ("PatBind" "A pattern binding")
+ ("ForImp" "A foreign import declaration")
+ ("ForExp" "A foreign export declaration")
+ ("RulePragmaDecl" "A RULES pragma")
+ ("DeprPragmaDecl" "A DEPRECATED pragma")
+ ("WarnPragmaDecl" "A WARNING pragma")
+ ("InlineSig" "An INLINE pragma")
+ ("InlineConlikeSig" "An INLINE CONLIKE pragma")
+ ("SpecSig" "A SPECIALISE pragma")
+ ("SpecInlineSig" "A SPECIALISE INLINE pragma")
+ ("InstSig" "A SPECIALISE instance pragma")
+ ("AnnPragma" "An ANN pragma"))
+
+ ("DeclHead" "The head of a type or class declaration")
+
+ ("InstHead" "The head of an instance declaration")
+
+ ("Binds" "A binding group inside a let or where clause"
+ ("BDecls" "An ordinary binding group")
+ ("IPBinds" "A binding group for implicit parameters"))
+
+ ("IPBind" "A binding of an implicit parameter")
+
+ ("ClassDecl" "Declarations inside a class declaration"
+ ("ClsDecl" "Ordinary declaration")
+ ("ClsDataFam" "Declaration of an associated data type")
+ ("ClsTyFam" "Declaration of an associated type synonym")
+ ("ClsTyDef" "Default choice for an associated type synonym"))
+
+ ("InstDecl" "Declarations inside an instance declaration"
+ ("InsDecl" "Ordinary declaration")
+ ("InsType" "An associated type definition")
+ ("InsData" "An associated data type implementation")
+ ("InsGData" "An associated data type implemented using GADT style"))
+
+ ("Deriving" "A deriving clause following a data type declaration")
+
+ ("ConDecl" "Declaration of an ordinary data constructor"
+ ("ConDecl" "Ordinary data constructor")
+ ("InfixConDecl" "Infix data constructor")
+ ("RecDecl" "Record constructor"))
+
+ ("FieldDecl" "Declaration of a (list of) named field(s)")
+
+ ("QualConDecl" "A single constructor declaration within a data type declaration, which may have an existential quantification binding")
+
+ ("GadtDecl" "A single constructor declaration in a GADT data type declaration")
+
+ ("BangType" "The type of a constructor argument or field, optionally including a strictness annotation"
+ ("BangedTy" "Strict component, marked with \"!\"")
+ ("UnBangedTy" "Non-strict component")
+ ("UnpackedTy" "Unboxed component, marked with an UNPACK pragma"))
+
+ ("Match" "Clauses of a function binding"
+ ("Match" "A clause defined with prefix notation, i.e. the function name followed by its argument patterns, the right-hand side and an optional where clause")
+ ("InfixMatch" "A clause defined with infix notation, i.e. first its first argument pattern, then the function name, then its following argument(s), the right-hand side and an optional where clause. Note that there can be more than two arguments to a function declared infix, hence the list of pattern arguments"))
+
+ ("Rhs" "The right hand side of a function or pattern binding"
+ ("UnGuardedRhs" "Unguarded right hand side (exp)")
+ ("GuardedRhss" "Guarded right hand side (gdrhs)"))
+
+ ("GuardedRhs" "A guarded right hand side | stmts = exp. The guard is a series of statements when using pattern guards, otherwise it will be a single qualifier expression")
+
+ ("Context" "A context is a set of assertions")
+
+ ("FunDep" "A functional dependency, given on the form l1 l2 ... ln -> r2 r3 .. rn")
+
+ ("Asst" "Class assertion. In Haskell 98, the argument would be a tyvar, but this definition allows multiple parameters, and allows them to be types. Also extended with support for implicit parameters and equality constraints"
+ ("ClassA" "Ordinary class assertion")
+ ("InfixA" "Class assertion where the class name is given infix")
+ ("IParam" "Implicit parameter assertion")
+ ("EqualP" "Type equality constraint"))
+
+ ("Type" "A type qualified with a context. An unqualified type has an empty context"
+ ("TyForall" "Qualified type")
+ ("TyFun" "Function type")
+ ("TyTuple" "Tuple type, possibly boxed")
+ ("TyList" "List syntax, e.g. [a], as opposed to [] a")
+ ("TyApp" "Application of a type constructor")
+ ("TyVar" "Type variable")
+ ("TyCon" "Named type or type constructor")
+ ("TyParen" "Type surrounded by parentheses")
+ ("TyInfix" "Infix type constructor")
+ ("TyKind" "Type with explicit kind signature"))
+
+ ("Kind" "An explicit kind annotation"
+ ("KindStar" "* , the kind of types")
+ ("KindBang" "!, the kind of unboxed types")
+ ("KindFn" "->, the kind of a type constructor")
+ ("KindParen" "A parenthesised kind")
+ ("KindVar" "A kind variable (as-of-yet unsupported by compilers)"))
+
+ ("TyVarBind" "A type variable declaration, optionally with an explicit kind annotation"
+ ("KindedVar" "Variable binding with kind annotation")
+ ("UnkindedVar" "Ordinary variable binding"))
+
+ ("Exp" "Haskell expression"
+ ("Var" "Variable")
+ ("IPVar" "Implicit parameter variable")
+ ("Con" "Data constructor")
+ ("Lit" "Literal constant")
+ ("InfixApp" "Infix application")
+ ("App" "Ordinary application")
+ ("NegApp" "Negation expression -exp (unary minus)")
+ ("Lambda" "Lambda expression")
+ ("Let" "Local declarations with let ... in .")
+ ("If" "if exp then exp else exp")
+ ("Case" "case exp of alts")
+ ("Do" "do-expression: the last statement in the list should be an expression")
+ ("MDo" "mdo-expression")
+ ("Tuple" "Tuple expression")
+ ("TupleSection" "Tuple section expression, e.g. (,,3)")
+ ("List" "List expression")
+ ("Paren" "Parenthesised expression")
+ ("LeftSection" "Left section (exp qop)")
+ ("RightSection" "Right section (qop exp)")
+ ("RecConstr" "Record construction expression")
+ ("RecUpdate" "Record update expression")
+ ("EnumFrom" "Unbounded arithmetic sequence, incrementing by 1: [from ..]")
+ ("EnumFromTo" "Bounded arithmetic sequence, incrementing by 1 [from .. to]")
+ ("EnumFromThen" "Unbounded arithmetic sequence, with first two elements given [from, then ..]")
+ ("EnumFromThenTo" "Bounded arithmetic sequence, with first two elements given [from, then .. to]")
+ ("ListComp" "Ordinary list comprehension")
+ ("ParComp" "Parallel list comprehension")
+ ("ExpTypeSig" "Expression with explicit type signature")
+ ("VarQuote" "'x for template haskell reifying of expressions")
+ ("TypQuote" "''T for template haskell reifying of types")
+ ("BracketExp" "Template haskell bracket expression")
+ ("SpliceExp" "Template haskell splice expression")
+ ("QuasiQuote" "Quasi-quotaion: [$name| string |]")
+ ("XTag" "Xml element, with attributes and children")
+ ("XETag" "Empty xml element, with attributes")
+ ("XPcdata" "PCDATA child element")
+ ("XExpTag" "Escaped haskell expression inside xml")
+ ("XChildTag" "Children of an xml element")
+ ("CorePragma" "CORE pragma")
+ ("SCCPragma" "SCC pragma")
+ ("GenPragma" "GENERATED pragma")
+ ("Proc" "Arrows proc: proc pat -> exp")
+ ("LeftArrApp" "Arrow application (from left): exp -< exp")
+ ("RightArrApp" "Arrow application (from right): exp >- exp")
+ ("LeftArrHighApp" "Higher-order arrow application (from left): exp -<< exp")
+ ("RightArrHighApp" "Higher-order arrow application (from right): exp >>- exp"))
+
+ ("Stmt" "A statement, representing both a stmt in a do-expression, an ordinary qual in a list comprehension, as well as a stmt in a pattern guard"
+ ("Generator" "A generator: pat <- exp")
+ ("Qualifier" "An exp by itself: in a do-expression, an action whose result is discarded; in a list comprehension and pattern guard, a guard expression")
+ ("LetStmt" "Local bindings")
+ ("RecStmt" "A recursive binding group for arrows"))
+
+ ("QualStmt" "A general transqual in a list comprehension, which could potentially be a transform of the kind enabled by TransformListComp"
+ ("QualStmt" "An ordinary statement")
+ ("ThenTrans" "then exp")
+ ("ThenBy" "then exp by exp")
+ ("GroupBy" "then group by exp")
+ ("GroupUsing" "then group using exp")
+ ("GroupByUsing" "then group by exp using exp"))
+
+ ("FieldUpdate" "An fbind in a labeled construction or update expression"
+ ("FieldUpdate" "Ordinary label-expresion pair")
+ ("FieldPun" "Record field pun")
+ ("FieldWildcard" "Record field wildcard"))
+
+ ("Alt" "An alt alternative in a case expression")
+
+ ("GuardedAlts" "The right-hand sides of a case alternative, which may be a single right-hand side or a set of guarded ones"
+ ("UnGuardedAlt" "-> exp")
+ ("GuardedAlts" "gdpat"))
+
+ ("GuardedAlt" "A guarded case alternative | stmts -> exp")
+
+ ("Pat" "A pattern, to be matched against a value"
+ ("PVar" "Variable")
+ ("PLit" "Literal constant")
+ ("PNeg" "Negated pattern")
+ ("PNPlusK" "Integer n+k pattern")
+ ("PInfixApp" "Pattern with an infix data constructor")
+ ("PApp" "Data constructor and argument patterns")
+ ("PTuple" "Tuple pattern")
+ ("PList" "List pattern")
+ ("PParen" "Parenthesized pattern")
+ ("PRec" "Labelled pattern, record style")
+ ("PAsPat" "@-pattern")
+ ("PWildCard" "Wildcard pattern: _")
+ ("PIrrPat" "Irrefutable pattern: ~pat")
+ ("PatTypeSig" "Pattern with type signature")
+ ("PViewPat" "View patterns of the form (exp -> pat)")
+ ("PRPat" "Regular list pattern")
+ ("PXTag" "XML element pattern")
+ ("PXETag" "XML singleton element pattern")
+ ("PXPcdata" "XML PCDATA pattern")
+ ("PXPatTag" "XML embedded pattern")
+ ("PXRPats" "XML regular list pattern")
+ ("PExplTypeArg" "Explicit generics style type argument e.g. f {| Int |} x = .")
+ ("PQuasiQuote" "String quasi quote pattern: [$name| string |]")
+ ("PBangPat" "Strict (bang) pattern: f !x = .."))
+
+ ("PatField" "An fpat in a labeled record pattern"
+ ("PFieldPat" "Ordinary label-pattern pair")
+ ("PFieldPun" "Record field pun")
+ ("PFieldWildcard" "Record field wildcard"))
+
+ ("Literal" "Literal Values of this type hold the abstract value of the literal, along with the precise string representation used. For example, 10, 0o12 and 0xa have the same value representation, but each carry a different string representation"
+ ("Char" "Character literal")
+ ("String" "String literal")
+ ("Int" "Integer literal")
+ ("Frac" "Floating point literal")
+ ("PrimInt" "Unboxed integer literal")
+ ("PrimWord" "Unboxed word literal")
+ ("PrimFloat" "Unboxed float literal")
+ ("PrimDouble" "Unboxed double literal")
+ ("PrimChar" "Character literal")
+ ("PrimString" "String literal"))
+
+ ("ModuleName" "The name of a Haskell module")
+
+ ("QName" "This type is used to represent qualified variables, and also qualified constructors"
+ ("Qual" "Name qualified with a module name")
+ ("UnQual" "Unqualified local name")
+ ("Special" "Built-in constructor with special syntax"))
+
+ ("Name" "This type is used to represent variables, and also constructors"
+ ("Ident" "varid or conid")
+ ("Symbol" "varsym or consym"))
+
+ ("QOp" "Possibly qualified infix operators (qop), appearing in expressions"
+ ("QVarOp" "Variable operator (qvarop)")
+ ("QConOp" "Constructor operator (qconop)"))
+
+ ("Op" "Operators appearing in infix declarations are never qualified"
+ ("VarOp" "Variable operator (varop)")
+ ("ConOp" "Constructor operator (conop)"))
+
+ ("SpecialCon" "Constructors with special syntax. These names are never qualified, and always refer to builtin type or data constructors"
+ ("UnitCon" "Unit type and data constructor ()")
+ ("ListCon" "List type constructor []")
+ ("FunCon" "Function type constructor ->")
+ ("TupleCon" "N-ary tuple type and data constructors (,) etc, possibly boxed (#,#)")
+ ("Cons" "Data constructor (:)")
+ ("UnboxedSingleCon" "Unboxed singleton tuple constructor (# #)"))
+
+ ("CName" "A name (cname) of a component of a class or data type in an import or export specification"
+ ("VarName" "Name of a method or field")
+ ("ConName" "Name of a data constructor"))
+
+ ("IPName" "An implicit parameter name"
+ ("IPDup" "?ident, non-linear implicit parameter")
+ ("IPLin" "%ident, linear implicit parameter"))
+
+ ("Bracket" "A template haskell bracket expression"
+ ("ExpBracket" "Expression bracket: [| ... |]")
+ ("PatBracket" "Pattern bracket: [p| ... |]")
+ ("TypeBracket" "Type bracket: [t| ... |]")
+ ("DeclBracket" "Declaration bracket: [d| ... |]"))
+
+ ("Splice" "A template haskell splice expression"
+ ("IdSplice" "Variable splice: $var")
+ ("ParenSplice" "Parenthesised expression splice: $(exp)"))
+
+ ("Safety" "The safety of a foreign function call"
+ ("PlayRisky" "Unsafe")
+ ("PlaySafe" "Safe (False) or threadsafe (True)")
+ ("PlayInterruptible" "Interruptible"))
+
+ ("CallConv" "The calling convention of a foreign function call")
+
+ ("ModulePragma" "A top level options pragma, preceding the module header"
+ ("LanguagePragma" "LANGUAGE pragma")
+ ("OptionsPragma" "OPTIONS pragma, possibly qualified with a tool, e.g. OPTIONS_GHC")
+ ("AnnModulePragma" "ANN pragma with module scope"))
+
+ ("Rule" "The body of a RULES pragma")
+ ("RuleVar" "Variables used in a RULES pragma, optionally annotated with types")
+ ("Activation" "Activation clause of a RULES pragma")
+
+ ("Annotation" "An annotation through an ANN pragma"
+ ("Ann" "An annotation for a declared name")
+ ("TypeAnn" "An annotation for a declared type")
+ ("ModuleAnn" "An annotation for the defining module")))
+ "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-context-menu.el b/elisp/shm-context-menu.el
new file mode 100644
index 0000000..b465fa5
--- /dev/null
+++ b/elisp/shm-context-menu.el
@@ -0,0 +1,171 @@
+;;; 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")
+
+(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."
+ (interactive)
+ (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
+ (progn
+ (cancel-timer shm-parsing-timer)
+ (unwind-protect
+ (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)))
+ (save-excursion
+ (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)))
+ (save-excursion
+ (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
+ (with-temp-message
+ (format "You can run the command `%s' with %s"
+ function (key-description binding))
+ (sit-for (if (numberp suggest-key-bindings)
+ suggest-key-bindings
+ 2))))))
+
+(defun chomp (str)
+ "Chomp leading and tailing whitespace from STR."
+ (while (string-match "\\`\n+\\|^\\s-+\\|\\s-+$\\|\n+\\'"
+ str)
+ (setq str (replace-match "" t t str)))
+ str)
+
+(provide 'shm-context-menu)
+
+;;; shm-context-menu.el ends here
diff --git a/elisp/shm-context-menu.el~ b/elisp/shm-context-menu.el~
new file mode 100644
index 0000000..fe14ae5
--- /dev/null
+++ b/elisp/shm-context-menu.el~
@@ -0,0 +1,175 @@
+;;; 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."
+ (interactive)
+ (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
+ (progn
+ (cancel-timer shm-parsing-timer)
+ (unwind-protect
+ (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)))
+ (save-excursion
+ (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)))
+ (save-excursion
+ (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
+ (with-temp-message
+ (format "You can run the command `%s' with %s"
+ function (key-description binding))
+ (sit-for (if (numberp suggest-key-bindings)
+ suggest-key-bindings
+ 2))))))
+
+(defun chomp (str)
+ "Chomp leading and tailing whitespace from STR."
+ (while (string-match "\\`\n+\\|^\\s-+\\|\\s-+$\\|\n+\\'"
+ str)
+ (setq str (replace-match "" t t str)))
+ str)
+
+(provide 'shm-context-menu)
+
+;;; shm-context-menu.el ends here
diff --git a/elisp/shm-customizations.el b/elisp/shm-customizations.el
new file mode 100644
index 0000000..73adc36
--- /dev/null
+++ b/elisp/shm-customizations.el
@@ -0,0 +1,137 @@
+;;; shm-customizations.el --- 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 <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+
+;; Group
+
+(defgroup shm nil
+ "Structured editing mode for Haskell"
+ :group 'haskell)
+
+
+;; 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)
+
+
+;; Customizations
+
+(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-packages-config-directory nil
+ "The package configuration to use"
+ :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
+
+(provide 'shm-customizations)
+
+;;; shm.el ends here
+;; End:
diff --git a/elisp/shm-evaporate.el b/elisp/shm-evaporate.el
new file mode 100644
index 0000000..e462feb
--- /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 <http://www.gnu.org/licenses/>.
+
+;;; 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-lambda.el b/elisp/shm-lambda.el
new file mode 100644
index 0000000..c27cc3f
--- /dev/null
+++ b/elisp/shm-lambda.el
@@ -0,0 +1,25 @@
+;;; package --- Summary
+
+;;; Commentary:
+
+;;; Code:
+(require 'shm-node)
+(require 'shm-query)
+
+(shm-query shm-query-lambda-args "lambdaArgs")
+(shm-query shm-query-lambda-body "lambdaBody")
+(shm-query shm-query-lambda-free-vars "freeVariables")
+
+(defun shm-lambda-args (node)
+ (vector-to-string (shm-query-lambda-args node)))
+
+(defun shm-lambda-free-vars (node)
+ (vector-to-string (shm-query-lambda-free-vars
+ node
+ (buffer-file-name (current-buffer)))))
+
+(defun vector-to-string (vec)
+ (mapconcat 'identity vec " "))
+
+(provide 'shm-lambda)
+
diff --git a/elisp/shm-node.el b/elisp/shm-node.el
new file mode 100644
index 0000000..72e6ad2
--- /dev/null
+++ b/elisp/shm-node.el
@@ -0,0 +1,298 @@
+;;; shm.el --- Structured Haskell Mode
+
+;; Copyright (c) 2013 Chris Done. All rights reserved.
+;; Copyright (c) 1998 Heribert Schuetz, Graeme E Moss
+
+;; Author: Chris Done <chrisdone@gmail.com>
+;; Created: 19-Oct-2013
+;; Version: 1.0.2
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; A minor mode for adding structured editing to Haskell.
+
+;;; Code:
+
+(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-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-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-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-node-lambda-p (node)
+ (string= (shm-node-cons node) "Lambda"))
+
+(defun shm-import-decl-p (node-cons)
+ (string= "ImportDecl" node-cons))
+
+(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-start-column (n)
+ "Get the starting column of N."
+ (save-excursion (goto-char (shm-node-start n))
+ (current-column)))
+
+(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-has-parent-with-matching-type-p (node-pair)
+ "Does node have a parent with the same type?"
+ (let* ((current (cdr node-pair))
+ (parent-pair (shm-node-parent node-pair (shm-node-type current)))
+ (parent (cdr parent-pair)))
+ (if parent
+ (if (string= (shm-node-type current)
+ (shm-node-type parent)) t))))
+
+(defun shm-concrete-syntax-for-node (node)
+ "Get the text representing this node."
+ (buffer-substring-no-properties
+ (shm-node-start (shm-current-node))
+ (shm-node-end (shm-current-node))))
+
+(defun shm-node-syntax-contains-regex (regex node)
+ "Check the syntax of a node for an occurrence of pattern."
+ (let ((node-concrete-syntax (shm-concrete-syntax-for-node node)))
+ (string-match-p regex node-concrete-syntax)))
+
+(defun shm-type-signature-with-constraint-p (pair)
+ "Is the node a type signiture with a constraint?"
+ (let ((current-node (cdr pair)))
+ (and (shm-top-level-type-decl-p pair)
+ (shm-node-syntax-contains-regex "=>" current-node))))
+
+(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-top-level-type-decl-p (node-pair)
+ (let ((current-node (cdr node-pair)))
+ (if (and (not (shm-has-parent-with-matching-type-p node-pair))
+ (string= "Type SrcSpanInfo" (shm-node-type current-node))) t)))
+
+(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-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-module-name-p (node-cons)
+ "Is the node a module name"
+ (string= "ModuleName" node-cons))
+
+(defun shm-node-child (node-pair)
+ "Return the immediate child of the given parent."
+ (cdr (shm-node-child-pair node-pair)))
+
+(defun shm-get-parent-top-level-decl (node-pair)
+ (shm-node-parent node-pair "Decl SrcSpanInfo"))
+
+(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-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)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;Specific node type queries
+(defun shm-constraint-has-parens-p (node)
+ (let* ((syntax (shm-concrete-syntax-for-node node))
+ (constraint-syntax (car (split-string syntax "=>"))))
+ (string-match-p ")" constraint-syntax)))
+
+(defun shm-goto-end-of-constraint (node)
+ "Set point to the first white-space character between the end of the type constraint and the '=>'"
+ (goto-char (+ (shm-node-start node)
+ (shm-node-syntax-contains-regex "=>" node)))
+ (re-search-backward "^\\|[^[:space:]]") (goto-char (+ (point) 1)))
+
+(defun add-initial-type-constraint (node)
+ (goto-char (shm-node-start node))
+ (insert " => ") (backward-char 4))
+
+(defun shm-add-additional-type-constraint (node)
+ (if (shm-constraint-has-parens-p node)
+ (progn
+ (shm-goto-end-of-constraint node)
+ (backward-char 1)
+ (insert ", "))
+ (goto-char (shm-node-start node))
+ (insert "(")
+ (shm-goto-end-of-constraint node)
+ (insert ", )")
+ (backward-char 1)))
+
+;;; Code:
+(defun shm-get-refactors (node)
+ "Get a vector of possible refactorings for the (CURRENT-NODE)."
+ (shm-lint-ast "decl"
+ (shm-node-start node)
+ (shm-node-end node)))
+
+(provide 'shm-node)
diff --git a/elisp/shm-query.el b/elisp/shm-query.el
new file mode 100644
index 0000000..2bfdb40
--- /dev/null
+++ b/elisp/shm-query.el
@@ -0,0 +1,40 @@
+;;; package --- Summary
+
+;;; Commentary:
+(require 'shm-node)
+
+(defconst query-program-name "haskell-src-query")
+
+(defun haskell-src-query (query node &optional filePath)
+ (let ((message-log-max nil)
+ (end (shm-node-end node))
+ (start (shm-node-start node))
+ (buffer (current-buffer))
+ (cabal-file (haskell-cabal-find-file))
+ (target (haskell-session-target (haskell-session)))
+ (srcPath (if filePath filePath "")))
+ (when (> end (1+ start))
+ (with-temp-buffer
+ (let ((temp-buffer (current-buffer)))
+ (with-current-buffer buffer
+ (condition-case e
+ (call-process-region start end
+ query-program-name
+ nil
+ temp-buffer
+ nil
+ query
+ "Emacs"
+ (format "--source-file=%s" srcPath)
+ (format "--package-conf=%s" shm-packages-config-directory)
+ (format "--cabal-file=%s" cabal-file)
+ (format "--build-target=%s" target))
+ ((file-error)
+ (error "cannot find haskell-src-query executable")))))
+ (read (buffer-string))))))
+
+(defmacro shm-query (name query)
+ `(defun ,name (node &optional filePath)
+ (haskell-src-query ,query node filePath)))
+
+(provide 'shm-query)
diff --git a/elisp/shm-refactor.el b/elisp/shm-refactor.el
new file mode 100644
index 0000000..8b768da
--- /dev/null
+++ b/elisp/shm-refactor.el
@@ -0,0 +1,65 @@
+;;; package --- Summary
+
+;;; Commentary:
+
+;;; Code:
+(require 'shm-node)
+
+(defun shm-find-refactor-by-name (refactors name)
+ (setq refactor nil)
+ (setq num 0)
+ (while (and (< num (length refactors))
+ (not (string= (refactor-name refactor) name)))
+ (setq refactor (elt refactors num))
+ (setq num (1+ num)))
+ (if (string= (refactor-name refactor) name) refactor nil))
+
+
+(defun shm-refactor-start (current-node refactor)
+ "Get the starting position of the (REFACTOR) relative to the currently selected node."
+ (let ((start (shm-node-start current-node))
+ (rsl (shm-start-line-refactor refactor))
+ (rsc (shm-start-column-refactor refactor)))
+ (save-excursion
+ (goto-char start)
+ (when (> rsl 0) (forward-line rsl))
+ (forward-char rsc)
+ (point))))
+
+(defun shm-refactor-end (current-node refactor)
+ "Get the end position of the (REFACTOR) relative to the currently selected node."
+ (let ((start (shm-node-start current-node))
+ (rel (shm-end-line-refactor refactor))
+ (rec (shm-end-column-refactor refactor)))
+ (save-excursion
+ (goto-char start)
+ (when (> rel 0) (forward-line rel))
+ (forward-char rec)
+ (point))))
+
+(defun shm-refactors-available-p (refactors)
+ "Check to see if the (REFACTORS) vector is populated."
+ (if (> (length refactors) 0) t))
+
+(defun refactor-name (refactor)
+ "Get the name of (REFACTOR)."
+ (elt refactor 1))
+
+(defun shm-start-line-refactor (refactor)
+ "Get the starting line of the (REFACTOR) which is relative to the context in which it was found."
+ (- (string-to-number (elt refactor 4)) 1))
+
+(defun shm-start-column-refactor (refactor)
+ "Get the starting column of the (REFACTOR) which is relative to the context in which it was found."
+ (- (string-to-number (elt refactor 5)) 1))
+
+(defun shm-end-line-refactor (refactor)
+ "Get the end line of the (REFACTOR) which is relative to the context in which it was found."
+ (- (string-to-number (elt refactor 6)) 1))
+
+(defun shm-end-column-refactor (refactor)
+ "Get the end column of the (REFACTOR) which is relative to the context in which it was found."
+ (- (string-to-number (elt refactor 7)) 1))
+
+
+(provide 'shm-refactor)
diff --git a/elisp/shm.el b/elisp/shm.el
new file mode 100644
index 0000000..dfb469b
--- /dev/null
+++ b/elisp/shm.el
@@ -0,0 +1,867 @@
+;;; shm.el --- Structured Haskell Mode
+
+;; Copyright (c) 2013 Chris Done. All rights reserved.
+;; Copyright (c) 1998 Heribert Schuetz, Graeme E Moss
+
+;; Author: Chris Done <chrisdone@gmail.com>
+;; Created: 19-Oct-2013
+;; Version: 1.0.2
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; A minor mode for adding structured editing to Haskell.
+
+;;; Code:
+
+(require 'shm-customizations)
+(require 'shm-ast-documentation)
+(require 'shm-evaporate)
+(require 'shm-node)
+(require 'shm-lambda)
+(require 'shm-context-menu)
+
+(require 'cl)
+
+(defvar shm-current-node-overlay nil
+ "Overlay to highlight the current node.")
+
+(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-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.")
+
+(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.")
+
+(defvar shm-map
+ (let ((map (make-sparse-keymap)))
+ ;; Navigation
+ (if (eq window-system 'x)
+ (define-key map (kbd "M-<return>") 'shm/present-actions-for-node)
+ (define-key map (kbd "M-]") 'shm/present-actions-for-node))
+ (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 "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)
+ (define-key map (kbd "C-c C-q") 'shm/qualify-import)
+ (define-key map (kbd "M-p") 'shm/walk)
+ 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)))
+
+(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))))))
+
+(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-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-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"
+ "Emacs")
+ ((file-error)
+ (error "Unable to find structured-haskell-mode executable! See README for help.")))))
+ (read (buffer-string))))))
+
+(defun shm-lint-ast (type start end)
+ "Get refactor suggestions for the region of TYPE from START to END."
+ (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
+ "hlint"
+ "Emacs")
+ ((file-error)
+ (error "Unable to find structured-haskell-mode executable! See README for help.")))))
+ (read (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))))
+
+(defun shm-decl-points (&optional use-line-comments)
+ "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 (not use-line-comments)
+ (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-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/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/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/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."))))
+
+
+(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-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/forward-paragraph ()
+ "Go forward one declaration."
+ (interactive)
+ (unless (/= (point)
+ (goto-char (cdr (shm-decl-points t))))
+ (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 t))))
+ (search-backward-regexp "[^\n ]" nil t 1)
+ (forward-char)))
+
+(defun shm/walk ()
+ (interactive)
+ (shm/reparse)
+ (shm/goto-parent-end))
+
+(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)))))
+
+(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-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-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-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-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 "{-"))))
+ (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-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)))))
+
+(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/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-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))))))
+
+
+(defun shm/qualify-import ()
+ "Toggle the qualification of the import at point."
+ (interactive)
+ (save-excursion
+ (let ((points (shm-decl-points)))
+ (goto-char (car points))
+ (shm/reparse)
+ (let ((current (shm-current-node)))
+ (when (and current
+ (string= "ImportDecl"
+ (shm-node-type-name current)))
+ (cond
+ ((looking-at "import[\n ]+qualified[ \n]+")
+ (search-forward-regexp "qualified" (shm-node-end current) t 1)
+ (delete-region (point)
+ (search-backward-regexp "qualified"))
+ (just-one-space 1))
+ (t
+ (search-forward-regexp "import")
+ (shm-insert-string " qualified")
+ (just-one-space 1))))))))
+
+(defun shm/modify-type-constraint ()
+ "Modify a type signatures constraint"
+ (interactive)
+ (let* ((pair (shm-current-node-pair))
+ (current-node (cdr pair)))
+ (if (shm-type-signature-with-constraint-p pair)
+ (shm-add-additional-type-constraint current-node)
+ (add-initial-type-constraint current-node))))
+
+(provide 'shm)
+
+;;; shm.el ends here
+;; Local Variables:
+;; byte-compile-warnings: (not cl-functions)
+;; End:
diff --git a/haskell-src-query.cabal b/haskell-src-query.cabal
new file mode 100644
index 0000000..1b3719e
--- /dev/null
+++ b/haskell-src-query.cabal
@@ -0,0 +1,25 @@
+name: haskell-src-query
+version: 1.0.0
+synopsis: Useful queries and source transformation suggestions (via hlint) for Haskell
+description: Useful queries and source transformation suggestions (via hlint) for Haskell
+license: BSD3
+license-file: LICENSE
+author: Eric Jones
+maintainer: ecjones2040@gmail.com
+copyright: Eric Jones 2014
+category: Development
+build-type: Simple
+cabal-version: >=1.8
+
+executable haskell-src-query
+ main-is: HSrcQuery.hs
+ ghc-options: -O2 -Wall
+ hs-source-dirs: src
+ build-depends: Cabal >= 1.18.0,
+ hlint >= 1.8.57,
+ process >= 1.1.0.2,
+ base >= 4 && < 5,
+ haskell-src-exts >= 1.14.0,
+ optparse-applicative >= 0.7.0.2,
+ syb >= 0.4.1
+
diff --git a/src-packages/hlint b/src-packages/hlint
new file mode 160000
index 0000000..8360f45
--- /dev/null
+++ b/src-packages/hlint
@@ -0,0 +1 @@
+Subproject commit 8360f4532189589ebfe80d0664a393aad1fbe0ee
diff --git a/src/Cabal.hs b/src/Cabal.hs
new file mode 100644
index 0000000..b7c7e7b
--- /dev/null
+++ b/src/Cabal.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Cabal (buildTargetSrcDirs) where
+
+import Data.List
+import Distribution.Package
+import Distribution.PackageDescription
+import Distribution.PackageDescription.Parse
+import Distribution.Verbosity
+
+type BuildTargetName = String
+type SrcDirs = String
+type Cond a = (BuildTargetName, CondTree ConfVar [Dependency] a)
+
+------------------------------------------------------------------------------
+buildTargetSrcDirs :: FilePath -> BuildTargetName -> IO (Maybe [SrcDirs])
+buildTargetSrcDirs cabalFilePath btn = do
+ gPDesc <- readPackageDescription silent cabalFilePath
+ return $ findSrcDirs gPDesc btn
+
+------------------------------------------------------------------------------
+findSrcDirs :: GenericPackageDescription -> BuildTargetName -> Maybe [SrcDirs]
+findSrcDirs GenericPackageDescription{..} btn =
+ case findTarget btn condExecutables of
+ Just execTarget -> Just . hsSourceDirs . buildInfo $ execTarget
+ Nothing -> case findTarget btn condTestSuites of
+ Just testTarget -> Just . hsSourceDirs . testBuildInfo $ testTarget
+ Nothing -> case findTarget btn condBenchmarks of
+ Just benchmarkTarget -> Just . hsSourceDirs . benchmarkBuildInfo $ benchmarkTarget
+ Nothing -> Nothing
+
+------------------------------------------------------------------------------
+findTarget :: BuildTargetName -> [(Cond a)] -> Maybe a
+findTarget btn targets = do
+ (_, CondNode a _ _ ) <- find isBuildTarget targets
+ return a
+ where
+ isBuildTarget (name, _) = name == btn
diff --git a/src/Client.hs b/src/Client.hs
new file mode 100644
index 0000000..1816141
--- /dev/null
+++ b/src/Client.hs
@@ -0,0 +1,4 @@
+module Client (Client(..)) where
+
+data Client = SublimeText
+ | Emacs
diff --git a/src/HDevTools.hs b/src/HDevTools.hs
new file mode 100644
index 0000000..173f9bc
--- /dev/null
+++ b/src/HDevTools.hs
@@ -0,0 +1,51 @@
+module HDevTools (isInModuleScope) where
+
+import Control.Monad
+import Data.List
+import System.Exit
+import System.Process
+------------------------------------------------------------------------------
+import Cabal
+
+------------------------------------------------------------------------------
+type SymbolName = String
+
+------------------------------------------------------------------------------
+isInModuleScope :: FilePath -> FilePath -> FilePath -> String -> SymbolName -> IO Bool
+isInModuleScope filePath pkgConfigPath cabalFilePath buildTargetName symName = do
+ (exitCode, _, stderr) <- search
+ case exitCode of
+ ExitFailure _ -> return $ "Not in scope" `isInfixOf` stderr
+ _ -> return False
+ where
+ search = do
+ let packageConfigOption = ghcOptionPkgConfig pkgConfigPath
+ maybeOptionSrcDirs <- ghcOptionSrcDirs cabalFilePath buildTargetName
+ case maybeOptionSrcDirs of
+ Just optionSrcDirs -> do
+ let args = ["info", filePath, symName, packageConfigOption] ++ optionSrcDirs
+ readProcessWithExitCode hdevtools args ""
+ Nothing -> readProcessWithExitCode hdevtools ["info", filePath, symName, packageConfigOption] ""
+
+------------------------------------------------------------------------------
+ghcOptionSrcDirs :: String -> String -> IO (Maybe [String])
+ghcOptionSrcDirs cabalFilePath buildTargetName = do
+ maybeSrcDirs <- buildTargetSrcDirs cabalFilePath buildTargetName
+ case maybeSrcDirs of
+ Just srcDirs -> return $ Just $ map ghcOptionSrcDir srcDirs
+ Nothing -> return $ Nothing
+
+
+------------------------------------------------------------------------------
+hdevtools :: String
+hdevtools = "hdevtools"
+
+------------------------------------------------------------------------------
+ghcOptionPkgConfig :: String -> String
+ghcOptionPkgConfig = (++) "-g-package-conf"
+
+------------------------------------------------------------------------------
+ghcOptionSrcDir :: String -> String
+ghcOptionSrcDir = (++) "-g-i"
+
+fn = isInModuleScope "src/HSrcQuery.hs" ".cabal-sandbox/x86_64-linux-ghc-7.6.3-packages.conf.d/" "haskell-src-query.cabal" "haskell-src-query" "runQuery"
diff --git a/src/HLint.hs b/src/HLint.hs
new file mode 100644
index 0000000..5a33c21
--- /dev/null
+++ b/src/HLint.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module HLint (hlint) where
+
+import Control.Applicative
+import Data.Maybe
+import Temporary.API
+import Language.Haskell.Exts.Annotated (SrcSpan(..))
+
+------------------------------------------------------------------------------
+hlint :: String -> IO String
+hlint code = do
+ ideas <- genIdeas code
+ if length ideas > 0
+ then return $ serializeIdeas ideas
+ else return "[]"
+
+------------------------------------------------------------------------------
+genIdeas :: String -> IO [Idea]
+genIdeas code = do
+ (parseFlags, classifications, hint) <- autoSettings
+ eitherErrorModule <- parseModuleEx parseFlags "" (Just code)
+ case eitherErrorModule of
+ Left _ -> error "error parsing code"
+ Right msi -> return $ applyHints classifications hint [msi]
+
+------------------------------------------------------------------------------
+serializeIdeas :: [Idea] -> String
+serializeIdeas ideas = "[" ++ (concat $ serializeIdea <$> ideas) ++ "]"
+
+------------------------------------------------------------------------------
+serializeIdea :: Idea -> String
+serializeIdea idea =
+ case ideaTo idea of
+ Just to -> "[" ++ concat (ideaContent to (ideaSpan idea)) ++ "]"
+ Nothing -> ""
+ where
+ ideaContent to SrcSpan{..} =
+ [ show . show $ ideaSeverity idea
+ , show $ findSuggestion (ideaHint idea)
+ , show $ ideaFrom idea
+ , show to
+ , show . show $ srcSpanStartLine
+ , show . show $ srcSpanStartColumn
+ , show . show $ srcSpanEndLine
+ , show . show $ srcSpanEndColumn
+ ]
+
+------------------------------------------------------------------------------
+findSuggestion :: String -> String
+findSuggestion i = fromMaybe "Error: No suggestion string mapping yet" $
+ lookup i [ ("Redundant lambda", "remove redundant lambda")
+ , ("Avoid lambda", "move lambda to top level")
+ , ("Collapse lambdas", "collapse nested lambdas")
+ , ("Redundant bracket", "remove redundant bracket")
+ ]
diff --git a/src/HSrcQuery.hs b/src/HSrcQuery.hs
new file mode 100644
index 0000000..3a1a381
--- /dev/null
+++ b/src/HSrcQuery.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Main where
+
+import Options.Applicative
+------------------------------------------------------------------------------
+import Client
+import HLint
+import Lambda
+import ParseAST
+
+------------------------------------------------------------------------------
+data Query = FreeVariables
+ | LambdaBody
+ | LambdaArgs
+ | HLint
+ | ParseAST
+ deriving Show
+
+------------------------------------------------------------------------------
+data Request = Request { query :: Query
+ , client :: Client
+ , srcFilePath :: FilePath
+ , pkgConfigDirPath :: FilePath
+ , cabalFilePath :: FilePath
+ , buildTargetName :: String
+ }
+
+------------------------------------------------------------------------------
+requestParser :: Parser Request
+requestParser = Request <$> argument parseQueryArg
+ ( metavar "QUERY"
+ <> help "Query to run on selected code.")
+ <*> argument parseClientArg
+ ( metavar "CLIENT"
+ <> help "Client Emacs or Sublime" )
+ <*> strOption ( long "source-file"
+ <> metavar "FILE"
+ <> help "File containing selected code."
+ <> value "")
+ <*> strOption ( long "package-conf"
+ <> metavar "DIRECTORY"
+ <> help "GHC package config directory."
+ <> value "")
+ <*> strOption ( long "cabal-file"
+ <> metavar "FILE"
+ <> help "Cabal file"
+ <> value "")
+ <*> strOption ( long "build-target"
+ <> metavar "TARGET"
+ <> help "Target of build"
+ <> value "")
+
+
+requestParserInfo :: ParserInfo Request
+requestParserInfo = info (helper <*> requestParser)
+ ( fullDesc
+ <> progDesc "Query infromation about Haskell source."
+ <> header "haskell-src-query - get info about haskell src")
+
+------------------------------------------------------------------------------
+main :: IO ()
+main = do
+ Request{..} <- execParser requestParserInfo
+ code <- getContents
+ putStrLn =<< runQuery query
+ srcFilePath
+ pkgConfigDirPath
+ cabalFilePath
+ buildTargetName
+ client
+ code
+
+------------------------------------------------------------------------------
+parseQueryArg :: String -> Maybe Query
+parseQueryArg s | s == "freeVariables" = Just FreeVariables
+ | s == "lambdaBody" = Just LambdaBody
+ | s == "lambdaArgs" = Just LambdaArgs
+ | s == "hlint" = Just HLint
+ | s == "parse" = Just ParseAST
+ | otherwise = Nothing
+
+------------------------------------------------------------------------------
+parseClientArg :: String -> Maybe Client
+parseClientArg s | s == "SublimeText" = Just SublimeText
+ | s == "Emacs" = Just Emacs
+ | otherwise = Nothing
+
+------------------------------------------------------------------------------
+runQuery
+ :: Query
+ -> FilePath
+ -> FilePath
+ -> FilePath
+ -> String
+ -> Client
+ -> String
+ -> IO String
+runQuery FreeVariables srcFile
+ pkgConfigPath
+ cabalFilePath
+ buildTargetName
+ client
+ code =
+ freeVariables srcFile
+ pkgConfigPath
+ cabalFilePath
+ buildTargetName
+ client
+ code
+runQuery LambdaBody _ _ _ _ _ code = return $ lambdaBody code
+runQuery LambdaArgs _ _ _ _ _ code = return $ lambdaArgs code
+runQuery HLint _ _ _ _ _ code = hlint code
+runQuery ParseAST _ _ _ _ _ code = return $ parseAST code
diff --git a/src/Lambda.hs b/src/Lambda.hs
new file mode 100644
index 0000000..29fce06
--- /dev/null
+++ b/src/Lambda.hs
@@ -0,0 +1,90 @@
+module Lambda ( freeVariables
+ , lambdaArgs
+ , lambdaBody
+ ) where
+
+import Control.Monad
+import Data.Generics.Aliases
+import Data.Generics.Schemes
+import Data.List
+import Language.Haskell.Exts
+------------------------------------------------------------------------------
+import HDevTools
+import Client
+
+------------------------------------------------------------------------------
+freeVariables :: FilePath -> FilePath -> FilePath -> String -> Client -> String -> IO String
+freeVariables srcPath pkgConfigPath cabalFilePath buildTargetName client code = case parseExp code of
+ ParseOk ast -> do
+ names <- dropModuleVariableNames srcPath
+ pkgConfigPath
+ cabalFilePath
+ buildTargetName $ extractFreeVariables ast
+ return . dropCommas $ show names
+ _ -> return "Error parsing freeVars"
+
+------------------------------------------------------------------------------
+lambdaBody :: String -> String
+lambdaBody code = case parseExp code of
+ ParseOk ast -> show . extractLambdaBody $ ast
+ _ -> "[]"
+
+------------------------------------------------------------------------------
+lambdaArgs :: String -> String
+lambdaArgs code = case parseExp code of
+ ParseOk ast -> extractLambdaArgs ast
+ _ -> "[]"
+
+------------------------------------------------------------------------------
+extractLambdaArgs :: Exp -> String
+extractLambdaArgs (Lambda _ ast _) = dropCommas . show $ allNames ast
+extractLambdaArgs _ = "[]"
+
+------------------------------------------------------------------------------
+allVariables :: GenericQ [Exp]
+allVariables = listify isVar
+
+------------------------------------------------------------------------------
+allBindings :: GenericQ [Pat]
+allBindings = listify isBinding
+
+------------------------------------------------------------------------------
+allNames :: GenericQ [String]
+allNames = everything (++) ([] `mkQ` fmap (: []) getStringFromName)
+
+------------------------------------------------------------------------------
+isVar :: Exp -> Bool
+isVar (Var _) = True
+isVar _ = False
+
+------------------------------------------------------------------------------
+isBinding :: Pat -> Bool
+isBinding (PVar _) = True
+isBinding _ = False
+
+------------------------------------------------------------------------------
+getStringFromName :: Name -> String
+getStringFromName (Symbol str) = str
+getStringFromName (Ident str) = str
+
+------------------------------------------------------------------------------
+dropCommas :: String -> String
+dropCommas = filter (/= ',')
+
+------------------------------------------------------------------------------
+extractLambdaBody :: Exp -> String
+extractLambdaBody (Lambda _ _ ast) = prettyPrint ast
+extractLambdaBody _ = "[]"
+
+------------------------------------------------------------------------------
+extractFreeVariables :: GenericQ [String]
+extractFreeVariables ast = allNames (allVariables ast) \\
+ allNames (allBindings ast)
+
+------------------------------------------------------------------------------
+dropModuleVariableNames :: FilePath -> FilePath -> FilePath -> String -> [String] -> IO [String]
+dropModuleVariableNames srcPath pkgConfigPath cabalFilePath buildTargetName =
+ filterM $ (liftM not) . isInModuleScope srcPath
+ pkgConfigPath
+ cabalFilePath
+ buildTargetName
diff --git a/src/ParseAST.hs b/src/ParseAST.hs
new file mode 100644
index 0000000..472f820
--- /dev/null
+++ b/src/ParseAST.hs
@@ -0,0 +1,135 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module ParseAST (parseAST) where
+
+import Control.Applicative
+import Data.Data
+import Data.Maybe
+import Language.Haskell.Exts.Annotated
+
+-----------------------------------------------------------------------------------------
+data D = forall a. Data a => D a
+
+-----------------------------------------------------------------------------------------
+parseAST :: String -> [Char]
+parseAST code = case parseTopLevel parseMode code of
+ ParseOk (D ast) -> ("[" ++ concat (genHSE ast) ++ "]")
+ ParseFailed _ _ -> "[]"
+
+-----------------------------------------------------------------------------------------
+parseTopLevel :: ParseMode -> String -> ParseResult D
+parseTopLevel mode code =
+ D . fix <$> parseDeclWithMode mode code <|>
+ D <$> parseImport mode code <|>
+ D . fix <$> parseModuleWithMode mode code <|>
+ D <$> parseModulePragma mode code
+
+-----------------------------------------------------------------------------------------
+-- | The 'empty' method isn't (shouldn't be) used, so this isn't a
+-- real Alternative instance (perhaps a Semigroup might do?). But it's
+-- handy.
+instance Alternative ParseResult where
+ empty = ParseFailed undefined undefined
+ ParseFailed{} <|> x = x
+ x <|> _ = x
+
+-----------------------------------------------------------------------------------------
+fix :: AppFixity ast => ast SrcSpanInfo -> ast SrcSpanInfo
+fix ast = fromMaybe ast (applyFixities baseFixities ast)
+
+-----------------------------------------------------------------------------------------
+-- | Pre-children tweaks for a given parent at index i.
+--
+pre :: (Typeable a) => a -> Integer -> [String]
+pre x i =
+ case cast x of
+ -- <foo { <foo = 1> }> becomes <foo <{ <foo = 1> }>>
+ Just (RecUpdate SrcSpanInfo{srcInfoPoints=(start:_),srcInfoSpan=end} _ _)
+ | i == 1 ->
+ [spanHSE (show "RecUpdates")
+ "RecUpdates"
+ (SrcSpan (srcSpanFilename start)
+ (srcSpanStartLine start)
+ (srcSpanStartColumn start)
+ (srcSpanEndLine end)
+ (srcSpanEndColumn end))]
+ _ -> case cast x :: Maybe (Deriving SrcSpanInfo) of
+ -- <deriving (X,Y,Z)> becomes <deriving (<X,Y,Z>)
+ Just (Deriving _ ds@(_:_)) ->
+ [spanHSE (show "InstHeads")
+ "InstHeads"
+ (SrcSpan (srcSpanFilename start)
+ (srcSpanStartLine start)
+ (srcSpanStartColumn start)
+ (srcSpanEndLine end)
+ (srcSpanEndColumn end))
+ |Just (IHead (SrcSpanInfo start _) _ _) <- [listToMaybe ds]
+ ,Just (IHead (SrcSpanInfo end _) _ _) <- [listToMaybe (reverse ds)]]
+ _ -> []
+
+-----------------------------------------------------------------------------------------
+-- | Generate a span from a HSE SrcSpan.
+spanHSE :: String -> String -> SrcSpan -> String
+spanHSE typ cons SrcSpan{..} = "[" ++ spanContent ++ "]"
+ where unqualify = dropUntilLast '.'
+ spanContent =
+ unwords [unqualify typ
+ ,cons
+ ,show srcSpanStartLine
+ ,show srcSpanStartColumn
+ ,show srcSpanEndLine
+ ,show srcSpanEndColumn]
+
+------------------------------------------------------------------------------
+-- | Like 'dropWhile', but repeats until the last match.
+dropUntilLast :: Char -> String -> String
+dropUntilLast ch = go []
+ where
+ go _ (c:cs) | c == ch = go [] cs
+ go acc (c:cs) = go (c:acc) cs
+ go acc [] = reverse acc
+
+------------------------------------------------------------------------------
+parseMode :: ParseMode
+parseMode =
+ defaultParseMode { extensions = allExtensions
+ , fixities = Nothing
+ }
+ where allExtensions = filter isDisabledExtention knownExtensions
+ isDisabledExtention (DisableExtension _) = False
+ isDisabledExtention _ = True
+
+------------------------------------------------------------------------------
+-- Parsers that HSE hackage doesn't have
+parseImport :: ParseMode -> String -> ParseResult (ImportDecl SrcSpanInfo)
+parseImport mode code =
+ case parseModuleWithMode mode code of
+ ParseOk (Module _ _ _ [i] _) -> return i
+ ParseOk _ -> ParseFailed noLoc "parseImport"
+ ParseFailed x y -> ParseFailed x y
+
+------------------------------------------------------------------------------
+parseModulePragma :: ParseMode -> String -> ParseResult (ModulePragma SrcSpanInfo)
+parseModulePragma mode code =
+ case parseModuleWithMode mode (code ++ "\nmodule X where") of
+ ParseOk (Module _ _ [p] _ _) -> return p
+ ParseOk _ -> ParseFailed noLoc "parseModulePragma"
+ ParseFailed x y -> ParseFailed x y
+
+------------------------------------------------------------------------------
+genHSE :: Data a => a -> [String]
+genHSE x =
+ case gmapQ D x of
+ zs@(D y:ys) ->
+ case cast y of
+ Just s ->
+ spanHSE (show (show (typeOf x)))
+ (showConstr (toConstr x))
+ (srcInfoSpan s) :
+ concatMap (\(i,D d) -> pre x i ++ genHSE d)
+ (zip [0..] ys)
+ _ ->
+ concatMap (\(D d) -> genHSE d) zs
+ _ -> []