shm-1.0.20/ 0000755 0000000 0000000 00000000000 12472572426 010562 5 ustar 00 0000000 0000000 shm-1.0.20/shm-ast-documentation.el 0000644 0000000 0000000 00000040667 12472572426 015344 0 ustar 00 0000000 0000000 ;;; 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 .
;;; 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
shm-1.0.20/shm-ast.el 0000644 0000000 0000000 00000064550 12472572426 012472 0 ustar 00 0000000 0000000 ;;; shm-ast.el --- AST functions
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-customizations)
(require 'shm-node)
(require 'shm-in)
(require 'shm-overlays)
(require 'ring)
(require 'cl)
(defvar shm-lighter " SHM?"
"The lighter for structured Haskell mode.")
(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-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-history-stack nil
"Stack for story node history.")
(defcustom shm-history-stack-max-length
10
"Maximum length of the node history stack."
:group 'shm
:type 'integer)
(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-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 ((parsed-ast (shm-get-ast (if (bound-and-true-p structured-haskell-repl-mode)
"stmt"
"decl")
start end)))
(let ((bail (lambda ()
(when shm-display-quarantine
(shm-quarantine-overlay start end))
(setq shm-lighter " SHM!")
nil)))
(if parsed-ast
(progn
(when (bound-and-true-p structured-haskell-repl-mode)
(shm-font-lock-region start end))
(let ((ast (shm-get-nodes parsed-ast 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)
(funcall bail))))
(funcall bail)))))))))
(defun shm-font-lock-region (start end)
"When in a REPL, we don't typically have font locking, so we
should manually perform a font-lock whenever we get a valid
parse."
(unless (= (1+ start) end)
(let ((point (point))
(inhibit-modification-hooks t)
(list buffer-undo-list)
(string (buffer-substring-no-properties start end)))
(unless (string-match "^:" string)
(let ((fontified (shm-fontify-as-mode string
'haskell-mode))
(overlays (mapcar (lambda (o)
(list o
(overlay-start o)
(overlay-end o)))
(overlays-in start end))))
(delete-region start end)
(insert fontified)
(goto-char point)
;; Restore overlay positions
(loop for o in overlays
do (move-overlay (nth 0 o) (nth 1 o) (nth 2 o)))
(setq buffer-undo-list list))))))
(defun shm-fontify-as-mode (text mode)
"Fontify TEXT as MODE, returning the fontified text."
(with-temp-buffer
(funcall mode)
(insert "x=" text)
(font-lock-fontify-buffer)
(buffer-substring (+ (point-min) (length "x=")) (point-max))))
(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 start)
(with-temp-buffer
(let ((temp-buffer (current-buffer)))
(with-current-buffer buffer
(condition-case e
(apply #'call-process-region
(append (list start
end
shm-program-name
nil
temp-buffer
nil
"parse"
type)
(shm-extra-arguments)))
((file-error)
(error "Unable to find structured-haskell-mode executable! See README for help.")))))
(read (buffer-string))))))
(defun shm-check-ast (type start end)
"Check whether the region of TYPE from START to END parses.
This doesn't generate or return an AST, it just checks whether it
parses."
(let ((message-log-max nil)
(buffer (current-buffer)))
(with-temp-buffer
(let ((temp-buffer (current-buffer)))
(with-current-buffer buffer
(apply #'call-process-region
(append (list start
end
shm-program-name
nil
temp-buffer
nil
"check"
;; In other words, always parse with
;; the more generic “decl” when
;; something starts at column 0,
;; because HSE distinguishes between a
;; “declaration” and an import, a
;; module declaration and a language
;; pragma.
(if (save-excursion (goto-char start)
(= (point) (line-beginning-position)))
"decl"
type))
(shm-extra-arguments)))))
(string= "" (buffer-string)))))
(defun shm-extra-arguments ()
"Extra arguments to pass to the structured-haskell-mode process."
(shm-language-extensions))
(defun shm-language-extensions ()
"Get the number of spaces to indent."
(if (boundp 'haskell-language-extensions)
haskell-language-extensions
shm-language-extensions))
(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)
((bound-and-true-p structured-haskell-repl-mode)
(case major-mode
(haskell-interactive-mode
;; If the prompt start is available.
(when (boundp 'haskell-interactive-mode-prompt-start)
;; Unless we're running code.
(unless (> (point)
(save-excursion (goto-char haskell-interactive-mode-prompt-start)
(line-end-position)))
;; When we're within the prompt and not on some output lines or whatever.
(when (and (>= (point) haskell-interactive-mode-prompt-start)
(not (= haskell-interactive-mode-prompt-start
(line-end-position))))
(let ((whole-line (buffer-substring-no-properties
haskell-interactive-mode-prompt-start
(line-end-position))))
;; Don't activate if we're doing a GHCi command.
(unless (and (string-match "^:" whole-line)
(not (string-match "^:[tk] " whole-line)))
(cons (save-excursion
(goto-char haskell-interactive-mode-prompt-start)
(when (looking-at ":[kt] ")
(search-forward " " (point-max) t 1))
(point))
(line-end-position))))))))))
;; Otherwise we just do our line-based hack.
(t
(save-excursion
(let ((start (or (flet
((jump ()
(search-backward-regexp "^[^ \n]" nil t 1)
(cond
((save-excursion (goto-char (line-beginning-position))
(looking-at "|]"))
(jump))
(t (unless (or (looking-at "^-}$")
(looking-at "^{-$"))
(point))))))
(goto-char (line-end-position))
(jump))
0))
(end (progn (goto-char (1+ (point)))
(or (flet
((jump ()
(when (search-forward-regexp "[\n]+[^ \n]" nil t 1)
(cond
((save-excursion (goto-char (line-beginning-position))
(looking-at "|]"))
(jump))
(t (forward-char -1)
(search-backward-regexp "[^\n ]" nil t)
(forward-char)
(point))))))
(jump))
(point-max)))))
(cons start end))))))
(defun shm-delete-markers (decl)
"Delete the markers in DECL."
(mapc #'shm-node-delete-markers
(cdr decl)))
(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-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-set-node-overlay (&optional node-pair jump-direction no-record)
"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)))
(unless no-record
(shm-history-record (point) node-pair))))
(defun shm/goto-last-point ()
"Jump to the most recent node."
(interactive)
(let ((stack (shm-history-stack))
(point (point)))
(when (not (ring-empty-p stack))
(let* ((i (if (= (point) (car (ring-ref stack 0)))
1
0))
(pair (ring-ref stack i)))
(when pair
(goto-char (car pair))
(shm-set-node-overlay (cdr pair) nil t)
(loop for j from 0 to i
do (ring-remove stack 0)))))))
(defun shm-history-jump (point)
"Jump to POINT and set the current node to whatever node was
last current at that point."
(goto-char point)
(let ((stack (shm-history-stack)))
(when (not (ring-empty-p stack))
(let ((pair (assoc point (ring-elements stack))))
(when pair
(shm-set-node-overlay (cdr pair)))))))
(defun shm-history-record (point node-pair)
"Record POINT and NODE in the node history."
(ring-insert (shm-history-stack)
(cons point node-pair)))
(defun shm-history-stack ()
"Get the node history of the current buffer."
(if (and (local-variable-p 'shm-history-stack)
shm-history-stack)
shm-history-stack
(set (make-local-variable 'shm-history-stack)
(make-ring shm-history-stack-max-length))))
(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)))))))
(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)))
(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-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
(shm-node-app-p actual-parent))
(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-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-node-child (node-pair)
"Return the immediate child of the given parent."
(cdr (shm-node-child-pair node-pair)))
(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-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-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-get-qop-string (node)
"Get the string of the operator, if the node is an operator."
(when (string= (shm-node-type-name node) "QOp")
(buffer-substring-no-properties (shm-node-start node)
(shm-node-end node))))
(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-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-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-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-current-node-string ()
"Get the text of the current shm node"
(shm-node-string (shm-current-node)))
(provide 'shm-ast)
;; Local variables:
;; byte-compile-warnings: (not cl-functions)
;; byte-compile-warnings: (not cl-macros)
;; End:
shm-1.0.20/shm-case-split.el 0000644 0000000 0000000 00000017413 12472572426 013743 0 ustar 00 0000000 0000000 ;;; shm-case-split.el --- Case splitting functionality
;; 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 .
;;; Commentary:
;; Produces a list of case alternatives from a sum type data
;; declaration.
;;; Code:
(require 'shm)
(require 'shm-ast)
(require 'haskell-process)
(defun shm-case-split-insert-pattern (alts)
"Takes the first alt in ALTS and inserts a pattern match for
it."
(when (car alts)
(let ((alt (car alts)))
(when (> (cdr alt) 0)
(insert "("))
(insert (car alt))
(loop for i from 1 to (cdr alt)
do (progn (insert " _")
(shm-evaporate (1- (point)) (point))))
(when (> (cdr alt) 0)
(insert ")")))))
(defun shm-case-split-insert-alts (alts)
"Inserts case alts for the given ALTS. It will create
evaporating slots for each part. E.g.
case x of
|
for data Maybe a = Just a | Nothing will insert
case x of
Just _ -> undefined
Nothing -> undefined
Where the _ and undefineds are evaporating slots."
(let ((column (current-column)))
(loop for alt in alts
do (progn (when (/= column (current-column))
(insert "\n")
(indent-to column))
(insert (car alt))
(loop for i from 1 to (cdr alt)
do (progn (insert " _")
(shm-evaporate (1- (point)) (point))))
(insert " -> undefined")
(shm-evaporate (- (point) (length "undefined"))
(point))))))
(defun shm-case-split-alts-from-data-decl (string)
"Given a data declaration STRING, generate a list of alternatives."
(with-temp-buffer
(insert (replace-regexp-in-string
"[a-zA-Z0-9]+-[0-9.]+:"
""
string))
(text-mode)
(structured-haskell-mode)
(setq shm-last-parse-start (point-max))
(setq shm-last-parse-end (point-min))
(shm/reparse)
(mapcar #'shm-case-split-name-and-arity
(shm-case-split-get-constructors))))
(defun shm-case-split-generate-alt (cons)
"Generate an alt from the given NODE-PAIR."
(let ((name (car cons))
(arity (cdr cons)))
(format "%s%s"
name
(apply 'concat
(loop for i from 1 to arity
collect " _")))))
(defun shm-case-split-name-and-arity (node-pair)
"Get the constructor name and arity of the given constructor NODE-PAIR."
(let* ((parent (shm-node-child-pair node-pair))
(name-node (shm-node-child parent)))
(goto-char (shm-node-end name-node))
(cons (shm-node-string name-node)
(or (when (/= (shm-node-end name-node)
(shm-node-end (cdr parent)))
(shm/forward-node)
(shm/reparse)
(let ((n 0)
(last-node 0)
(current-pair (shm-current-node-pair)))
(while (and (/= (point) (point-max))
current-pair
(= (car parent)
(car (shm-node-parent current-pair))))
(when (/= (car current-pair)
last-node)
(setq n (1+ n))
(setq last-node (car current-pair)))
(unless (= (point)
(point-max))
(shm/forward-node)
(shm/reparse)
(setq current-pair (shm-current-node-pair))))
n))
0))))
(defun shm-case-split-get-constructors ()
"Get a list of constructors."
(goto-char (point-min))
(or (search-forward "= " nil t 1)
(error "Couldn't find any constructors (searched for '=')."))
(let ((conses (list)))
(while (/= (point) (point-max))
(let ((cons (shm-case-split-get-constructor)))
(when cons
(setq conses (cons cons conses)))))
(reverse conses)))
(defun shm-case-split-get-constructor ()
"Get the constructor at point."
(shm/reparse)
(let ((cons-pair (shm-node-ancestor-at-point (shm-current-node-pair)
(point))))
(goto-char (shm-node-end (cdr cons-pair)))
(or (search-forward "| " nil t 1)
(goto-char (point-max)))
cons-pair))
;; Backend based on haskell-process.el
(defun shm-trim-string (string)
"Remove white spaces in beginning and ending of STRING.
White space here is any of: space, tab, emacs newline (line feed, ASCII 10)."
(replace-regexp-in-string "\\`[ \t\n]*" "" (replace-regexp-in-string "[ \t\n]*\\'" "" string)))
(defun haskell-process-get-type (expr)
"Get the type of the given expression or name."
(let ((reply
(haskell-process-queue-sync-request (haskell-process)
(format ":t %s\n" expr))))
(shm-trim-string (car (last (split-string reply " :: "))))))
(defun shm-cleanup-type-string-for-case (s)
"Remove constraints and replace polymorphic type variables with
() to allow shm/case-split to work in more cases."
(let* ((clean-s (car
(last
(mapcar 'shm-trim-string
(split-string s "=>"))))))
(if s
(let ((case-fold-search nil))
(replace-regexp-in-string "\\b[a-z_][A-Za-z_]*\\b" "()" clean-s))
s)))
(defun haskell-process-get-data-type (name)
"Get the data type definition of the given name."
(let ((reply
(haskell-process-queue-sync-request (haskell-process)
(format ":i %s\n" name))))
(car (split-string reply "[\n\t ]+-- Defined "))))
(defun shm/case-split (name &optional expr-string)
"Prompt for a type then do a case split based on it."
(interactive (list (read-from-minibuffer "Type: ")))
(save-excursion
(let ((column (current-column))
(case-expr (if expr-string
expr-string
"undefined")))
(insert (concat "case " case-expr " "))
(if (not expr-string)
(shm-evaporate (- (point) (+ 1 (length "undefined")))
(- (point) 1)))
(insert "of\n")
(indent-to (+ column 2))
(shm-case-split-insert-alts
(shm-case-split-alts-from-data-decl
(haskell-process-get-data-type name))))))
(defun shm/case-split-shm-node ()
"Do a case split based on the current node expression type."
(interactive)
(let* ((expr (shm-current-node-string))
(expr-type (haskell-process-get-type expr))
(clean-expr (shm-cleanup-type-string-for-case expr-type)))
(if expr-type
(progn
(shm/kill-node)
(shm/case-split clean-expr expr)))))
(defun shm/do-case-split (arg)
"Without prefix, calculate type of current node expression and replace it
with a case expression based on its type. With prefix, insert a case expression based
on the type given at the prompt."
(interactive "P")
(if arg
(call-interactively 'shm/case-split)
(call-interactively 'shm/case-split-shm-node)))
(defun shm/expand-pattern (name)
"Expand a pattern match on a data type."
(interactive (list (read-from-minibuffer "Type: ")))
(save-excursion
(shm-case-split-insert-pattern
(shm-case-split-alts-from-data-decl
(haskell-process-get-data-type name)))))
(provide 'shm-case-split)
shm-1.0.20/shm-constraint.el 0000644 0000000 0000000 00000006264 12472572426 014065 0 ustar 00 0000000 0000000 ;;; shm-constraint.el --- Constraint editing functions.
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-ast)
(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))))
(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)))
(defun add-initial-type-constraint (node)
(goto-char (shm-node-start node))
(insert " => ") (backward-char 4))
(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-type-signature-with-constraint-p (pair)
(let ((current-node (cdr pair)))
(and (shm-top-level-type-decl-p pair)
(shm-node-syntax-contains-regex "=>" current-node))))
(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 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-concrete-syntax-for-node (node)
"Get the concrete syntax of the node"
(buffer-substring-no-properties
(shm-node-start (shm-current-node))
(shm-node-end (shm-current-node))))
(defun shm-has-parent-with-matching-type-p (node-pair)
(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))))
(provide 'shm-constraint)
shm-1.0.20/shm-customizations.el 0000644 0000000 0000000 00000007334 12472572426 014773 0 ustar 00 0000000 0000000 ;;; 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 .
;;; 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-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-language-extensions
(if (boundp 'haskell-language-extensions)
haskell-language-extensions
'())
"Language extensions in use. Should be in format: -XFoo, -XNoFoo etc."
:group 'shm
:type '(repeat '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-colon-enabled
nil
"Do special insertion of colons."
:group 'shm
:type 'boolean)
(defcustom shm-prevent-parent-deletion
t
"Prevent backspacing over parent heads that would break the
syntax."
:group 'shm
:type 'boolean)
(defcustom shm-idle-timeout
0.2
"Number of seconds before re-parsing."
:group 'shm
:type 'string)
(defcustom shm-indent-point-after-adding-where-clause
nil
"Whether to indent point to the next line when inseting where clause, e.g.
| being a point:
foo x = ...
where
|
when option is t, as opposed to
foo x = ...
where |
when option is nil.
"
:group 'shm
:type 'boolean)
(defcustom shm-pragmas
'("LANGUAGE" "OPTIONS_GHC" "INCLUDE" "DEPRECATED" "WARNING"
"INLINE" "NOINLINE" "INLINABLE" "CONLIKE" "LINE" "RULES"
"SPECIALIZE" "UNPACK" "SOURCE" "SCC")
"Pragmas supported."
:group 'shm
:type 'list)
;; Provide
(provide 'shm-customizations)
;;; shm.el ends here
;; End:
shm-1.0.20/shm-debug.el 0000644 0000000 0000000 00000006761 12472572426 012771 0 ustar 00 0000000 0000000 ;;; shm-debug.el --- Debugging utilities
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-layout)
(defun shm/test-exe ()
"Test that the executable is working properly."
(interactive)
(let ((region (shm-decl-points)))
(when (get-buffer "*shm-scratch-test*")
(with-current-buffer
(switch-to-buffer "*shm-scratch-test*")
(erase-buffer)))
(call-process-region (car region)
(cdr region)
shm-program-name
nil
"*shm-scratch-test*"
nil
"parse"
"decl")
(switch-to-buffer "*shm-scratch-test*")
(when (save-excursion (goto-char (point-min))
(looking-at "structured-haskell-mode:"))
(insert "\nNote: If you got a parse error for valid code
that is using fairly new (read: couple years) a GHC extension,
you are probably hitting the fact that haskell-src-exts doesn't
parse a bunch of newer GHC extensions. SHM does not do any
parsing itself, it uses HSE. There are some patches in the HSE
repo, provided as pull requests, which you can try applying to a
local copy of HSE and then recompile SHM with the new version.
See also: https://github.com/haskell-suite/haskell-src-exts/issues/19
And: https://github.com/chrisdone/structured-haskell-mode/blob/master/src/Main.hs"))))
(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-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)))
(shm-node-string node))
(format "Node type: “%s” (no more info)"
(shm-node-type-name node)))))
(defun shm-node-string (node)
"Get the string of the NODE."
(save-excursion
(shm-kill-node 'buffer-substring-no-properties
node
nil
t)))
(provide 'shm-debug)
shm-1.0.20/shm-edit-string.el 0000644 0000000 0000000 00000005003 12472572426 014120 0 ustar 00 0000000 0000000 ;;; shm-edit-string.el --- Editing strings
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-insert-del)
(require 'shm-layout)
(defvar shm-string-buffer nil
"The buffer of the string node that's currently being edited.")
(defvar shm-string-node nil
"The string node that's currently being edited.")
(defun shm/edit-string ()
"Edit the string at point."
(interactive)
(let ((current (shm-current-node))
(buffer (current-buffer))
(string (shm-kill-node 'buffer-substring-no-properties nil nil t)))
(goto-char (shm-node-start current))
(switch-to-buffer (get-buffer-create "*shm-string*"))
(erase-buffer)
(insert
(replace-regexp-in-string
"\\\\\"" "\""
(replace-regexp-in-string
"\\\\n" "\n"
(replace-regexp-in-string
"^\"\\(.*\\)\"$" "\\1"
(replace-regexp-in-string
"\\\\\n\\\\" ""
string)))))
(shm-edit-string-mode)
(set (make-local-variable 'shm-string-node)
current)
(set (make-local-variable 'shm-string-buffer)
buffer)
(goto-char (point-min))))
(define-derived-mode shm-edit-string-mode
text-mode "String"
"Major mode for editing string content from a Haskell string.")
(define-key shm-edit-string-mode-map (kbd "C-c C-c") 'shm-finish-editing-string)
(defun shm-finish-editing-string ()
"Take the contents of the buffer and insert it back into the
original node in the Haskell buffer, replacing the old one."
(interactive)
(let ((finish-string (buffer-string))
(buffer shm-string-buffer))
(quit-window)
(switch-to-buffer buffer)
(shm/delete)
(insert "\"\"")
(forward-char -1)
(save-excursion
(font-lock-fontify-region (line-beginning-position)
(line-end-position)))
(shm-insert-indented (lambda () (insert finish-string)))
(forward-char -1)))
(provide 'shm-edit-string)
shm-1.0.20/shm-evaporate.el 0000644 0000000 0000000 00000005007 12472572426 013661 0 ustar 00 0000000 0000000 ;;; 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 .
;;; 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-before-p ()
"Before an evaporating piece of code at point?"
(let ((os (remove-if-not
(lambda (o)
(overlay-get o 'shm-evaporate-overlay))
(overlays-in (point) (1+ (point))))))
(not (null os))))
(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))
(shm-evaporate-delete-text o beg end)
(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))
(shm-evaporate-delete-text o beg end)
(delete-overlay o))))
(defun shm-evaporate-delete-text (o beg end)
"Delete the text associated with the evaporating slot."
(unless (eq this-command 'undo)
(delete-region (overlay-start o)
(overlay-end o))))
(provide 'shm-evaporate)
;;; shm-evaporate.el ends here
shm-1.0.20/shm-fold.el 0000644 0000000 0000000 00000004577 12472572426 012632 0 ustar 00 0000000 0000000 ;;; shm-fold.el --- Code folding.
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(defun shm-fold ()
"Fold either the region or the node at point."
(interactive)
(if (region-active-p)
(shm-fold-region (region-beginning)
(region-end))
(let ((current (shm-current-node)))
(shm-fold-region (shm-node-start current)
(shm-node-end current)))))
(defun shm-fold-toggle-decl ()
"Toggle the folding or unfolding of the declaration."
(interactive)
(let* ((points (shm-decl-points))
(o (car (remove-if-not (lambda (o)
(overlay-get o 'folded-decl))
(overlays-in (car points)
(cdr points))))))
(if o
(delete-overlay o)
(shm-fold-decl))))
(defun shm-fold-decl ()
"Fold the current declaration."
(interactive)
(let* ((points (shm-decl-points))
(beg (save-excursion (goto-char (car points))
(line-end-position)))
(end (cdr points)))
(when (> end beg)
(shm-fold-region beg end 'folded-decl))))
(defun shm-fold-region (beg end &optional prop)
"Hide region."
(let ((o (make-overlay beg end)))
(overlay-put o 'invisible t)
(overlay-put o 'intangible t)
(overlay-put o 'after-string "...")
(overlay-put o 'hide-region t)
(overlay-put o prop t)))
(defun shm-fold-region-undo ()
"Undo the hidden region at point."
(interactive)
(mapcar (lambda (o)
(when (overlay-get o 'hide-region)
(delete-overlay o)))
(overlays-in (- (point) 1)
(+ (point) 1))))
(provide 'shm-fold)
;; Local variables:
;; byte-compile-warnings: (not cl-functions)
;; End:
shm-1.0.20/shm-in.el 0000644 0000000 0000000 00000004064 12472572426 012303 0 ustar 00 0000000 0000000 ;;; shm-in.el --- Are we in some thing.
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(defun shm-in-comment ()
"Are we currently in a comment?"
(save-excursion
(when (and (= (line-end-position)
(point))
(/= (line-beginning-position) (point)))
(forward-char -1))
(and (or (eq 'font-lock-comment-delimiter-face
(get-text-property (point) 'face))
(eq 'font-lock-doc-face
(get-text-property (point) 'face))
(eq 'font-lock-comment-face
(get-text-property (point) 'face))
(save-excursion (goto-char (line-beginning-position))
(looking-at "^\-\- ")))
;; Pragmas {-# SPECIALIZE .. #-} etc are not to be treated as
;; comments, even though they are highlighted as such
(not (save-excursion (goto-char (line-beginning-position))
(looking-at "{-# "))))))
(defun shm-in-string ()
"Are we in a string?"
(save-excursion
(when (looking-at "\"")
(forward-char -1))
(eq 'font-lock-string-face
(get-text-property (point) 'face))))
(defun shm-in-char ()
"Are we in a char literal?"
(save-excursion
(and (looking-at "'")
(looking-back "'"))))
(defun shm-literal-insertion ()
"Should a node have literal insertion?"
(or (shm-in-string)
(shm-in-char)
(shm-in-comment)))
(provide 'shm-in)
shm-1.0.20/shm-indent.el 0000644 0000000 0000000 00000047105 12472572426 013161 0 ustar 00 0000000 0000000 ;;; shm-indent.el --- Indentation commands
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-layout)
(require 'shm-simple-indent)
(defun shm/delete-indentation ()
"Send the node up one line."
(interactive)
(if (looking-back "^[ ]+")
(cond
((or (looking-at "then[] [{}\"'()]")
(looking-at "else[] [{}\"'()]"))
(delete-indentation))
((looking-at "[ ]*$")
(delete-indentation))
(t
(let ((current (shm-current-node)))
(let ((old-column (current-column)))
(delete-region (line-beginning-position) (point))
(delete-char -1)
(let ((new-column (current-column)))
(indent-rigidly (line-end-position)
(shm-node-end current)
(abs (- old-column new-column))))))
(when nil
(let ((string (shm-kill-node 'buffer-substring-no-properties)))
(delete-indentation)
(insert " ")
(shm-insert-indented
(lambda ()
(insert string)))))))
(delete-indentation)))
(defun shm/swing-down ()
"Swing the children of the current node downwards.
hai = do foo bar
mu zot
With the cursor on `do', this will produce:
hai = do
foo bar
mu zot
"
(interactive)
(let* ((current-pair (shm-current-node-pair))
(current (cdr current-pair)))
(cond
((eq (shm-node-cons current)
'Do)
(save-excursion
(let ((new-column (shm-get-swing-column current)))
(goto-char (shm-node-start current))
(forward-word 1)
(search-forward " ")
(let ((old-column (current-column)))
(insert "\n")
(indent-rigidly (point)
(shm-node-end current)
(- old-column))
(indent-rigidly (point)
(shm-node-end current)
new-column)))
(shm/reparse)))
((eq (shm-node-cons current)
'Var)
(let* ((next-pair (shm-node-next current-pair))
(parent-pair (shm-node-parent current-pair))
(start (shm-node-start-column (cdr parent-pair))))
(let ((swing-string
(shm-kill-region 'buffer-substring-no-properties
(shm-node-start (cdr next-pair))
(shm-node-end (cdr parent-pair))
nil)))
(shm/reparse)
(forward-char -1)
(shm-newline)
(indent-to (+ (shm-indent-spaces)
start))
(shm-insert-indented (lambda () (insert swing-string))))))
(t
(error "Don't know how to swing that kind of expression.")))))
(defun shm-get-swing-column (node)
"Get the column that a node would be newline-indented to."
(save-excursion
(let ((start (shm-node-start node)))
(goto-char start)
(shm-newline-indent nil nil)
(let ((column (current-column)))
(delete-region start (point))
column))))
(defun shm/swing-up ()
"Swing the children of the current node upwards.
hai = do
foo bar
mu zot
With the cursor on `do', this will produce:
hai = do foo bar
mu zot
"
(interactive)
(let* ((current-pair (shm-current-node-pair))
(current (cdr current-pair)))
(cond
((eq (shm-node-cons current)
'Do)
(let ((swing-string
(shm-kill-node 'buffer-substring-no-properties
current
(shm-node-start (shm-node-child current-pair)))))
(delete-indentation)
(if (looking-at " ")
(forward-char 1)
(insert " "))
(shm-insert-indented (lambda () (insert swing-string)))))
(t
(error "Don't know how to swing that kind of expression.")))))
(defun shm/newline-indent ()
"Make a newline and indent, making sure to drag anything down, re-indented
with it."
(interactive)
(cond
((or (= (line-beginning-position)
(line-end-position))
(not (shm-current-node)))
(if (= (line-beginning-position)
(line-end-position))
(newline)
(progn (newline)
(shm/simple-indent))))
((and (shm-in-string)
(not (= (shm-node-start (shm-current-node))
(point))))
(let ((column (shm-node-start-column (shm-current-node))))
(insert "\\")
(shm-newline)
(indent-to column)
(insert "\\")))
((and (looking-at "[^])}\"]") ;; This is a cheap solution. It
;; could use node boundaries
;; instead.
(not (looking-at "$"))
(looking-back " "))
(shm/reparse)
(let ((newline-string (buffer-substring-no-properties (point)
(shm-node-end (shm-current-node))))
;; This is like (line-end-position), but if the line ends in
;; a closing delimiter like ), then *really* the "end" of
;; the thing we're dragging should be inside these
;; delimiters.
(end-position (save-excursion
(goto-char (line-end-position))
(when (looking-back "[])}\"]+")
(search-backward-regexp "[^])}\"]")
(forward-char 1))
(point))))
;; If we're going to drag something, that means the *real* parent
;; should encompass whatever we're going to drag, and that should
;; be at or beyond the end of the line.
(unless (looking-at "\\(=>\\|->\\)")
(let ((current (shm-current-node-pair)))
(while (and (not (>= (shm-node-end (cdr current))
end-position))
(/= (car current)
(car (shm-node-ancestor-at-point current
(shm-node-start (cdr current))))))
(shm/goto-parent)
(setq current (shm-current-node-pair)))))
;; If there's some stuff trailing us, then drag that with us.
(let* ((current (shm-current-node))
(old-column (shm-node-start-column current)))
(shm-newline-indent t
newline-string)
(let ((new-column (current-column)))
(indent-rigidly (point)
(shm-node-end current)
(- (abs (- old-column new-column))))))))
;; Otherwise just do the indent.
(t (shm/reparse)
(shm-newline-indent nil)))
(shm/reparse))
(defun shm-newline-indent (dragging &optional newline-string)
"Go to the next logical line from the current node at the right column.
This function uses the node's type to decode how to indent, and
in some cases will insert commas and things like for tuples and
lists.
DRAGGING indicates whether this indent will drag a node downwards."
(let* ((current-pair (shm-current-node-pair))
(current (cdr current-pair))
(parent-pair (shm-node-parent current-pair))
(parent (cdr parent-pair))
(inhibit-read-only t))
(cond
((or (string= (shm-node-type-name current)
"ImportSpecList")
(and (string= (shm-node-type-name current)
"ModuleName")
(looking-at "$")
parent
(string= (shm-node-type-name parent)
"ImportDecl")))
(shm-newline)
(insert "import "))
((and (or (string= "Type" (shm-node-type-name current))
(string= "Context" (shm-node-type-name current)))
(eq 'TypeSig (shm-node-cons (shm-decl-node (point)))))
(let ((column (save-excursion (search-backward-regexp " :: ")
(+ 4 (current-column)))))
(shm-newline)
(indent-to column)
(when (and dragging
(or (string-match "^=>" newline-string)
(string-match "^->" newline-string)))
(delete-region (- (point) 3) (point)))))
;; List comprehensions
((and parent
(eq 'QualStmt (shm-node-cons parent)))
(shm-newline)
(indent-to (1- (shm-node-start-column parent)))
(insert ",")
(shm-set-node-overlay parent-pair))
;; When inside a list, indent to the list's position with an
;; auto-inserted comma.
((and parent
(or (eq 'List (shm-node-cons parent))
(eq 'Tuple (shm-node-cons parent))
(eq 'QualStmt (shm-node-cons parent))))
(shm-newline-indent-listish current parent parent-pair))
;; Lambdas indents k spaces inwards
((eq 'Lambda (shm-node-cons current))
(shm-newline)
(indent-to (+ (shm-indent-spaces) (shm-node-start-column current))))
;; Indentation for RHS
((and parent
(eq 'App (shm-node-cons parent))
(= (shm-node-start current)
(shm-node-start parent)))
(let ((ancestor-parent (shm-node-parent
(shm-node-ancestor-at-point current-pair (point))))
(decl (shm-node-parent current-pair "Decl SrcSpanInfo")))
(shm-newline)
(indent-to (+ (shm-indent-spaces)
(shm-node-start-column (cdr decl))))))
;; Indentation for function application.
((and parent
(or (eq 'App (shm-node-cons parent))
(eq 'TyApp (shm-node-cons parent))
(eq 'ConDecl (shm-node-cons parent))))
(let ((column
(save-excursion
(if (/= (shm-node-start-line current)
(shm-node-start-line parent))
(shm-node-start-column current)
(progn (shm/goto-parent)
(forward-sexp)
(1+ (current-column))))))
(previous
(when (looking-back " ")
(save-excursion
(search-backward-regexp "[ ]+"
(line-beginning-position)
t
1)
(let ((prev (shm-current-workable-node)))
(when (and (= (car (shm-node-parent prev))
(car parent-pair))
(/= (shm-node-start parent)
(shm-node-start (cdr prev))))
prev))))))
(cond
(previous
(shm-newline)
(indent-to (shm-node-start-column (cdr previous))))
((and (or (= column (current-column))
(= column (+ (shm-node-start-column parent)
(shm-indent-spaces))))
(/= column (shm-node-start-column parent)))
(shm-newline)
(indent-to (+ (shm-node-start-column parent)
(shm-indent-spaces))))
(t
(shm-newline)
(indent-to column)))))
;; Indent for sum types
((or (and parent
(eq 'DataDecl (shm-node-cons parent)))
(eq 'ConDecl (shm-node-cons current)))
(shm-newline)
(indent-to (shm-node-start-column current))
(delete-char -2)
(insert "| "))
;; Auto-insert commas for field updates
((or (string= "FieldUpdate" (shm-node-type-name current))
(string= "FieldDecl" (shm-node-type-name current))
(string= "ExportSpec" (shm-node-type-name current))
(string= "ImportSpec" (shm-node-type-name current)))
;; This is hacky because HSE doesn't have special nodes for the
;; record and the update in record {update} and so we have to
;; figure out where the { starts. There is some additional
;; information in HSE's trees, but I haven't thought of a nice
;; way to extract that yet.
(goto-char (shm-node-end parent))
(backward-sexp)
(let ((column (current-column)))
(goto-char (shm-node-end current))
(shm-newline)
(indent-to column)
(insert ",")
(insert (make-string (abs (- (shm-node-start-column current)
(1+ column)))
? ))
(shm-auto-insert-field-prefix current parent)
(shm/init)))
((and parent
(eq 'Lambda (shm-node-cons parent)))
(cond
((eq shm-lambda-indent-style 'leftmost-parent)
(let ((leftmost-parent (cdr (shm-find-furthest-parent-on-line parent-pair t))))
(shm-newline)
(indent-to (+ (shm-indent-spaces)
(shm-node-indent-column leftmost-parent)))))
(t (shm-newline)
(indent-to (+ (shm-indent-spaces)
(shm-node-start-column parent))))))
;; Guards | foo = …
((or (string= "GuardedRhs" (shm-node-type-name current))
(string= "GuardedAlt" (shm-node-type-name current)))
(shm-newline)
(indent-to (shm-node-start-column current))
(insert "| "))
;; Indent after or at the = (an rhs).
((and parent
(or (string= "Rhs" (shm-node-type-name parent))
(string= "Rhs" (shm-node-type-name current))
(string= "GuardedAlt" (shm-node-type-name parent))
(string= "GuardedRhs" (shm-node-type-name parent))))
(shm-newline)
(indent-to (+ (shm-indent-spaces)
(shm-node-start-column (cdr (shm-node-parent parent-pair))))))
;; When in a field update.
((and parent
(string= "FieldUpdate" (shm-node-type-name parent)))
(shm-newline)
(indent-to (+ (shm-node-start-column parent)
(shm-indent-spaces))))
;; When in an alt list
((and parent
(string= "GuardedAlts" (shm-node-type-name current)))
(shm-newline)
(indent-to (+ (shm-node-start-column parent)
(shm-indent-spaces))))
;; When in a case alt.
((and parent
(string= "GuardedAlts" (shm-node-type-name parent)))
(shm-newline)
(let ((alt (cdr (shm-node-parent parent-pair))))
(indent-to (+ (shm-node-start-column alt)
(shm-indent-spaces)))))
;; Infix operators
((and parent
(eq 'InfixApp (shm-node-cons parent)))
(shm-newline)
(indent-to (+ (shm-node-start-column parent))))
((and parent
(eq 'Paren (shm-node-cons parent)))
(shm-newline-indent-listish current parent parent-pair))
;; Default indentation just copies the current node's indentation
;; level. Generally works reliably, but has less than favourable
;; indentation sometimes. It just serves as a catch-all.
(t
(shm-newline)
(indent-to (shm-node-start-column current))))))
(defun shm-newline-indent-listish (current parent parent-pair)
"Indent and insert a comma for a list-ish syntactical node."
(let* ((first-item-on-line (and (not (looking-at ","))
(save-excursion
(goto-char (shm-node-start current))
(search-backward-regexp "[[,][ ]*")
(= (current-column)
(shm-node-start-column parent)))))
(go-back (and first-item-on-line
(= (point) (shm-node-start current))))
(already-have-comma (looking-back ",")))
(shm-newline)
(indent-to (shm-node-start-column parent))
;; Don't insert duplicate commas.
(unless (or (looking-at ",") already-have-comma)
(insert ","))
(when go-back
(let ((column (current-column)))
(forward-line -1)
(forward-char column)))
(when first-item-on-line
(insert (make-string (- (shm-node-start-column current)
(current-column))
? )))
(unless (or (looking-back ",")
(looking-at ","))
(insert " "))
(shm-set-node-overlay parent-pair)))
;; Copy infix operators similar to making new list/tuple
;; separators
;; ((and parent
;; (eq 'InfixApp (shm-node-cons parent)))
;; (let* ((operand-pair (shm-node-previous current-pair))
;; (operand (cdr operand-pair))
;; (string (buffer-substring-no-properties (shm-node-start operand)
;; (shm-node-end operand))))
;; (cond
;; (dragging
;; (shm-newline)
;; (indent-to (shm-node-start-column parent)))
;; ((save-excursion (goto-char (shm-node-end operand))
;; (= (point) (line-end-position)))
;; (insert " " string)
;; (shm-newline)
;; (indent-to (shm-node-start-column current)))
;; (t
;; (shm-newline)
;; (indent-to (shm-node-start-column operand))
;; (insert string " ")))))
;; A case for shm-newline-indent which will copy a case-alt. Not
;; determined how to best include this feature yet.
;;
;; ((eq 'Alt (shm-node-cons current))
;; (shm-newline)
;; (indent-to (shm-node-start-column current))
;; (when shm-auto-insert-skeletons
;; (save-excursion (insert "_ -> undefined"))
;; (shm-evaporate (point) (+ (point) 1))
;; (shm-evaporate (+ (point) (length "_ -> "))
;; (+ (point) (length "_ -> undefined")))))
;; Commenting out this behaviour for now
;; ((string= "Match" (shm-node-type-name current))
;; (let ((name (cdr (shm-node-child-pair current-pair))))
;; (shm-newline)
;; (indent-to (shm-node-start-column current))
;; (insert (buffer-substring-no-properties (shm-node-start name)
;; (shm-node-end name))
;; " ")))
(defun shm-auto-insert-field-prefix (current parent)
"Auto insert prefixes of fields in record declarations. Example:
data Person = Person
{ personAge :: Int
, person|
"
(when (string= "FieldDecl" (shm-node-type-name current))
(let* ((cur-substr
(save-excursion
(goto-char (shm-node-start current))
(buffer-substring-no-properties (point)
(progn (forward-word 1)
(point)))))
(type-name
(save-excursion
(goto-char (shm-node-start parent))
(buffer-substring-no-properties (point)
(progn (forward-word 1)
(point)))))
(prefix
(if (string-match "\\([A-Z]\\)\\(.*\\)"
type-name)
(concat (downcase (match-string 1 type-name))
(match-string 2 type-name))
type-name)))
(when (string-prefix-p prefix cur-substr)
(insert prefix)))))
(defun shm-newline ()
"Normal `newline' does funny business. What we want is to
literally insert a newline and no more."
(insert "\n"))
(defun shm/split-line ()
"Split line."
(interactive)
(if (shm-literal-insertion)
(call-interactively 'split-line)
(save-excursion
(let ((column (current-column)))
(insert "\n")
(indent-to column)))))
(provide 'shm-indent)
shm-1.0.20/shm-insert-del.el 0000644 0000000 0000000 00000046576 12472572426 013761 0 ustar 00 0000000 0000000 ;;; shm-insert-del.el --- Insertion/deletion commands
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-macros)
(require 'shm-slot)
(require 'shm-layout)
(require 'shm-indent)
(defun shm-post-self-insert ()
"Self-insertion handler."
(save-excursion
(shm-appropriate-adjustment-point 'forward)
(forward-char -1)
(shm-adjust-dependents (point) 1)))
(defun shm/wrap-parens (&optional current)
"Wrap the node in parentheses."
(interactive)
(cond
((region-active-p)
(shm-wrap-delimiters "(" ")"))
(t (let ((line (line-number-at-pos))
(node (or current (shm-current-node))))
(save-excursion
(goto-char (shm-node-start node))
(insert "(")
(goto-char (shm-node-end node))
(when (/= line (line-number-at-pos))
(indent-rigidly (shm-node-start node)
(shm-node-end node)
1))
(insert ")"))
(forward-char 1)))))
(defun shm/space ()
"Insert a space but sometimes do something more clever, like
inserting skeletons."
(interactive)
(if (and (bound-and-true-p god-local-mode)
(fboundp 'god-mode-self-insert))
(god-mode-self-insert)
(let ((case-fold-search nil))
(cond
((or (shm-in-comment)
(shm-in-string))
(insert " "))
(shm-auto-insert-skeletons
(cond
((looking-back "[[ (,]\\\\")
(shm-auto-insert-lambda))
((and (looking-back "[^a-zA-Z0-9_]do")
(shm-nothing-following-p))
(shm-auto-insert-do))
((and (looking-back " <-")
(let ((current (shm-current-node)))
(when current
(or (eq 'Do (shm-node-cons current))
(string= "Stmt" (shm-node-type-name current))))))
(if (bound-and-true-p structured-haskell-repl-mode)
(insert " ")
(shm-auto-insert-stmt 'qualifier)))
((and (looking-back "[^a-zA-Z0-9_]case")
(shm-nothing-following-p))
(shm-auto-insert-case))
((and (looking-back "[^a-zA-Z0-9_]if")
(shm-nothing-following-p))
(shm-auto-insert-if))
((and (looking-back "[^a-zA-Z0-9_]let")
(shm-nothing-following-p))
(cond
((let ((current (shm-current-node)))
(and current
(or (not (or (eq 'Do (shm-node-cons current))
(eq 'BDecls (shm-node-cons current))
(string= "Stmt" (shm-node-type-name current))))
(bound-and-true-p structured-haskell-repl-mode))))
(shm-auto-insert-let))
((not (bound-and-true-p structured-haskell-repl-mode))
(shm-auto-insert-stmt 'let))))
((and (looking-back "module")
(= (line-beginning-position)
(- (point) 6))
(looking-at "[ ]*$"))
(shm-auto-insert-module))
(t (shm-insert-string " ")))
)
(t (shm-insert-string " "))))))
(defun shm-auto-insert-lambda ()
"Lambda insertion."
(save-excursion
(shm/insert-underscore)
(forward-char)
(insert " -> ")
(shm/insert-undefined)))
(defun shm-nothing-following-p ()
"Is there nothing following me (other than closing delimiters)?"
(or (eolp)
(looking-at "[])},;]")))
(defun shm/double-quote ()
"Insert double quotes.
This tries to be clever about insertion. If already in a string,
it will insert \", if at the end of a string, it will glide over
the ending quote. If not in a string, it will insert \"\", and
also space out any neccessary spacing."
(interactive)
(shm/reparse)
(if (shm-in-comment)
(insert "\"")
(let* ((current-node (shm-current-node))
(node (if (eq 'Lit (shm-node-cons current-node))
(shm-actual-node)
current-node)))
(cond
((and (shm-in-string)
(looking-back "\\\\"))
(insert "\""))
((shm-find-overlay 'shm-quarantine)
(insert "\"\"")
(forward-char -1))
;; "…|…"
((shm-in-string)
(cond
;; "…|"
((= (point)
(1- (shm-node-end node)))
(forward-char 1))
;; "…|…"
((= (point) (shm-node-end node))
(if (looking-back "\"")
(shm-delimit "\"" "\"")
(progn (insert "\""))))
(t (let ((inhibit-read-only t))
(shm-adjust-dependents (point) 2)
(insert "\\\"")))))
;; '|'
((save-excursion (forward-char -1)
(looking-at "''"))
(let ((inhibit-read-only t))
(shm-adjust-dependents (point) 1)
(insert "\"")))
;; anywhere
(t
(shm-delimit "\"" "\""))))))
(defun shm/comma (n)
"Insert a comma. In a list it tries to help a bit by setting
the current node to the parent."
(interactive "p")
(if (shm-in-comment)
(self-insert-command n)
(let ((current-pair (shm-current-node-pair)))
(if (not current-pair)
(self-insert-command n)
(let* ((current (cdr current-pair))
(parent-pair (shm-node-parent current-pair))
(parent (cdr parent-pair)))
(cond
;; When inside a list, indent to the list's position with an
;; auto-inserted comma.
((eq 'List (shm-node-cons parent))
(shm-insert-string ",")
(shm-set-node-overlay parent-pair))
(t
(shm-insert-string ",")
(shm-set-node-overlay parent-pair))))))))
(defun shm/single-quote ()
"Delimit single quotes."
(interactive)
(shm-delimit "'" "'"))
(defun shm/= ()
"Insert equal."
(interactive)
(cond
((shm-literal-insertion)
(insert "="))
(t (unless (looking-back " ")
(shm-insert-string " "))
(shm-insert-string "=")
(unless (looking-at " ")
(shm-insert-string " ")))))
(defun shm/: ()
"Insert colon."
(interactive)
(if (or (not shm-colon-enabled)
(shm-literal-insertion))
(call-interactively 'self-insert-command)
(let ((current (shm-current-node)))
(cond
((and current
(or (eq (shm-node-cons current)
'SpliceDecl)
(string= (shm-node-type-name current)
"BangType")
(string= (shm-node-type-name current)
"FieldDecl")))
(unless (looking-back "[ ]+")
(insert " "))
(unless (looking-back "::[ ]+")
(shm-insert-string ":: a")
(forward-word -1)
(shm-evaporate (point) (1+ (point)))))
(t
(shm-insert-string ":"))))))
(defun shm/hyphen (n)
"The - hyphen."
(interactive "p")
(if (and (looking-back "{")
(looking-at "}"))
(progn (insert "--")
(forward-char -1))
(self-insert-command n)))
(defun shm/hash (n)
"The # hash."
(interactive "p")
(if (and (looking-back "{-")
(looking-at "-}"))
(progn (insert "# #")
(forward-char -2)
(let ((pragma (ido-completing-read "Pragma: "
shm-pragmas)))
(insert pragma
" ")
(when (string= pragma "LANGUAGE")
(insert (ido-completing-read
"Language: "
(remove-if (lambda (s) (string= s ""))
(split-string (shell-command-to-string "ghc --supported-languages")
"\n")))))))
(self-insert-command n)))
(defun shm/open-paren ()
"Delimit parentheses."
(interactive)
(let ((current (shm-current-node)))
(cond
((and current
(or (string= "ExportSpec" (shm-node-type-name current))
(string= "ImportSpec" (shm-node-type-name current))))
(insert "()")
(forward-char -1))
(t
(shm-delimit "(" ")")))))
(defun shm/open-bracket ()
"Delimit brackets."
(interactive)
(shm-delimit "[" "]"))
(defun shm/open-brace ()
"Delimit braces."
(interactive)
(let ((current (shm-current-node)))
(cond
((and current
(string= "Pat" (shm-node-type-name current)))
(shm-insert-string "{}")
(forward-char -1))
(t
(shm-delimit "{" "}")))))
(defun shm/del ()
"Character deletion handler.
Generally, we delete things in the current node. BUT, there are
some things that we shouldn't delete, because they would cause
parse errors that are rarely useful. For example:
(|case x of _ -> _) -- where | indicates cursor.
"
(interactive)
(shm-with-fallback
delete-backward-char
(let ((case-fold-search nil))
(cond
((region-active-p)
(delete-region (region-beginning)
(region-end)))
;; These cases are “gliders”. They simply move over the character
;; backwards. These could be handled all as one regular
;; expression, but in the interest of clarity—for now—they are left
;; as separate cases.
((and (shm-in-string)
(looking-back "^[ ]*\\\\"))
(let ((here (point)))
(delete-region (search-backward-regexp "\\\\$")
here)))
((and (looking-back "{-[ ]*")
(looking-at "[ ]*-}"))
(delete-region (search-backward-regexp "-")
(progn (forward-char 1)
(search-forward-regexp "-"))))
((and (looking-back "^{-#[ ]*")
(looking-at "[ ]*#-}$"))
(delete-region (search-backward-regexp "#")
(progn (forward-char 1)
(search-forward-regexp "#"))))
((looking-back "[()]") (shm-delete-or-glide "(" ")"))
((looking-back "[[]") (shm-delete-or-glide "\\[" "\\]"))
((looking-back "[]]") (shm-delete-or-glide "\\[" "\\]"))
((looking-back "[{}]") (shm-delete-or-glide "{" "}"))
((looking-back "[\"]") (shm-delete-or-glide "\"" "\""))
;; These kind of patterns block the parens of syntaxes that would
;; otherwise break everything, so, "if", "of", "case", "do",
;; etc. if deleted.
((and (shm-prevent-parent-deletion-p)
(looking-back "[^A-Za-z0-9_']do ?")
(shm-nothing-following-p))
nil) ; do nothing
((and (shm-prevent-parent-deletion-p)
(looking-back " <-")
(shm-nothing-following-p))
(forward-char -3))
((and (shm-prevent-parent-deletion-p)
(looking-back " <- ")
(shm-nothing-following-p))
(forward-char -4))
((and (shm-prevent-parent-deletion-p)
(looking-back "[^A-Za-z0-9_]of ?"))
(search-backward-regexp "[ ]*of"))
((and (shm-prevent-parent-deletion-p)
(or (looking-at "of$")
(looking-at "of ")))
(forward-char -1))
((and (shm-prevent-parent-deletion-p)
(looking-back "[_ ]-> ?")) (forward-char -3))
((and (shm-prevent-parent-deletion-p)
(looking-at "-> ?"))
(forward-char -1))
((and (shm-prevent-parent-deletion-p)
(looking-back "[^A-Za-z0-9_]then ?"))
(search-backward-regexp "[^ ][ ]*then")
(unless (or (looking-at "$") (looking-at " "))
(forward-char 1)))
((and (shm-prevent-parent-deletion-p)
(looking-back "[^A-Za-z0-9_]else ?"))
(search-backward-regexp "[^ ][ ]*else")
(unless (or (looking-at "$") (looking-at " "))
(forward-char 1)))
((and (shm-prevent-parent-deletion-p)
(looking-back "^module ?"))
(when (looking-at "[ ]*where$")
(delete-region (line-beginning-position) (line-end-position))))
((and (shm-prevent-parent-deletion-p)
(looking-back "[^A-Za-z0-9_]if ?"))
nil) ; do nothing
((and (shm-prevent-parent-deletion-p)
(looking-back "[^A-Za-z0-9_]case ?"))
nil) ; do nothing
((and (shm-prevent-parent-deletion-p)
(and (looking-at "= ")
(looking-back " ")))
(forward-char -1))
((and (shm-prevent-parent-deletion-p)
(or (and (looking-back " = ")
(not (looking-at "$"))
(not (looking-at " ")))
(and (looking-back "[\w ]=")
(looking-at " "))))
(search-backward-regexp "[ ]+=[ ]*"
(line-beginning-position)
t
1)
(when (looking-back " ")
(when (search-backward-regexp "[^ ]" (line-beginning-position)
t 1)
(forward-char 1))))
;; This is the base case, we assume that we can freely delete
;; whatever we're looking back at, and that the node will be able
;; to re-parse it.
(t (shm-delete-char)
(save-excursion
(shm-appropriate-adjustment-point 'backward)
(shm-adjust-dependents (point) -1))))))
(shm/init t))
(defun shm-prevent-parent-deletion-p ()
"Prevent parent deletion at point?"
(and shm-prevent-parent-deletion
(not (shm-in-string))))
(defun shm-delete-or-glide (open close)
"Delete the given OPEN/CLOSE delimiter, or simply glide over it
if it isn't empty."
(cond
;; If the delimiters are empty, we can delete the whole thing.
((shm-delimiter-empty open close)
(let ((inhibit-read-only t))
(shm-adjust-dependents (point) -2)
(delete-region (1- (point))
(1+ (point)))))
;; If the delimiters aren't empty and we're in a literal, then go
;; ahead and elete the character.
((and (shm-literal-insertion)
(not (= (point) (1+ (shm-node-start (shm-current-node))))))
(shm-delete-char))
;; Otherwise just glide over the character.
(t
(when (looking-back close)
(forward-char -1)))))
(defun shm-delete-char ()
"Delete a character backwards or delete the region, if there is
one active."
(if (region-active-p)
(delete-region (region-beginning)
(region-end))
(delete-region (1- (point))
(point))))
(defun shm-delimiter-empty (open close)
"Is the current expression delimited by OPEN and CLOSE empty?"
(and (looking-back open)
(not (save-excursion (forward-char (* -1 (length open)))
(looking-back "\\\\")))
(looking-at close)))
(defun shm-wrap-delimiters (open close)
"Wrap the current region with the given delimiters. Called when
the region is active."
(let ((beg (region-beginning))
(end (region-end)))
(save-excursion
(goto-char beg)
(save-excursion
(goto-char end)
(shm-insert-string close))
(shm-insert-string open))
(when (= (point) beg)
(forward-char 1))))
(defun shm-delimit (open close)
"Insert the given delimiters.
This is a special function because it will do different things
depending on the context.
If we're in a string, it just inserts OPEN. If we're in an
expression, it will insert OPEN and CLOSE and put the point
between them. It will also space out so that there is space
between previous nodes and the next. E.g.
foo|(bar)
If you hit \" at | then you will get:
foo \"\" (bar)
It saves one having to type spaces; it's obvious what to do
here."
(cond
((region-active-p)
(shm-wrap-delimiters open close))
((and (shm-literal-insertion)
(not (string= open "\"")))
(shm-insert-string open))
(t
(shm/reparse)
(let ((current (shm-actual-node))
(looking-back-regexp "\\(\\(^\\|\\W\\)'\\|[ ,[({\\!]\\)"))
(cond
((shm-find-overlay 'shm-quarantine)
(if (not (or (looking-back looking-back-regexp)
(and (looking-back "\\$")
(string= "(" open))
(bolp)))
(progn (shm-insert-string " ") 1)
0)
(shm-insert-string open)
(let ((point (point)))
(shm-insert-string close)
(when (and (/= (point) (line-end-position))
(not (looking-at "[]){} ,\\]")))
(shm-insert-string " "))
(goto-char point)))
(t
(if (not (or (looking-back looking-back-regexp)
(bolp)))
(progn (shm-insert-string " ") 1)
0)
(shm-insert-string open)
(let ((point (point)))
(shm-insert-string close)
(when (and (/= (point) (line-end-position))
(not (looking-at "[]){} ,!]")))
(shm-insert-string " "))
(goto-char point)
(shm/init t))))))))
(defun shm-auto-insert-stmt (type)
"Insert template
do x <- |
{undefined}
"
(let* ((current (shm-current-node))
(column (save-excursion
(case type
('let (backward-word 1)
(current-column))
('qualifier
(cond
((eq 'Do (shm-node-cons current))
(goto-char (shm-node-start current))
(forward-char 2)
(search-forward-regexp "[^ \n]")
(1- (current-column)))
(t (goto-char (shm-node-start current))
(current-column))))))))
(unless (save-excursion
(let ((current-line (line-number-at-pos)))
(forward-line 1)
(goto-char (+ (line-beginning-position)
column))
(and (not (bolp))
(/= current-line (line-number-at-pos))
(= (point)
(save-excursion (back-to-indentation)
(point))))))
(save-excursion
(insert "\n")
(indent-to column)
(insert "undefined")
(forward-word -1)
(shm/reparse)
(shm-evaporate (point)
(progn (forward-word 1)
(point)))))
(insert " ")))
(defun shm/delete ()
"Delete the current node."
(interactive)
(shm-with-fallback
delete-char
(let ((current (shm-current-node))
(inhibit-read-only t))
(delete-region (shm-node-start current)
(shm-node-end current)))))
(defun shm/export ()
"Export the identifier at point."
(interactive)
(let ((name (shm-node-string (shm-actual-node))))
(save-excursion
(goto-char (point-min))
(search-forward-regexp "^module")
(search-forward-regexp " where")
(search-backward-regexp ")")
(shm/reparse)
(shm/newline-indent)
(insert name))))
(provide 'shm-insert-del)
;; Local variables:
;; byte-compile-warnings: (not cl-functions)
;; End:
shm-1.0.20/shm-layout.el 0000644 0000000 0000000 00000035545 12472572426 013222 0 ustar 00 0000000 0000000 ;;; shm-layout.el --- Layout-sensitive tasks
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-node)
(require 'shm-ast)
(defun shm-appropriate-adjustment-point (direction)
"Go to the appropriate adjustment point.
This is called before calling `shm-adjust-dependents', because some places, e.g.
zoo = do
bar
mu
If the point is at 'z', then we should *not* move 'bar' or 'mu',
even though we normally would. To avoid doing this, we use a very
simple but 90% effective (100% is rather hard, will not be
appearing in a beta version) heuristic. We jump to here:
zoo| = do
bar
mu
And use our normal adjustment test there. After all, only thing
after 'zoo' are *really* dependent."
(unless (eolp)
(let ((current (shm-current-node)))
(case direction
('forward
(when (and current
(< (shm-node-end current) (line-end-position))
(not (and (looking-at " ")
(looking-back " "))))
(goto-char (shm-node-end current))))
('backward
(when (and current
(> (shm-node-start current) (line-beginning-position)))
(goto-char (shm-node-start current))))))))
(defun shm-adjust-dependents (end-point n)
"Adjust dependent lines by N characters that depend on this
line after END-POINT."
(unless (= (line-beginning-position)
(1- (point)))
(let ((line (line-number-at-pos))
(column (current-column)))
(when (and (not (< column (shm-indent-spaces)))
;; I don't remember what this is for. I'm removing
;; it. If it causes problems, I'll deal with it then.
;;
;; (not (and (looking-back "^[ ]+")
;; (looking-at "[ ]*")))
(save-excursion (goto-char end-point)
(forward-word)
(= (line-number-at-pos) line)))
(unless (save-excursion
(goto-char (line-end-position))
(let ((current-pair (shm-node-backwards)))
(when current-pair
(or (string= (shm-node-type-name (cdr current-pair))
"Rhs")
(eq (shm-node-cons (cdr current-pair))
'Lambda)))))
(shm-move-dependents n
end-point))))))
(defun shm-move-dependents (n point)
"Move dependent-with-respect-to POINT lines N characters forwards or backwards.
This is purely based on alignments. If anything is aligned after
the current column, then it's assumed to be a child of whatever
has recently changed at POINT, and thus we 'bring it along'
either forwards or backwards.
The algorithm isn't quite comprehensive, it needs special cases
for top-level functions and things like that."
(save-excursion
(let ((column (progn (goto-char point)
(current-column)))
(point nil)
(end-point nil))
(while (and (= 0 (forward-line 1))
(or (not end-point)
(/= end-point (line-end-position))))
(if (shm-line-indented-past (1+ column))
(progn (unless point
(setq point (goto-char (line-beginning-position))))
(setq end-point (line-end-position)))
(goto-char (point-max))))
(when end-point
(indent-rigidly point end-point n)))))
(defun shm-line-indented-past (n)
"Is the current line indented past N?"
(goto-char (line-beginning-position))
(let ((column (search-forward-regexp "[^ ]" (line-end-position) t 1)))
(if column
(>= (1- (current-column)) n)
t)))
(defun shm-insert-string (string)
"Insert the given string."
(save-excursion
(shm-appropriate-adjustment-point 'forward)
(shm-adjust-dependents (point) (length string)))
(insert string)
(shm/init t))
(defun shm-insert-indented (do-insert &optional no-adjust-dependents)
"Insert, indented in The Right Way. Calls DO-INSERT to do the insertion.
This function assumes a certain semantic meaning towards the
contents of the kill ring. That is,
do bar
mu
Is an expression which, when pasted, into
main =
should yield,
main = do bar
mu
Which is so convenient it changes the way you work. However,
there is also the other case:
do
bar
mu
This is what happens when you have expressions whose children
hang on the underside, and thus pasting these can be done in two
ways: (1) the above way, (2) or like this:
main = do
bar
mu
I.e. take the parent into account and try to re-paste an
underside dangling expression. I don't like this style. With SHM
this style becomes pointless and in fact detrimental. It's much
easier to read and manipulate children who are next to their
parents. But one must compromise and conform to some styles no
matter how poorly reasoned.
We can actually give the option for people to pick and choose
this underside dangling vs not. But that will be implemented as a
separate function rather than hard-coded into this one specific
operation."
(let* ((column (current-column))
(line (line-beginning-position))
(start (point))
(string
(with-temp-buffer
(funcall do-insert)
(buffer-string)))
(swinging
(with-temp-buffer
(insert string)
(get-text-property (point-min) 'shm-swinging-expr)))
(current-node-pair
(when swinging
(shm-current-node-pair)))
(furthest-parent
(when current-node-pair
(shm-find-furthest-parent-on-line current-node-pair))))
(insert (if (shm-in-string)
(replace-regexp-in-string
"\n" "\\\\n\\\\\n\\\\"
string)
string))
(when (and (= line (line-beginning-position))
(not no-adjust-dependents))
(shm-adjust-dependents start (- (current-column)
column)))
(when (= (point) start)
(goto-char (region-end)))
(let ((end (point)))
(cond
(swinging
(when furthest-parent
(let ((node (cdr furthest-parent)))
(goto-char end)
(indent-rigidly start
end
(+ (shm-indent-spaces)
(shm-node-indent-column node))))))
(t (goto-char end)
(indent-rigidly start end column)))
(push-mark)
(goto-char start))))
(defun shm-find-furthest-parent-on-line (current &optional stop-at-rhs)
"Find the parent which starts nearest to column 0 on the
current line.
This is used when indenting dangling expressions."
(if (string= (shm-node-type-name (cdr current)) "Decl")
current
(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 stop-at-rhs)
current)
current))))
(defun shm-indent-spaces ()
"Get the number of spaces to indent."
(if (boundp 'haskell-indent-spaces)
haskell-indent-spaces
shm-indent-spaces))
(defun shm-kill-region (save-it start end do-not-delete)
"Kill the given region, dropping any redundant indentation.
This normalizes everything it kills assuming what has been killed
is a node or set of nodes. Indentation is stripped off and
preserved appropriately so that if we kill e.g.
foo = {do bar
mu}
where {} indicates the current node, then what is put into the kill ring is:
do bar
mu
rather than what is normally put there,
do bar
mu
So this is nice to paste elsewhere outside of Emacs, but it's
especially nice for pasting back into other parts of code,
because the yank function will take advantage of this
normalization and paste and re-indent to fit into the new
location. See `shm/yank' for documentation on that."
(goto-char start)
(let* ((start-col (current-column))
(multi-line (/= (line-beginning-position)
(save-excursion (goto-char end)
(line-beginning-position))))
(string (buffer-substring-no-properties
start
end))
(result
(unless (string= string "")
(with-temp-buffer
(when multi-line
(insert (make-string start-col ? )))
(insert string)
;; This code de-indents code until a single line is
;; hitting column zero.
(let ((indent-tabs-mode nil)
(continue t)
(buffer-max (point-max)))
(while (and continue
(progn (goto-char (point-min))
(not (and (search-forward-regexp "^[^ ]" nil t 1)
(forward-line -1)
;; If there are empty lines, they
;; don't count as hitting column zero.
(if (/= (line-beginning-position)
(line-end-position))
t
;; And we should actually delete empty lines.
(progn (if (bobp)
(delete-region (point) (1+ (point)))
(delete-region (1- (point)) (point)))
nil))))))
;; Bring everything back one.
(unless (= 0 start-col)
(indent-rigidly (point-min) (point-max)
-1))
(if (/= buffer-max (point-max))
(setq buffer-max (point-max))
(setq continue nil))))
;; If there's an empty line at the end, then strip that
;; out. It's just bothersome when pasting back in.
(goto-char (point-max))
(when (looking-at "^$")
(delete-region (1- (point))
(point)))
(when (> (count-lines (point-min)
(point-max))
1)
(let* ((first-line-col (save-excursion (goto-char (point-min))
(back-to-indentation)
(current-column)))
(second-line-col (save-excursion (goto-char (point-min))
(forward-line)
(back-to-indentation)
(current-column))))
(when (> first-line-col second-line-col)
(goto-char (point-min))
(indent-rigidly (line-beginning-position)
(line-end-position)
(- first-line-col))
(put-text-property (point-min)
(point-max)
'shm-swinging-expr
t))))
;; Finally, the actual save.
(funcall (if save-it save-it 'clipboard-kill-ring-save)
(point-min)
(point-max))))))
(let ((inhibit-read-only t))
(unless do-not-delete
(delete-region start
end)))
result))
(defun shm-kill-to-end-of-line (&optional prepend-newline)
"Kill everything possible to kill after point before the end of
the line."
(let* ((vector (shm-decl-ast))
(current-pair (shm-current-node-pair))
(current (cdr current-pair))
(parent-pair (shm-node-ancestor-for-kill current-pair (point)))
(parent (cdr parent-pair)))
(loop for i
from 0
to (length vector)
until (or (>= i (length vector))
(let ((node (elt vector i)))
(and (>= (shm-node-start node)
(shm-node-start parent))
(<= (shm-node-end node)
(shm-node-end parent)))))
finally (return
(let ((last-command (if prepend-newline 'kill-region last-command)))
(when prepend-newline
(kill-append "\n" nil))
(if (< i (length vector))
(shm-kill-node 'clipboard-kill-ring-save
parent
(point))
(let ((line-end-position (if prepend-newline
(save-excursion (forward-line)
(line-end-position))
(line-end-position))))
(when (= (point)
line-end-position)
(kill-region (point)
line-end-position)))))))))
(defun shm-node-ancestor-for-kill (current-pair point)
"Get the ancestor for greedy killing."
(let* ((current (cdr current-pair))
(parent-pair (shm-node-parent current-pair))
(parent (cdr parent-pair)))
(if (and (shm-node-app-p parent)
(< (shm-node-end current) (line-end-position)))
parent-pair
(shm-node-ancestor-at-point current-pair point))))
(defun shm-kill-node (&optional save-it node start do-not-delete)
"Kill the current node.
See documentation of `shm-kill-region' for the transformations
this does."
(interactive)
(let* ((current (or node (shm-current-node))))
(shm-kill-region save-it
(or start (shm-node-start current))
(shm-node-end current)
do-not-delete)))
(provide 'shm-layout)
shm-1.0.20/shm-macros.el 0000644 0000000 0000000 00000002365 12472572426 013163 0 ustar 00 0000000 0000000 ;;; shm-macros.el --- Macros
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(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))))))
(provide 'shm-macros)
shm-1.0.20/shm-manipulation.el 0000644 0000000 0000000 00000020701 12472572426 014371 0 ustar 00 0000000 0000000 ;;; shm-manipulation.el --- Manipulation of nodes commands
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-layout)
(defun shm/$ ()
"Swap parens with a dollar."
(interactive)
(let* ((current-pair (shm-current-node-pair))
(current (cdr current-pair)))
(if (eq (shm-node-cons current) 'Paren)
(progn (let ((child (shm-node-child current-pair)))
(shm-raise-to child current)
(if (looking-back " ")
nil
(shm-insert-string " "))
(shm-insert-string "$")
(if (looking-at " ")
nil
(shm-insert-string " ")))))))
(defun shm/add-operand ()
"When in an infix application, figure out the operator and add
a new operand. E.g.
foo <> bar|
will give you
foo <> bar <> |
or
foo <> |bar
will give you
foo <> | <> bar
This is more convenient than typing out the same operator."
(interactive)
(let* ((current-pair (shm-current-node-pair))
(current (cdr current-pair))
(parent-pair (shm-node-parent current-pair))
(parent (cdr parent-pair)))
(cond
((eq 'InfixApp (shm-node-cons parent))
(let ((qop
(or (shm-get-qop-string (cdr (shm-node-previous current-pair)))
(shm-get-qop-string (cdr (shm-node-next current-pair))))))
(cond
(qop
(cond
((= (point) (shm-node-start current))
(let ((point (point)))
(shm-insert-string (concat " " qop " "))
(goto-char point)))
((= (point) (shm-node-end current))
(shm-insert-string (concat " " qop " ")))
(t (error "Please go to the start or end of the node to indicate direction."))))
(t (error "Unable to figure out the operator.")))))
((string= "Type" (shm-node-type-name current))
(if (= (point) (shm-node-start current))
(save-excursion (insert " -> "))
(insert " -> ")))
(t (error "Not in an infix application.")))))
(defun shm/raise ()
"Raise the expression up one, replacing its parent."
(interactive)
(let* ((current-pair (shm-current-node-pair))
(current (cdr current-pair))
(parent-pair (shm-node-parent current-pair (shm-node-type current)))
(parent (cdr parent-pair))
(actual-parent-pair (shm-node-parent current-pair)))
(cond
((and parent
(or (shm-node-app-p current)
(eq (shm-node-cons current) 'TyFun))
(shm-node-paren-p parent))
(let* ((grandparent-pair (shm-node-parent parent-pair (shm-node-type current)))
(grandparent (cdr grandparent-pair)))
(when grandparent
(shm-raise-to current grandparent))))
(parent
(when (string= (shm-node-type current)
(shm-node-type parent))
(shm-raise-to current parent)))
((and (eq 'UnGuardedRhs (shm-node-cons (cdr actual-parent-pair)))
(eq 'Lambda (shm-node-cons current)))
(goto-char (shm-node-start current))
(delete-char 1)
(delete-region (point)
(search-backward-regexp "[ ]+=[ ]+"))
(insert " ")
(search-forward-regexp "[ ]*->")
(delete-region (- (point) 2)
(search-forward-regexp "[ ]+"))
(insert "= "))
(t
(error "No matching parent!")))))
(defun shm-raise-to (current parent)
"Raise the current node and replace PARENT."
(let ((shm/raise-code (shm-kill-node 'buffer-substring-no-properties current nil t)))
(shm-kill-node 'buffer-substring-no-properties parent)
(shm-insert-indented (lambda () (insert shm/raise-code)))
(shm/reparse)))
(defun shm/splice ()
"Splice the current children wrapped in parens into the parent.
foo (a b c) -> foo a b c
Only parenthesized nodes are supported at the moment."
(interactive)
(let* ((current-pair (shm-current-node-pair))
(current (cdr current-pair))
(parent-pair (shm-node-parent current-pair))
(parent (cdr parent-pair)))
(if (and parent (shm-node-paren-p parent))
(shm-raise-to current parent)
(message "Unsupported node type for splicing!"))))
(defun shm/split-list ()
"Split the current list into two lists by the nearest comma."
(interactive)
(let ((current-pair (shm-current-node-pair)))
(while (not (eq 'List (shm-node-cons (cdr (shm-node-parent current-pair)))))
(setq current-pair (shm-node-parent current-pair)))
(let ((current (cdr current-pair)))
(cond
((< (abs (- (point) (shm-node-start current)))
(abs (- (point) (shm-node-end current))))
(goto-char (shm-node-start current))
(when (looking-back ",")
(delete-char -1)))
(t
(goto-char (shm-node-end current))
(when (looking-at ",")
(delete-char 1))))
(insert "] ["))))
(defun shm/comment ()
"Comment the current node, or if there is none, or some error,
fall back to `comment-dwim'. If the region is active, uses
`comment-dwim'."
(interactive)
(if (region-active-p)
(call-interactively 'comment-dwim)
(let ((current (shm-current-node)))
(cond
((shm-in-comment)
(save-excursion
(unless (looking-at "{-")
(search-backward-regexp "{-" nil nil 1))
(delete-region (point) (+ 2 (point)))
(search-forward-regexp "-}" nil nil 1)
(delete-region (- (point) 2) (point))))
(current
(save-excursion
(goto-char (shm-node-start current))
(insert "{-")
(goto-char (shm-node-end current))
(insert "-}")
(font-lock-fontify-region (shm-node-start current)
(shm-node-end current))))
(t (call-interactively 'comment-dwim))))))
(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/bind-toggle ()
"Swap the monadicness of a bind."
(interactive)
(let ((node (shm-get-binding-parent (shm-current-node-pair))))
(case (shm-node-cons node)
(Generator (progn (goto-char (shm-node-start node))
(search-forward " <- ")
(delete-region (- (point) (length " <- "))
(point))
(insert " = ")
(goto-char (shm-node-start node))
(shm-insert-string "let ")))
(LetStmt (progn (goto-char (shm-node-start node))
(delete-region (point) (+ (point) (length "let ")))
(search-forward " = ")
(delete-region (- (point) (length " = "))
(point))
(insert " <- "))))))
(defun shm-get-binding-parent (node-pair)
"Get the binding parent of the node."
(if (or (eq 'Generator (shm-node-cons (cdr node-pair)))
(eq 'LetStmt (shm-node-cons (cdr node-pair))))
(cdr node-pair)
(let ((parent-pair (shm-node-parent node-pair)))
(if parent-pair
(shm-get-binding-parent parent-pair)
(error "Couldn't find a let/generator statement in the node's parents.")))))
(provide 'shm-manipulation)
shm-1.0.20/shm-nav.el 0000644 0000000 0000000 00000011475 12472572426 012465 0 ustar 00 0000000 0000000 ;;; shm-nav.el --- Navigation commands
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-macros)
(require 'shm-layout)
(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/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))
(insert "\n"))
(let ((indent (shm-node-start-column
(cdr (shm-node-parent (cons i rhs))))))
(indent-to (+ 2 indent))
(insert "where")
(if shm-indent-point-after-adding-where-clause
(progn
(insert "\n")
(indent-to (+ 4 indent)))
(insert " ")))))))))))
(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))))
(progn (goto-char (shm-node-end current))
(setq shm-last-point (point))))))
(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))))
(progn (goto-char (shm-node-start current))
(setq shm-last-point (point))))))
(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)))))
(provide 'shm-nav)
shm-1.0.20/shm-node.el 0000644 0000000 0000000 00000006562 12472572426 012627 0 ustar 00 0000000 0000000 ;;; shm-node.el --- Node functions
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-customizations)
(require 'shm-ast-documentation)
(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-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-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-node-start-column (n)
"Get the starting column of N."
(save-excursion (goto-char (shm-node-start n))
(current-column)))
(defun shm-node-start-line (n)
"Get the starting line of N."
(save-excursion (goto-char (shm-node-start n))
(line-number-at-pos)))
(defun shm-node-indent-column (n)
"Get the starting column of N."
(+ (shm-node-start-column n)
(if (or (string= "Tuple" (shm-node-cons n))
(string= "Paren" (shm-node-cons n))
(string= "List" (shm-node-cons n)))
1
0)))
(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-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-string (n)
"Get the string of the region spanned by the node."
(buffer-substring-no-properties (shm-node-start n)
(shm-node-end n)))
(defun shm-node-app-p (node)
"Is the given node an application of some kind?"
(or (eq (shm-node-cons node) 'App)
(eq (shm-node-cons node) 'InfixApp)
(eq (shm-node-cons node) 'TyApp)))
(defun shm-node-paren-p (node)
"Is the given node a paren of some kind?"
(or (eq (shm-node-cons node) 'Paren)
(eq (shm-node-cons node) 'PParen)
(eq (shm-node-cons node) 'TyParen)))
(provide 'shm-node)
shm-1.0.20/shm-overlays.el 0000644 0000000 0000000 00000004335 12472572426 013542 0 ustar 00 0000000 0000000 ;;; shm-overlays.el --- 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 .
;;; Code:
(require 'cl)
(require 'shm-node)
(defvar shm-current-node-overlay nil
"Overlay to highlight the current node.")
(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.")
(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-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-find-overlay (type)
"Find overlays at point."
(remove-if-not (lambda (o) (overlay-get o type))
(overlays-in (point-min) (point-max))))
(provide 'shm-overlays)
;; Local variables:
;; byte-compile-warnings: (not cl-functions)
;; End:
shm-1.0.20/shm-pkg.el 0000644 0000000 0000000 00000000602 12472572426 012450 0 ustar 00 0000000 0000000 (define-package "shm" "1.0.20" "Structured Haskell Mode" 'nil :commit "8abc5cd73e59ea85bef906e14e87dc388c4f350f" :authors
'(("Chris Done" . "chrisdone@gmail.com"))
:maintainers
'(("Chris Done" . "chrisdone@gmail.com"))
:maintainer
'("Chris Done" . "chrisdone@gmail.com")
:keywords
'("development" "haskell" "structured"))
;; Local Variables:
;; no-byte-compile: t
;; End:
shm-1.0.20/shm-reformat.el 0000644 0000000 0000000 00000002425 12472572426 013513 0 ustar 00 0000000 0000000 ;;; shm-reformat.el ---
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-ast)
(require 'hindent)
(defun shm-reformat-decl ()
"Reformat the current declaration with `hindent/reformat-decl'
and then jump back to the right node."
(interactive)
(let* ((current-pair (shm-current-node-pair))
(index (car current-pair))
(offset (- (point) (shm-node-start (cdr current-pair)))))
(structured-haskell-mode -1)
(hindent/reformat-decl)
(structured-haskell-mode 1)
(shm/reparse)
(let ((new-current (elt (shm-decl-ast) index)))
(goto-char (+ (shm-node-start new-current) offset)))))
(provide 'shm-reformat)
shm-1.0.20/shm-simple-indent.el 0000644 0000000 0000000 00000010410 12472572426 014435 0 ustar 00 0000000 0000000 ;;; shm-simple-indent.el --- Simple indentation
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-layout)
(defun shm/simple-indent ()
"Space out to under next visible indent point.
Indent points are positions of non-whitespace following whitespace in
lines preceeding point. A position is visible if it is to the left of
the first non-whitespace of every nonblank line between the position and
the current line. If there is no visible indent point beyond the current
column, `tab-to-tab-stop' is done instead."
(interactive)
(let* ((start-column (current-column))
(invisible-from nil) ; `nil' means infinity here
(indent
(catch 'shm-simple-indent-break
(save-excursion
(while (progn (beginning-of-line)
(not (bobp)))
(forward-line -1)
(if (not (looking-at "[ \t]*\n"))
(let ((this-indentation (current-indentation)))
(if (or (not invisible-from)
(< this-indentation invisible-from))
(if (> this-indentation start-column)
(setq invisible-from this-indentation)
(let ((end (line-beginning-position 2)))
(move-to-column start-column)
;; Is start-column inside a tab on this line?
(if (> (current-column) start-column)
(backward-char 1))
(or (looking-at "[ \t]")
(skip-chars-forward "^ \t" end))
(skip-chars-forward " \t" end)
(let ((col (current-column)))
(throw 'shm-simple-indent-break
(if (or (= (point) end)
(and invisible-from
(> col invisible-from)))
invisible-from
col)))))))))))))
(if indent
(let ((opoint (point-marker)))
(indent-line-to indent)
(if (> opoint (point))
(goto-char opoint))
(set-marker opoint nil))
(tab-to-tab-stop))))
(defun shm/simple-indent-backtab ()
"Indent backwards. Dual to `shm-simple-indent'."
(interactive)
(let ((current-point (point))
(i 0)
(x 0))
(goto-char (line-beginning-position))
(save-excursion
(while (< (point) current-point)
(shm/simple-indent)
(setq i (+ i 1))))
(while (< x (- i 1))
(shm/simple-indent)
(setq x (+ x 1)))))
(defun shm/simple-indent-newline-same-col ()
"Make a newline and go to the same column as the current line."
(interactive)
(let ((point (point)))
(let ((start-end
(save-excursion
(let* ((start (line-beginning-position))
(end (progn (goto-char start)
(search-forward-regexp
"[^ ]" (line-end-position) t 1))))
(when end (cons start (1- end)))))))
(if start-end
(progn (insert "\n")
(insert (buffer-substring-no-properties
(car start-end) (cdr start-end))))
(insert "\n")))))
(defun shm/simple-indent-newline-indent ()
"Make a newline on the current column and indent on step."
(interactive)
(shm/simple-indent-newline-same-col)
(insert (make-string (shm-indent-spaces) ? )))
(provide 'shm-simple-indent)
shm-1.0.20/shm-slot.el 0000644 0000000 0000000 00000016530 12472572426 012657 0 ustar 00 0000000 0000000 ;;; shm-slot.el --- Slots for shm
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-evaporate)
(require 'shm-layout)
(require 'cl)
(defun shm/jump-to-slot ()
"Jump to the next skeleton slot."
(interactive)
(let ((os (sort (remove-if-not (lambda (o) (overlay-get o 'shm-evaporate-overlay))
(overlays-in (point) (point-max)))
(lambda (a b)
(< (overlay-start a)
(overlay-start b))))))
(when os
(if (= (overlay-start (car os))
(point))
(when (cadr os)
(goto-char (overlay-start (cadr os))))
(goto-char (overlay-start (car os)))))))
(defun shm/jump-to-previous-slot ()
"Jump to the previous skeleton slot."
(interactive)
(let ((os (sort (remove-if-not (lambda (o) (overlay-get o 'shm-evaporate-overlay))
(overlays-in (point-min) (point)))
(lambda (a b)
(> (overlay-start a)
(overlay-start b))))))
(when os
(if (= (overlay-start (car os))
(point))
(when (cadr os)
(goto-char (overlay-start (cadr os))))
(goto-char (overlay-start (car os)))))))
(defun shm/insert-undefined ()
"Insert undefined."
(interactive)
(let ((point (point)) (bumped nil))
(when (and (looking-back "[^[({;, ]")
(not (bolp)))
(shm-insert-string " ")
(setq point (1+ point)))
(when (and (looking-at "[^])},; ]+_*")
(not (eolp)))
(shm-insert-string " ")
(forward-char -1))
(shm-insert-string "undefined")
(shm-evaporate point (point))
(goto-char point)))
(defun shm/insert-underscore ()
"Insert underscore."
(interactive)
(save-excursion
(let ((point (point)))
(when (looking-back "[a-zA-Z0-9]+_*")
(shm-insert-string " "))
(when (looking-at "[a-zA-Z0-9]+_*")
(shm-insert-string " ")
(forward-char -1))
(shm-insert-string "_")
(shm-evaporate point (point)))))
(defun shm-auto-insert-lambda ()
"Insert template
\_ -> undefined
"
(save-excursion
(shm/insert-underscore)
(forward-char)
(insert " -> ")
(shm/insert-undefined)))
(defun shm-auto-insert-do ()
"Insert template
do {undefined}
{undefined}
"
(insert " ")
(let ((point (point))
(column (current-column)))
(insert "undefined")
(cond
((bound-and-true-p structured-haskell-repl-mode)
(forward-word -1)
(shm/reparse)
(save-excursion
(shm-evaporate (point) (+ (point) (length "undefined")))))
(t (insert "\n")
(indent-to column)
(let ((next-point (point)))
(insert "undefined")
(goto-char point)
(shm/reparse)
(save-excursion
(shm-evaporate (point) (+ (point) (length "undefined")))
(goto-char next-point)
(shm-evaporate (point) (+ (point) (length "undefined")))))))))
(defun shm-auto-insert-case ()
"Insert template
case {undefined} of
{_} -> {undefined}
"
(let ((start (save-excursion (forward-char -1)
(search-backward-regexp "[^a-zA-Z0-9_]")
(forward-char 1)
(point)))
(template (if (bound-and-true-p structured-haskell-repl-mode)
"case undefined of _ -> undefined"
"case undefined of\n _ -> undefined")))
(shm-adjust-dependents (point) (- start (point)))
(delete-region start (point))
(shm-adjust-dependents (point) (length (car (last (split-string template "\n")))))
(shm-insert-indented
(lambda ()
(insert template)))
(forward-char 5)
(shm/reparse)
(save-excursion
(shm-evaporate (point) (+ (point) (length "undefined")))
(search-forward-regexp "_" nil nil 1)
(shm-evaporate (1- (point)) (point))
(forward-char 4)
(shm-evaporate (point) (+ (point) (length "undefined"))))))
(defun shm-auto-insert-if ()
"Insert template
if {undefined}
then {undefined}
else {undefined}
or
if {undefined} then {undefined} else {undefined}
if inside parentheses."
(let ((start (save-excursion (forward-char -1)
(search-backward-regexp "[^a-zA-Z0-9_]")
(forward-char 1)
(point)))
(template (if (bound-and-true-p structured-haskell-repl-mode)
"if undefined then undefined else undefined"
"if undefined\n then undefined\n else undefined")))
(shm-adjust-dependents (point) (- start (point)))
(delete-region start (point))
(shm-adjust-dependents (point) (length (car (last (split-string template "\n")))))
(shm-insert-indented
(lambda ()
(insert template)))
(forward-char 3)
(save-excursion
(shm-evaporate (point) (+ (point) (length "undefined")))
(search-forward-regexp "then ")
(shm-evaporate (point) (+ (point) (length "undefined")))
(search-forward-regexp "else ")
(shm-evaporate (point) (+ (point) (length "undefined"))))))
(defun shm-auto-insert-let ()
"Insert template
let | in {undefined}"
(delete-region (- (point) 3) (point))
;; If needs to be nested this way. Don't change it.
(let
((evaporate-in (lambda ()
(forward-char 4)
(save-excursion
(forward-word)
(forward-char 1)
(shm-evaporate (point) (+ (point) (length "undefined")))))))
(if (bound-and-true-p structured-haskell-repl-mode)
(let ((points (shm-decl-points)))
(if points
(if (= (point) (car points))
(progn (shm-insert-indented
(lambda () (insert "let _ = undefined")))
(search-forward "_")
(shm-evaporate (1- (point)) (point))
(forward-word 1)
(forward-word -1)
(shm-evaporate (point) (+ (point) (length "undefined")))
(search-backward "_"))
(progn (shm-insert-indented
(lambda () (insert "let in undefined")))
(funcall evaporate-in)))
(insert "let ")))
(progn (shm-insert-indented
(lambda () (insert "let \nin undefined")))
(funcall evaporate-in))))
(shm/reparse))
(defun shm-auto-insert-module ()
"Insert template
module | where"
(insert " where")
(backward-word 1)
(forward-char -1))
(provide 'shm-slot)
;; Local variables:
;; byte-compile-warnings: (not cl-functions)
;; byte-compile-warnings: (not cl-macros)
;; End:
shm-1.0.20/shm-test.el 0000644 0000000 0000000 00000013112 12472572426 012646 0 ustar 00 0000000 0000000 ;;; shm-test.el --- Testing suite
;; 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 .
;;; Commentary:
;; Simple test writing and running suite.
;;; Code:
(require 'shm-tests)
(require 'shm)
(defvar shm-test-eob nil)
(defun shm-test/run-all ()
"Run all tests."
(interactive)
(setq shm-colon-enabled t)
(when (remove-if-not #'identity
(mapcar #'shm-test/run shm-tests))
(message "All tests passed OK.")))
(defun shm-test/new ()
"Make a new SHM test."
(interactive)
(switch-to-buffer (get-buffer-create "*shm-test*"))
(let ((map (make-composed-keymap shm-map)))
(define-key map (kbd "C-c C-c") 'shm-test/continue)
(use-local-map map))
(structured-haskell-mode t)
(when (fboundp 'god-local-mode)
(god-local-mode -1))
(erase-buffer)
(insert "\n")
(setq shm-test-eob (set-marker (make-marker) (point)))
(insert "-- Steps to create a test\n"
"-- \n"
"-- 1. Insert the test-case setup code.\n"
"-- 2. Move the cursor to the starting point.\n"
"-- 3. Hit C-c C-c to record cursor position.\n"
"-- 4. Press F3 to begin recording the test actions.\n"
"-- 5. Do the action.\n"
"-- 6. Hit F4 to complete the action and run C-c C-c.\n"
"--\n")
(goto-char (point-min)))
(defun shm-test/continue ()
"Save the cursor position in the test."
(interactive)
(message "last-command: %S" last-command)
(cond
((eq last-command
'kmacro-end-or-call-macro)
(let ((point (point)))
(save-excursion
(goto-char (point-max))
(insert
(format ":finish-cursor %d\n" point)
(format ":current-node-overlay '%S\n"
(let ((o shm-current-node-overlay))
(if o
(list (overlay-start o)
(overlay-end o))
nil)))
(format ":end-buffer-content %S\n"
(buffer-substring-no-properties
(point-min) (marker-position shm-test-eob)))))
(goto-char (point-max))
(let ((point (point)))
(call-interactively 'insert-kbd-macro)
(eval (buffer-substring-no-properties point (point)))
(delete-region point (point))
(insert (format ":kbd %S)" last-kbd-macro))
(shm-test/save))))
(t
(let ((point (point)))
(save-excursion
(goto-char (point-max))
(insert
"(list "
(format ":name %S\n" (read-from-minibuffer "Name: "))
(format ":start-buffer-content %S\n"
(buffer-substring-no-properties
(point-min) (marker-position shm-test-eob)))
(format ":start-cursor %d\n" point)))))))
(defun shm-test/save ()
"Save the test to a lisp expression."
(emacs-lisp-mode)
(let ((point (point)))
(backward-sexp)
(let ((string (buffer-substring-no-properties point (point))))
(erase-buffer)
(insert string)
(indent-region (point-min)
(point-max))
(backward-sexp))))
(defun shm-test/wait ()
"Wait for a second."
(interactive)
(sit-for 1))
(defun shm-test/run (test)
"Run the given test and validate it."
(message "Testing %s..." (plist-get test :name))
(switch-to-buffer-other-window (get-buffer-create "*shm-test*"))
(erase-buffer)
(kill-all-local-variables)
(when (fboundp 'god-local-mode)
(god-local-mode -1))
(let ((customizations (plist-get test :customizations)))
(when customizations
(dolist (entry customizations)
(set (make-local-variable (car entry))
(cdr entry)))))
(structured-haskell-mode 1)
(insert (plist-get test :start-buffer-content))
(goto-char (plist-get test :start-cursor))
(shm/reparse)
(execute-kbd-macro (plist-get test :kbd))
(shm-test-validate test)
(shm-mode-stop))
(defun shm-test-validate (test)
"Validate the given test."
(let ((name (plist-get test :name)))
(let ((actual (buffer-substring-no-properties (point-min) (point-max)))
(expected (plist-get test :end-buffer-content)))
(unless (string= actual expected)
(error "\nTest failed, differing buffer contents.
Original:
%s
Expected (quoted):
%s
Actual (quoted):
%s\n"
(plist-get test :start-buffer-content)
(shm-test-exact-quote expected)
(shm-test-exact-quote actual))))
(let ((actual (point))
(expected (plist-get test :finish-cursor)))
(unless (= actual expected)
(error "\nTest failed, differing cursor positions.
Expected:
%d
Actual:
%d\n"
expected actual))))
(kill-buffer)
t)
(defun shm-test-exact-quote (s)
"Quote a string exactly, so you can see any details or differences in whitespace."
(mapconcat 'identity
(mapcar (lambda (l)
(concat "\"" l "\""))
(split-string s "\n"))
"\n"))
(provide 'shm-test)
;;; shm-test.el ends here
;; Local Variables:
;; byte-compile-warnings: (not cl-functions)
;; End:
shm-1.0.20/shm-tests.el 0000644 0000000 0000000 00000040742 12472572426 013042 0 ustar 00 0000000 0000000 ;;; shm.el --- Tests for structured-haskell-mode
;; Copyright (c) 2013 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 .
;;; Commentary:
;; A big list of tests.
;;; Code:
(defvar shm-tests-that-dont-run-in-batch-mode
(list
(list :name "swinging-expr-yanking"
:start-buffer-content "main = do
x
z
y
foo = undefined
"
:start-cursor 8
:finish-cursor 17
:current-node-overlay '(17 31)
:end-buffer-content "main = a
foo = do
x
z
y
"
:kbd [134217739 97 1 14 14 6 6 6 6 6 6 delete 25])
(list :name "yanking"
:start-buffer-content "main = (case undefined of
_ -> undefined
,putStrLn (if undefined
then undefined
else undefined)
,23 * 45)
"
:start-cursor 9
:finish-cursor 9
:current-node-overlay '(9 11)
:end-buffer-content "main = (23 * 45
,putStrLn (if undefined
then undefined
else undefined)
,case undefined of
_ -> undefined)
"
:kbd "\371\371\371\371\371\371")))
(defvar shm-tests
(list
(list :name "inserting after '"
:start-buffer-content "x = [foo'
,()]
"
:start-cursor 6
:finish-cursor 22
:current-node-overlay '(19 24)
:end-buffer-content "x = [foo' []
,('[])]
"
:kbd "[,(
'[")
(list :name "don't re-indent dependent rhs"
:start-buffer-content "foo bar baz =
bar + baz
"
:start-cursor 4
:finish-cursor 9
:current-node-overlay '(1 9)
:end-buffer-content "foohello bar baz =
bar + baz
"
:kbd "hello")
(list :name "add-initial-type-constraint"
:start-buffer-content "fn :: a -> b
"
:start-cursor 13
:finish-cursor 7
:current-node-overlay '(7 12)
:end-buffer-content "fn :: => a -> b
"
:kbd [41 134217848 115 104 109 47 109 111 100 tab return])
(list :name "add-additional-type-constraint-no-parens"
:start-buffer-content "fn :: Eq a => a -> a
"
:start-cursor 21
:finish-cursor 14
:current-node-overlay '(11 15)
:end-buffer-content "fn :: (Eq a, ) => a -> a
"
:kbd [41 41 134217848 115 104 109 47 109 111 tab return])
(list :name "add-addtional-type-constraint-parens"
:start-buffer-content "fn :: (Ord s, Eq a, Monad m) => StateT s m a
"
:start-cursor 45
:finish-cursor 30
:current-node-overlay '(27 30)
:end-buffer-content "fn :: (Ord s, Eq a, Monad m, ) => StateT s m a
"
:kbd [41 41 134217848 115 104 109 47 109 111 tab return])
(list :name "newline-indent-type-sig-arrows"
:start-buffer-content "outputWith :: Show a => String -> String -> String -> IO ()
"
:start-cursor 22
:finish-cursor 56
:current-node-overlay '(37 84)
:end-buffer-content "outputWith :: Show a \n => String \n -> String -> String -> IO ()
"
:kbd "
\346
")
(list :name "newline-indent-type-sig"
:start-buffer-content "outputWith :: String -> String -> String -> IO ()
"
:start-cursor 25
:finish-cursor 40
:current-node-overlay '(40 46)
:end-buffer-content "outputWith :: String -> \n String -> String -> IO ()
"
:kbd "
")
(list :name "qualify-import"
:start-buffer-content "import qualified Data.Conduit.List as CL
"
:start-cursor 31
:finish-cursor 31
:current-node-overlay '(18 35)
:end-buffer-content "import qualified Data.Conduit.List as CL
"
:kbd "")
(list :name "split-list"
:start-buffer-content "main = print [foo,bar,mu]
"
:start-cursor 19
:finish-cursor 21
:current-node-overlay '(21 24)
:end-buffer-content "main = print [foo] [bar,mu]
"
:kbd [134217848 115 104 109 47 115 112 108 105 116 45 108 105 115 116 return])
(list :name "wrap-delimiters"
:start-buffer-content "main = do bar
mu
zot
"
:start-cursor 8
:finish-cursor 9
:current-node-overlay '(9 44)
:end-buffer-content "main = [do bar
mu
zot]
"
:kbd [201326624 91])
(list :name "move-by-paragraphs"
:start-buffer-content "clockOut config project task reason = foo
-- | Clock in or out.
clock :: Config -> Entry -> IO ()
"
:start-cursor 1
:finish-cursor 1
:current-node-overlay '(1 9)
:end-buffer-content "clockOut config project task reason = foo
-- | Clock in or out.
clock :: Config -> Entry -> IO ()
"
:kbd "\375\375\375\375\375\373\373\373\373\373")
(list :name "skip-trailing-comments"
:start-buffer-content "foo = do foo
let bar = 23
bob = 23
-- bar
-- test
bar
"
:start-cursor 23
:finish-cursor 57
:current-node-overlay '(55 57)
:end-buffer-content "foo = do foo
let bar = 23
bob = 23
-- bar
-- test
bar
"
:kbd "\206")
(list :name "kill-with-whitespace"
:start-buffer-content "foo = 123
bar = 123
mu = 123
"
:start-cursor 11
:finish-cursor 22
:current-node-overlay '(22 25)
:end-buffer-content "foo = 123
mu = 123
bar = 123
"
:kbd [67108896 14 5 23 4 14 5 return return 25])
(list :name "space-reindent"
:start-buffer-content "main = do let x = 123
undefined
"
:start-cursor 5
:finish-cursor 6
:current-node-overlay '(1 6)
:end-buffer-content "main = do let x = 123
undefined
"
:kbd " ")
(list :name "goto-parent"
:end-buffer-content "main = x
"
:start-cursor 9
:finish-cursor 6
:current-node-overlay '(6 9)
:start-buffer-content "main = x
"
:kbd "\341")
(list :name "goto-parent-in-do-notation"
:end-buffer-content "main = do return ()
print ()
"
:start-cursor 39
:finish-cursor 8
:current-node-overlay '(8 39)
:start-buffer-content "main = do return ()
print ()
"
:kbd "\341\341")
(list :name "goto-parent-end"
:end-buffer-content "main = return ()
"
:start-cursor 16
:finish-cursor 17
:current-node-overlay '(8 17)
:start-buffer-content "main = return ()
"
:kbd ")")
(list :name "goto-parent-in-function-application"
:start-buffer-content "main = foo bar mu zot
"
:start-cursor 19
:finish-cursor 8
:current-node-overlay '(8 22)
:end-buffer-content "main = foo bar mu zot
"
:kbd "\341")
(list :name "newline-indent-in-do"
:end-buffer-content "main = do foo bar
mu zot
"
:start-cursor 18
:finish-cursor 35
:current-node-overlay '(32 35)
:start-buffer-content "main = do foo bar
"
:kbd ")
mu zot")
(list :name "make-string"
:start-buffer-content "main = putStrLn
"
:start-cursor 16
:finish-cursor 18
:current-node-overlay '(17 19)
:end-buffer-content "main = putStrLn \"\"
"
:kbd "\"")
(list :name "in-string-delete-empty"
:start-buffer-content "main = putStrLn \"\"
"
:start-cursor 18
:finish-cursor 16
:current-node-overlay 'nil
:end-buffer-content "main = putStrLn
"
:kbd [backspace backspace])
(list :name "open-double-quote"
:start-buffer-content "main = return"
:start-cursor 14
:finish-cursor 16
:current-node-overlay '(15 17)
:end-buffer-content "main = return ()"
:kbd "(")
(list :name "wrap-parens"
:start-buffer-content "main = return
"
:start-cursor 8
:finish-cursor 9
:current-node-overlay '(9 15)
:end-buffer-content "main = (return)
"
:kbd "\250")
(list :name "open-bracket"
:start-buffer-content "main = print
"
:start-cursor 13
:finish-cursor 15
:current-node-overlay '(14 16)
:end-buffer-content "main = print []
"
:kbd "[")
(list :name "delete-parens"
:start-buffer-content "main = ()"
:start-cursor 9
:finish-cursor 8
:current-node-overlay '(8 8)
:end-buffer-content "main = "
:kbd [backspace])
(list :name "delete-brackets"
:start-buffer-content "main = []"
:start-cursor 9
:finish-cursor 8
:current-node-overlay '(8 8)
:end-buffer-content "main = "
:kbd [backspace])
(list :name "delete-braces"
:start-buffer-content "main = {}"
:start-cursor 9
:finish-cursor 8
:current-node-overlay '(8 8)
:end-buffer-content "main = "
:kbd [backspace])
(list :name "open-brace"
:start-buffer-content "foo = Foo
"
:start-cursor 10
:finish-cursor 12
:current-node-overlay '(7 13)
:end-buffer-content "foo = Foo {}
"
:kbd "{")
(list :name "comma-in-list"
:start-buffer-content "main = print [foo]
"
:start-cursor 18
:finish-cursor 36
:current-node-overlay '(33 36)
:end-buffer-content "main = print [foo
,bar]
"
:kbd "
bar")
(list :name "new-list-item-on-single-line"
:start-buffer-content "main = print [a,b,c]
"
:start-cursor 20
:finish-cursor 36
:current-node-overlay '(35 36)
:end-buffer-content "main = print [a,b,c
,x]
"
:kbd "
x")
(list :name "newline-indent-function-app"
:start-buffer-content "main = foo bar
"
:start-cursor 15
:finish-cursor 30
:current-node-overlay '(27 30)
:end-buffer-content "main = foo bar
zot
"
:kbd "
zot")
(list :name "delete-node"
:start-buffer-content "main = do return ()
"
:start-cursor 19
:finish-cursor 17
:current-node-overlay '(11 17)
:end-buffer-content "main = do return
"
:kbd [delete backspace])
(list :name "kill-line"
:start-buffer-content "main = do putStrLn (f bar mu)
"
:start-cursor 21
:finish-cursor 21
:current-node-overlay '(20 22)
:end-buffer-content "main = do putStrLn ()
"
:kbd "")
(list :name "kill-line-rest"
:start-buffer-content "main = do putStrLn
(foo bar mu)
case x y z of
Just p -> x
"
:start-cursor 56
:finish-cursor 56
:current-node-overlay 'nil
:end-buffer-content "main = do putStrLn
(foo bar mu)\n \n"
:kbd "")
(list :name "isearch"
:start-buffer-content "main = do foo
bar
"
:start-cursor 11
:finish-cursor 32
:current-node-overlay '(29 32)
:end-buffer-content "main = do foo
bar bob
"
:kbd "bar
bob")
(list :name "auto-reindentation"
:start-buffer-content "main = do foo
bar
"
:start-cursor 5
:finish-cursor 3
:current-node-overlay '(1 3)
:end-buffer-content "ma = do foo
bar
"
:kbd [97 98 99 backspace backspace backspace backspace backspace])
(list :name "raise"
:start-buffer-content "main = case x of
p -> foo (bar bu)
"
:start-cursor 37
:finish-cursor 8
:current-node-overlay '(8 11)
:end-buffer-content "main = bar bu
"
:kbd "\341\362\341\362")
(list :name "splice"
:start-buffer-content "main = foo (bar)
"
:start-cursor 13
:finish-cursor 12
:current-node-overlay '(12 15)
:end-buffer-content "main = foo bar
"
:kbd "\363")
(list :name "kill-line"
:start-buffer-content "main = do foo
bar
mu
"
:start-cursor 11
:finish-cursor 11
:current-node-overlay '(11 14)
:end-buffer-content "main = do foo
bar
mu
"
:kbd "")
(list :name "kill-line-gobble"
:start-buffer-content "foo = do
bar mu
zot
bob bill
ben
lal dat
bob
"
:start-cursor 12
:finish-cursor 12
:current-node-overlay '(12 15)
:end-buffer-content "foo = do
bar mu
zot
bob bill
ben
lal dat
bob
"
:kbd "")
(list :name "kill-line-case-example"
:start-buffer-content "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
"
:start-cursor 182
:finish-cursor 182
:current-node-overlay '(182 189)
:end-buffer-content "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
"
:kbd "")
(list :name "add-operand"
:start-buffer-content "main = a <|> b <|> c
"
:start-cursor 14
:finish-cursor 15
:current-node-overlay '(14 15)
:end-buffer-content "main = a <|> x <|> b <|> c
"
:kbd [67108907 120])
(list :name "wrapping-parens-reindent"
:start-buffer-content "main = foo bar
mu
"
:start-cursor 8
:finish-cursor 9
:current-node-overlay '(9 12)
:end-buffer-content "main = (foo bar
mu)
"
:kbd "\341\250")
(list :name "copy/paste"
:start-buffer-content "main = foo (bar mu
zot)
where g = y
"
:start-cursor 12
:finish-cursor 26
:current-node-overlay '(26 57)
:end-buffer-content "main = foo
where g = y (bar mu
zot)
"
:kbd [11 backspace 14 5 32 25])
(list :name "auto-insert-type-sig"
:start-buffer-content "main
"
:start-cursor 5
:finish-cursor 10
:current-node-overlay '(9 10)
:end-buffer-content "main :: X
"
:kbd ":X")
(list :name "slide-over-used-equal"
:start-buffer-content "main = x
"
:start-cursor 8
:finish-cursor 5
:current-node-overlay '(1 5)
:end-buffer-content "main = x
"
:kbd [backspace])
(list :name "swing-up"
:start-buffer-content "hai = do
foo bar
mu zot
"
:start-cursor 8
:finish-cursor 10
:current-node-overlay '(10 13)
:end-buffer-content "hai = do foo bar
mu zot
"
:kbd "")
(list :name "pragmas"
:start-buffer-content "{}
"
:start-cursor 2
:finish-cursor 23
:current-node-overlay 'nil
:end-buffer-content "{-# LANGUAGE Haskell98 #-}
"
:kbd "-#")
(list :name "where-clause"
:start-buffer-content "fn :: a -> b
fn x = y + y
"
:start-cursor 19
:finish-cursor 36
:current-node-overlay 'nil
:end-buffer-content "fn :: a -> b
fn x = y + y
where y
"
:kbd [?\M-x ?s ?h ?m ?/ ?g ?o ?t ?o ?- ?w ?h ?e ?r ?e return ?y])
(list :name "where-clause with indentation"
:start-buffer-content "fn :: a -> b
fn x = y + y
"
:start-cursor 19
:finish-cursor 40
:current-node-overlay 'nil
:end-buffer-content "fn :: a -> b
fn x = y + y
where
y
"
:kbd [?\M-x ?s ?h ?m ?/ ?g ?o ?t ?o ?- ?w ?h ?e ?r ?e return ?y]
:customizations
'((shm-indent-point-after-adding-where-clause t)))))
(provide 'shm-tests)
;;; shm-tests.el ends here
shm-1.0.20/shm-type.el 0000644 0000000 0000000 00000011226 12472572426 012654 0 ustar 00 0000000 0000000 ;;; shm-type.el --- Type info for nodes
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-layout)
(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-present-type-info (node info)
"Present type info to the user."
(let ((info. (concat (shm-kill-node 'buffer-substring-no-properties node nil t)
" :: "
info)))
(if shm-use-presentation-mode
(if (fboundp 'haskell-present)
(haskell-present "SHM-Node"
nil
info.)
(message "%s" info))
(message "%s" info))))
(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-node-type-info (node)
"Get the type of the given node."
(shm-type-of-region (shm-node-start node)
(shm-node-end node)))
(provide 'shm-type)
shm-1.0.20/shm-yank-kill.el 0000644 0000000 0000000 00000007723 12472572426 013575 0 ustar 00 0000000 0000000 ;;; shm-yank-kill.el --- Yanking/killing operations
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Code:
(require 'shm-macros)
(require 'shm-layout)
(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/kill-region (beg end)
"Kill the region, and save it in the clipboard."
(interactive "r")
(shm-kill-region nil beg end nil))
(defun shm/copy-region (beg end)
"Copy the region, and save it in the clipboard."
(interactive "r")
(save-excursion
(shm-kill-region 'clipboard-kill-ring-save beg end t)))
(defun shm/kill-line ()
"Kill everything possible to kill after point before the end of
the line.
Successive kills will also work, for example:
do |foo
bar
mu
Hitting C-k C-k C-k here will killall three lines, and then C-y
will insert them back verbatim."
(interactive)
(shm-with-fallback
kill-line
(shm/reparse)
(cond
((looking-at "^[ ]+$")
(delete-region (point) (line-end-position)))
((= (line-end-position) (line-beginning-position))
(delete-char -1)
(forward-char 1))
((and (shm-in-string)
(not (= (point)
(shm-node-start (shm-current-node)))))
(let ((current (shm-current-node)))
(if (and (> (shm-node-end current)
(line-end-position))
(save-excursion (goto-char (line-end-position))
(looking-back "\\\\")))
(kill-region (point) (1- (line-end-position)))
(kill-region (point)
(1- (shm-node-end current))))))
((and (= (point) (line-end-position))
(not (looking-at "\n[^ ]")))
(let ((column (current-column)))
(delete-region (point)
(save-excursion (forward-line 1)
(goto-char (+ (line-beginning-position)
column))))
(shm-kill-to-end-of-line t)))
((shm-current-node)
(shm-kill-to-end-of-line))
(t (kill-line)))))
(defun shm/kill-node ()
"Kill the current node."
(interactive)
(shm-kill-node))
(defun shm/yank ()
"Yank from the kill ring and insert indented with `shm-insert-indented'."
(interactive)
(shm-with-fallback
yank
;; This avoids merging two identifiers together accidentally.
(unless (or (shm-in-comment)
(shm-in-string))
(when (looking-back "[a-zA-Z0-9]+_*")
(shm-insert-string " "))
(when (and (looking-at "[a-zA-Z0-9]+_*")
(not (shm-evaporate-before-p)))
(shm-insert-string " ")
(forward-char -1)))
(shm-insert-indented #'clipboard-yank)))
(defun shm/yank-pop ()
"Yank from the kill ring and insert indented with `shm-insert-indented'."
(interactive)
(shm-with-fallback
yank-pop
(if (not (eq last-command 'yank))
(error "Previous command was not a yank (error from shm/yank-pop)"))
(shm-insert-indented #'yank-pop)))
(defun shm/backward-kill-word ()
"Kill the word backwards."
(interactive)
(let ((to-be-deleted (save-excursion (backward-word)
(point))))
(save-excursion
(shm-adjust-dependents (point) (* -1 (- (point) to-be-deleted))))
(backward-kill-word 1)))
(provide 'shm-yank-kill)
shm-1.0.20/shm.el 0000644 0000000 0000000 00000023235 12472572426 011700 0 ustar 00 0000000 0000000 ;;; shm.el --- Structured Haskell Mode
;; Copyright (c) 2013 Chris Done. All rights reserved.
;; Copyright (c) 1998 Heribert Schuetz, Graeme E Moss
;; Author: Chris Done
;; 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 .
;;; Commentary:
;; A minor mode for adding structured editing to Haskell.
;;; Code:
(require 'shm-edit-string)
(require 'shm-constraint)
(require 'shm-type)
(require 'shm-simple-indent)
(require 'shm-yank-kill)
(require 'shm-slot)
(require 'shm-indent)
(require 'shm-insert-del)
(require 'shm-nav)
(require 'shm-manipulation)
(require 'shm-debug)
(defvar shm-map
(let ((map (make-sparse-keymap)))
;; Insertion
(define-key map (kbd "\"") 'shm/double-quote)
(define-key map (kbd "(") 'shm/open-paren)
(define-key map (kbd "M-(") 'shm/wrap-parens)
(define-key map (kbd "[") 'shm/open-bracket)
(define-key map (kbd "{") 'shm/open-brace)
(define-key map (kbd "-") 'shm/hyphen)
(define-key map (kbd "#") 'shm/hash)
(define-key map (kbd ",") 'shm/comma)
(define-key map (kbd ":") 'shm/:)
(define-key map (kbd "SPC") 'shm/space)
(define-key map (kbd "C-c C-u") 'shm/insert-undefined)
(define-key map (kbd "C-c C-_") 'shm/insert-underscore)
(define-key map (kbd "M-;") 'shm/comment)
(define-key map (kbd "C-c C-e") 'shm/export)
(define-key map (kbd "C-M-o") 'shm/split-line)
;; Indentation
(define-key map (kbd "C-j") 'shm/newline-indent-proxy)
(define-key map (kbd "M-)") 'paredit-close-round-and-newline)
(define-key map (kbd "C-c C-^") 'shm/swing-up)
(define-key map (kbd "C-c C-j") 'shm/swing-down)
(define-key map (kbd "TAB") 'shm/tab)
(define-key map (kbd "") 'shm/backtab)
(define-key map (kbd "RET") 'shm/ret-proxy)
(define-key map (kbd "C-") 'shm/simple-indent-newline-indent)
;; Deletion
(define-key map (kbd "DEL") 'shm/del)
(define-key map (kbd "") 'shm/delete)
(define-key map (kbd "M-^") 'shm/delete-indentation)
(define-key map (kbd "M-DEL") 'shm/backward-kill-word)
(define-key map (kbd "C-") 'shm/backward-kill-word)
;; Killing & yanking
(define-key map (kbd "C-k") 'shm/kill-line)
(define-key map (kbd "M-k") 'shm/kill-node)
(define-key map (kbd "C-w") 'shm/kill-region)
(define-key map (kbd "M-w") 'shm/copy-region)
(define-key map (kbd "C-M-k") 'shm/kill-node)
(define-key map (kbd "C-y") 'shm/yank)
(define-key map (kbd "M-y") 'shm/yank-pop)
;; Navigation
(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 ")") 'shm/close-paren)
(define-key map (kbd "]") 'shm/close-bracket)
(define-key map (kbd "}") 'shm/close-brace)
(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)
;; Splitting, slurping, barfing, etc.
(define-key map (kbd "C-+") 'shm/add-operand)
(define-key map (kbd "C-$") 'shm/$)
(define-key map (kbd "M-r") 'shm/raise)
(define-key map (kbd "M-s") 'shm/splice)
(define-key map (kbd "C-c C-q") 'shm/qualify-import)
map)
"Structural editing operations keymap. Any key bindings in this
map are intended to be only structural operations which operate
with the tree in mind.")
(defvar shm-parsing-timer nil
"The timer used to re-parse every so often. The idle time can
be configured with `shm-idle-timeout'.")
;;;###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)))
(defvar shm-repl-map
(let ((map (make-sparse-keymap)))
;; Insertion
(define-key map (kbd "\"") 'shm/double-quote)
(define-key map (kbd "(") 'shm/open-paren)
(define-key map (kbd "M-(") 'shm/wrap-parens)
(define-key map (kbd "[") 'shm/open-bracket)
(define-key map (kbd "{") 'shm/open-brace)
(define-key map (kbd "-") 'shm/hyphen)
(define-key map (kbd "#") 'shm/hash)
(define-key map (kbd ",") 'shm/comma)
(define-key map (kbd ":") 'shm/:)
(define-key map (kbd "SPC") 'shm/space)
(define-key map (kbd "C-c C-u") 'shm/insert-undefined)
(define-key map (kbd "C-c C-_") 'shm/insert-underscore)
(define-key map (kbd "M-;") 'shm/comment)
;; Navigation
(define-key map (kbd "C-M-f") 'shm/forward-node)
(define-key map (kbd "C-M-b") 'shm/backward-node)
(define-key map (kbd "M-a") 'shm/goto-parent)
(define-key map (kbd ")") 'shm/close-paren)
(define-key map (kbd "]") 'shm/close-bracket)
(define-key map (kbd "}") 'shm/close-brace)
(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 "TAB") 'shm/tab)
(define-key map (kbd "") 'shm/backtab)
;; Killing / yanking
(define-key map (kbd "C-k") 'shm/kill-line)
(define-key map (kbd "M-k") 'shm/kill-node)
(define-key map (kbd "C-w") 'shm/kill-region)
(define-key map (kbd "M-w") 'shm/copy-region)
(define-key map (kbd "C-M-k") 'shm/kill-node)
(define-key map (kbd "C-y") 'shm/yank)
(define-key map (kbd "M-y") 'shm/yank-pop)
;; Deletion
(define-key map (kbd "DEL") 'shm/del)
(define-key map (kbd "") 'shm/delete)
(define-key map (kbd "M-^") 'shm/delete-indentation)
(define-key map (kbd "M-DEL") 'shm/backward-kill-word)
(define-key map (kbd "C-") 'shm/backward-kill-word)
;; Splitting, slurping, barfing, etc.
(define-key map (kbd "C-$") 'shm/$)
(define-key map (kbd "C-+") 'shm/add-operand)
(define-key map (kbd "M-r") 'shm/raise)
(define-key map (kbd "M-s") 'shm/splice)
(define-key map (kbd "C-c C-q") 'shm/qualify-import)
map)
"Structural editing operations keymap for in the REPL. This
differs to `shm-map' by having keybindings more appropriate for
a REPL, with inappropriate ones removed.")
(define-minor-mode structured-haskell-repl-mode
"Structured editing for Haskell inside a REPL."
:lighter shm-lighter
:keymap shm-repl-map
(cond
((eq major-mode 'haskell-interactive-mode)
(if structured-haskell-repl-mode
(shm-mode-start)
(shm-mode-stop)))
(t (structured-haskell-repl-mode -1)
(error "Unsupported REPL mode: %S" major-mode))))
(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-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)
;; Kill self-insert hooks.
(remove-hook 'post-self-insert-hook 'shm-post-self-insert t)
;; Delete all markers.
(mapc (lambda (pair)
(mapc #'shm-node-delete-markers
(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 (or structured-haskell-mode
structured-haskell-repl-mode)
(shm/reparse)))
(defun shm/tab ()
"Either indent if at the start of a line, or jump to the next
slot."
(interactive)
(cond
((save-excursion (goto-char (line-beginning-position))
(looking-at "^[ ]*$"))
(shm/simple-indent))
(t
(shm/jump-to-slot))))
(defun shm/backtab ()
"Either de-indent if at the start of a line, or jump to the previous
slot."
(interactive)
(cond
((save-excursion (goto-char (line-beginning-position))
(looking-at "^[ ]*$"))
(shm/simple-indent-backtab))
(t
(shm/jump-to-previous-slot))))
(defun shm/ret-proxy ()
"Run `shm/simple-indent-newline-same-col', or in electric mode
run `shm/newline-indent' (swaps behaviour)."
(interactive)
(if (bound-and-true-p electric-indent-mode)
(call-interactively 'shm/newline-indent)
(call-interactively 'shm/simple-indent-newline-same-col)))
(defun shm/newline-indent-proxy ()
"Run `shm/newline-indent', or in electric mode
run `simple-indent-newline-same-col' (swaps behaviour)."
(interactive)
(if (bound-and-true-p electric-indent-mode)
(call-interactively 'shm/simple-indent-newline-same-col)
(call-interactively 'shm/newline-indent)))
(provide 'shm)