diff --git a/elisp/shm-ast.el b/elisp/shm-ast.el --- a/elisp/shm-ast.el +++ b/elisp/shm-ast.el @@ -316,25 +316,44 @@ haskell-interactive-mode-prompt-start (line-end-position)))) ;; Don't activate if we're doing a GHCi command. - (unless (string-match "^:" whole-line) - (cons haskell-interactive-mode-prompt-start - (line-end-position))))))) - ))) + (unless (and (string-match "^:" whole-line) + (not (string-match "^:t[^ ]* " whole-line)) + (not (string-match "^:k[^ ]* " 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 (progn (goto-char (line-end-position)) - (search-backward-regexp "^[^ \n]" nil t 1) - (unless (or (looking-at "^-}$") - (looking-at "^{-$")) - (point))) + (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 (when (search-forward-regexp "[\n]+[^ \n]" nil t 1) - (forward-char -1) - (search-backward-regexp "[^\n ]" nil t) - (forward-char) - (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)))))) @@ -628,3 +647,8 @@ (shm-node-string (shm-current-node))) (provide 'shm-ast) + +;; Local variables: +;; byte-compile-warnings: (not cl-functions) +;; byte-compile-warnings: (not cl-macros) +;; End: diff --git a/elisp/shm-fold.el b/elisp/shm-fold.el --- a/elisp/shm-fold.el +++ b/elisp/shm-fold.el @@ -68,3 +68,7 @@ (+ (point) 1)))) (provide 'shm-fold) + +;; Local variables: +;; byte-compile-warnings: (not cl-functions) +;; End: diff --git a/elisp/shm-indent.el b/elisp/shm-indent.el --- a/elisp/shm-indent.el +++ b/elisp/shm-indent.el @@ -144,8 +144,14 @@ with it." (interactive) (cond - ((not (shm-current-node)) - (shm/simple-indent)) + ((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)))) @@ -336,7 +342,7 @@ (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)))) + (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))))) diff --git a/elisp/shm-insert-del.el b/elisp/shm-insert-del.el --- a/elisp/shm-insert-del.el +++ b/elisp/shm-insert-del.el @@ -29,14 +29,14 @@ (forward-char -1) (shm-adjust-dependents (point) 1))) -(defun shm/wrap-parens () +(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 (shm-current-node))) + (node (or current (shm-current-node)))) (save-excursion (goto-char (shm-node-start node)) (insert "(") @@ -62,6 +62,8 @@ (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)) @@ -473,7 +475,7 @@ (let ((current (shm-actual-node))) (cond ((shm-find-overlay 'shm-quarantine) - (if (not (or (looking-back "[ ,[({\\]") + (if (not (or (looking-back "[ ,[({\\!]") (and (looking-back "\\$") (string= "(" open)) (bolp))) @@ -483,11 +485,11 @@ (let ((point (point))) (shm-insert-string close) (when (and (/= (point) (line-end-position)) - (not (looking-at "[]){} ,]"))) + (not (looking-at "[]){} ,\\]"))) (shm-insert-string " ")) (goto-char point))) (t - (if (not (or (looking-back "[ ,[({]") + (if (not (or (looking-back "[ ,[({!\\]") (bolp))) (progn (shm-insert-string " ") 1) 0) @@ -495,7 +497,7 @@ (let ((point (point))) (shm-insert-string close) (when (and (/= (point) (line-end-position)) - (not (looking-at "[]){} ,]"))) + (not (looking-at "[]){} ,!]"))) (shm-insert-string " ")) (goto-char point) (shm/init t)))))))) @@ -565,3 +567,7 @@ (insert name)))) (provide 'shm-insert-del) + +;; Local variables: +;; byte-compile-warnings: (not cl-functions) +;; End: diff --git a/elisp/shm-layout.el b/elisp/shm-layout.el --- a/elisp/shm-layout.el +++ b/elisp/shm-layout.el @@ -210,19 +210,21 @@ (push-mark) (goto-char start)))) -(defun shm-find-furthest-parent-on-line (current) +(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." - (let ((parent (shm-node-parent current))) - (if parent - (if (= (line-beginning-position) - (save-excursion (goto-char (shm-node-start (cdr parent))) - (line-beginning-position))) - (shm-find-furthest-parent-on-line parent) - current) - current))) + (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." diff --git a/elisp/shm-manipulation.el b/elisp/shm-manipulation.el --- a/elisp/shm-manipulation.el +++ b/elisp/shm-manipulation.el @@ -59,6 +59,10 @@ (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 () diff --git a/elisp/shm-overlays.el b/elisp/shm-overlays.el --- a/elisp/shm-overlays.el +++ b/elisp/shm-overlays.el @@ -61,3 +61,7 @@ (overlays-in (point-min) (point-max)))) (provide 'shm-overlays) + +;; Local variables: +;; byte-compile-warnings: (not cl-functions) +;; End: diff --git a/elisp/shm-slot.el b/elisp/shm-slot.el --- a/elisp/shm-slot.el +++ b/elisp/shm-slot.el @@ -68,6 +68,17 @@ (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 @@ -199,3 +210,8 @@ (forward-char -1)) (provide 'shm-slot) + +;; Local variables: +;; byte-compile-warnings: (not cl-functions) +;; byte-compile-warnings: (not cl-macros) +;; End: diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,18 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-signatures -fno-warn-type-defaults #-} -- | Take in Haskell code and output a vector of source spans and -- their associated node type and case. module Main (main) where -import Control.Applicative -import Data.Data -import Data.Maybe -import Language.Haskell.Exts.Annotated -import System.Environment +import Control.Applicative +import Data.Data +import Data.List +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Descriptive +import Descriptive.Options +import Language.Haskell.Exts.Annotated +import System.Environment -- | A generic Dynamic-like constructor -- but more convenient to -- write and pattern match on. @@ -34,34 +41,59 @@ --- | Main entry point. main :: IO () -main = do - code <- getContents - action:typ:_ <- getArgs - outputWith action typ code +main = + do code <- getContents + args <- getArgs + case consume options (map T.pack args) of + (Right (action,typ,exts),_) -> + outputWith action typ exts code + (Left _err,_) -> + error (T.unpack (textDescription (fst (describe options [])))) +-- | Action to perform. +data Action = Parse | Check + +-- | Thing to parse. +data ParseType = Decl | Stmt + +-- | Command line options. +options :: Consumer [Text] Option (Action,ParseType,[Extension]) +options = (,,) <$> action <*> typ <*> exts + where action = + sumConstant Parse "parse" <|> + sumConstant Check "check" + typ = + sumConstant Decl "decl" <|> + sumConstant Stmt "stmt" + sumConstant sum' text = + fmap (const sum') + (constant text) + exts = + fmap getExtensions + (many (prefix "X" "Language extension")) + -- | Output some result with the given action (check/parse/etc.), -- parsing the given type of AST node. In the past, the type was any -- kind of AST node. Today, it's just a "decl" which is covered by -- 'parseTopLevel'. -outputWith :: String -> String -> String -> IO () -outputWith action typ code = +outputWith :: Action -> ParseType -> [Extension] -> String -> IO () +outputWith action typ exts code = case typ of - "decl" -> - output action parseTopLevel code - "stmt" -> - output action parseSomeStmt code - _ -> error "Unknown parser type." + Decl -> output action parseTopLevel exts code + Stmt -> output action parseSomeStmt exts code -- | Output AST info for the given Haskell code. -output :: String -> Parser -> String -> IO () -output action parser code = - case parser parseMode code of +output :: Action -> Parser -> [Extension] -> String -> IO () +output action parser exts code = + case parser parseMode {extensions = exts} code of ParseFailed _ e -> error e ParseOk (D ast) -> case action of - "check" -> return () - "parse" -> putStrLn ("[" ++ concat (genHSE ast) ++ "]") - _ -> error "unknown action" + Check -> return () + Parse -> + putStrLn ("[" ++ + concat (genHSE ast) ++ + "]") -- | An umbrella parser to parse: -- @@ -87,17 +119,14 @@ D . fix <$> parseExpWithMode mode code <|> D <$> parseImport mode code +-- | Apply fixities after parsing. fix ast = fromMaybe ast (applyFixities baseFixities ast) -- | Parse mode, includes all extensions, doesn't assume any fixities. parseMode :: ParseMode parseMode = - defaultParseMode { extensions = allExtensions - , fixities = Nothing - } - where allExtensions = filter isDisabledExtention knownExtensions - isDisabledExtention (DisableExtension _) = False - isDisabledExtention _ = True + defaultParseMode {extensions = defaultExtensions + ,fixities = Nothing} -- | Generate a list of spans from the HSE AST. genHSE :: Data a => a -> [String] @@ -183,3 +212,42 @@ ParseOk (Module _ _ [p] _ _) -> return p ParseOk _ -> ParseFailed noLoc "parseModulePragma" ParseFailed x y -> ParseFailed x y + +-------------------------------------------------------------------------------- +-- Extensions stuff stolen from hlint + +-- | Consume an extensions list from arguments. +getExtensions :: [Text] -> [Extension] +getExtensions = foldl f defaultExtensions . map T.unpack + where f _ "Haskell98" = [] + f a ('N':'o':x) + | Just x' <- readExtension x = + delete x' a + f a x + | Just x' <- readExtension x = + x' : + delete x' a + f _ x = error $ "Unknown extension: " ++ x + +-- | Parse an extension. +readExtension :: String -> Maybe Extension +readExtension x = + case classifyExtension x of + UnknownExtension _ -> Nothing + x' -> Just x' + +-- | Default extensions. +defaultExtensions :: [Extension] +defaultExtensions = + [e | e@EnableExtension{} <- knownExtensions] \\ + map EnableExtension badExtensions + +-- | Extensions which steal too much syntax. +badExtensions :: [KnownExtension] +badExtensions = + [Arrows -- steals proc + ,TransformListComp -- steals the group keyword + ,XmlSyntax, RegularPatterns -- steals a-b + ,UnboxedTuples -- breaks (#) lens operator + ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break + ] diff --git a/structured-haskell-mode.cabal b/structured-haskell-mode.cabal --- a/structured-haskell-mode.cabal +++ b/structured-haskell-mode.cabal @@ -1,5 +1,5 @@ name: structured-haskell-mode -version: 1.0.4 +version: 1.0.6 synopsis: Structured editing Emacs mode for Haskell description: Structured editing Emacs mode for Haskell. homepage: https://github.com/chrisdone/structured-haskell-mode @@ -41,5 +41,7 @@ main-is: Main.hs ghc-options: -O2 -Wall hs-source-dirs: src - build-depends: base >= 4 && < 5, - haskell-src-exts == 1.15.* + build-depends: base >= 4 && < 5 + , haskell-src-exts == 1.15.* + , text + , descriptive == 0.0.*