branch: elpa/haskell-tng-mode commit 794c80b4d8cdd7acfb0075360842e411b2bd4f71 Author: Tseen She <ts33n....@gmail.com> Commit: Tseen She <ts33n....@gmail.com>
better indentation alts --- haskell-tng-smie.el | 50 ++++---- test/src/layout.hs.insert.indent | 36 +++--- test/src/medley.hs.insert.indent | 270 +++++++++++++++++++-------------------- 3 files changed, 181 insertions(+), 175 deletions(-) diff --git a/haskell-tng-smie.el b/haskell-tng-smie.el index 36778b8..92bdc9c 100644 --- a/haskell-tng-smie.el +++ b/haskell-tng-smie.el @@ -88,7 +88,7 @@ ;; https://www.gnu.org/software/emacs/manual/html_mono/elisp.html#SMIE-Indentation (defun haskell-tng-smie:rules (method arg) ;; see docs for `smie-rules-function' -;; (message "INDENT %S %S" method arg) + ;; (message "INDENT %S %S" method arg) (pcase method (:elem (pcase arg @@ -141,32 +141,38 @@ (defun haskell-tng-smie:indent-alts () "Returns a list of alternative indentation levels for the current line." - (save-excursion - (let ((the-line (line-number-at-pos)) - indents) + (let ((the-line (line-number-at-pos)) + indents) + (save-excursion (when (re-search-backward haskell-tng:regexp:toplevel nil t) - (while (< (line-number-at-pos) the-line) - ;; FIXME improve the indentation alts - ;; TODO add positions of WLDOS - ;; TODO +- 2 WLDOS - ;; TODO special cases for import (unless grammar handles it) - ;; TODO special cases for multiple whitespaces (implies alignment) - ;; TODO the-line +- 2 - (push (current-indentation) indents) - (forward-line))) - - ;; alts are easier to use when ordered - (setq indents (sort indents '<)) - ;; TODO consider ordering all alts, and cycling the list so the first alt - ;; is the next higher than the current indentation level - - ;; indentation of the next line is common for insert edits, top priority + (let ((start (point))) + (while (< (line-number-at-pos) the-line) + (push (current-indentation) indents) ;; this line's indentation + (forward-line)) + (when (re-search-backward + (rx word-start (| "where" "let" "do" "case") word-end) + start t) + ;; TODO the next whitespace level after a WLDO (not a WLDC) + (push (+ 2 (current-column)) indents))))) + + (save-excursion + (forward-line -1) + (when (/= the-line (line-number-at-pos)) + (push (+ 2 (current-indentation)) indents))) + + ;; alts are easier to use when ordered + (setq indents (sort indents '<)) + ;; TODO consider ordering alts, and cycling the list so the first suggestion + ;; is the next one higher than the current indentation level. + + ;; indentation of the next line is common for insert edits, top priority + (save-excursion (forward-line) (forward-comment (point-max)) (when (/= the-line (line-number-at-pos)) - (push (current-indentation) indents)) + (push (current-indentation) indents))) - (-distinct indents)))) + (-distinct indents))) (defun haskell-tng-smie:setup () (setq-local smie-indent-basic 2) diff --git a/test/src/layout.hs.insert.indent b/test/src/layout.hs.insert.indent index 8fcf9b0..f82da4a 100644 --- a/test/src/layout.hs.insert.indent +++ b/test/src/layout.hs.insert.indent @@ -1,38 +1,38 @@ -- Figure 2.1 from the Haskell2010 report -v +v 1 module AStack( Stack, push, pop, top, size ) where -v +v 1 2 data Stack a = Empty -2 1 v +2 3 1 v | MkStack a (Stack a) -1 v +1 v 2 -v 1 +v 1 2 push :: a -> Stack a -> Stack a -v +v 1 push x s = MkStack x s -1 v +1 2 v -v +v 1 size :: Stack a -> Int -v +v 1 size s = length (stkToLst s) where -2 v 1 +2 v 1 3 stkToLst Empty = [] -2 1 v +2 1 3 4 v stkToLst (MkStack x s) = x:xs where xs = stkToLst s -1 2 v +1 2 3 4 v -1 2 v +1 2 3 4 v pop :: Stack a -> (a, Stack a) -v +v 1 pop (MkStack x s) 2 1 v = (x, case s of r -> i r where i x = x) -- (pop Empty) is an error -1 2 v +1 2 3 v 4 -v 1 +v 1 2 top :: Stack a -> a -v +v 1 top (MkStack x s) = x -- (top Empty) is an error -v \ No newline at end of file +v 1 \ No newline at end of file diff --git a/test/src/medley.hs.insert.indent b/test/src/medley.hs.insert.indent index 661081d..d980b25 100644 --- a/test/src/medley.hs.insert.indent +++ b/test/src/medley.hs.insert.indent @@ -1,292 +1,292 @@ {-# LANGUAGE OverloadedStrings #-} -v +v 1 {-# LANGUAGE ScopedTypeVariables #-} -v +v 1 -v +v 1 -- | This file is a medley of various constructs and some corner cases -v +v 1 module Foo.Bar.Main 2 1 v ( Wibble(..), Wobble(Wobb, (!!!)), Woo -2 1 v +2 1 3 v -- * Operations -2 1 v +2 1 3 v , getFooByBar, getWibbleByWobble -2 1 v +2 1 3 v , module Bloo.Foo -1 2 v +1 2 3 v ) where -v 1 +v 1 2 -v 1 +v 1 2 import Control.Applicative (many, optional, pure, (<*>), (<|>)) -v +v 1 import Data.Foldable (traverse_) -v +v 1 import Data.Functor ((<$>)) -v +v 1 import Data.List (intercalate) -v +v 1 import Data.Monoid ((<>)) -v +v 1 import qualified Options.Monad -v +v 1 import qualified Options.Applicative as Opts -v +v 1 import qualified Options.Divisible -- wibble (wobble) -2 1 v +2 31 v as Div -v 1 +v 1 2 import qualified ProfFile.App hiding (as, hiding, qualified) -v +v 1 import ProfFile.App (as, hiding, qualified) -v +v 1 import ProfFile.App hiding (as, hiding, qualified) -v +v 1 import qualified ProfFile.App (as, hiding, qualified) -v +v 1 import System.Exit (ExitCode (..), exitFailure, qualified, -1 v +1 2 v Typey, -1 v +1 v 2 wibble, -1 v +1 v 2 Wibble) -v 1 +v 1 2 import System.FilePath (replaceExtension, Foo(Bar, (:<))) -v +v 1 import System.IO (IOMode (..), hClose, hGetContents, -1 v +1 2 v hPutStr, hPutStrLn, openFile, stderr, -1 v +1 v 2 stdout, MoarTypey) -v 1 +v 1 2 import System.Process (CreateProcess (..), StdStream (..), -1 v +1 2 v createProcess, proc, waitForProcess) -1 v 2 +1 v 2 3 -1 v 2 +1 2 v 3 -- some chars that should be propertized -v 1 +v 1 2 chars = ['c', '\n', '\''] -1 v +1 2 v -v +v 1 strings = ["", "\"\"", "\n\\ ", "\\"] -1 v +1 2 v -- knownWrongEscape = "foo"\\"bar" -1 v +1 2 v -v +v 1 multiline1 = "\ -v 1 +v 2 1 \ " -v 1 +v 1 2 multiline2 = "\ -v 1 +v 2 1 \" -1 2 v +1 2 3 v -v 1 +v 1 2 difficult = foo' 'a' 2 -1 v +1 2 v -v +v 1 foo = "wobble (wibble)" -1 v +1 2 v -v +v 1 class Get a s where -1 v +1 v 2 get :: Set s -> a -1 2 v +1 2 3 4 v -1 v +1 v 2 instance {-# OVERLAPS #-} Get a (a ': s) where -2 1 v +2 1 v 3 get (Ext a _) = a -1 2 v +1 2 3 v 4 -1 v +1 v 2 instance {-# OVERLAPPABLE #-} Get a s => Get a (b ': s) where -2 1 v +2 1 v 3 get (Ext _ xs) = get xs -1 2 v +1 2 3 v 4 -1 v +1 v 2 data Options = Options 2 1 v { optionsReportType :: ReportType -2 1 v +2 1 3 v , optionsProfFile :: Maybe FilePath -2 1 v +2 1 3 v , optionsOutputFile :: Maybe FilePath -2 1 v +2 1 3 v , optionsFlamegraphFlags :: [String] -2 1 v +2 1 3 v } deriving (Eq, Show) -1 v +1 v 2 v 1 class (Eq a) => Ord a where -2 1 v +2 1 v 3 (<), (<=), (>=), (>) :: a -> a -> Bool -2 1 v +2 1 3 4 v max @Foo, min :: a -> a -> a -1 2 v +1 2 3 4 v -1 v +1 v 2 instance (Eq a) => Eq (Tree a) where -2 1 v +2 1 v 3 Leaf a == Leaf b = a == b -2 1 v +2 1 3 4 v (Branch l1 r1) == (Branch l2 r2) = (l1==l2) && (r1==r2) -2 1 v +2 1 3 4 v _ == _ = False -1 2 v +1 2 3 4 v -1 v +1 v 2 data ReportType = Alloc -- ^ Report allocations, percent -2 1 v +2 3 1 v | Entries -- ^ Report entries, number -1 v +1 v 2 | Time -- ^ Report time spent in closure, percent -1 v +1 v 2 | Ticks -- ^ Report ticks, number -1 v +1 v 2 | Bytes -- ^ Report bytes allocated, number -1 v +1 v 2 deriving (Eq, Show) -1 v +1 v 2 -v 1 +v 1 2 type family G a where -2 1 v +2 1 v 3 G Int = Bool -2 1 v +2 1 3 v 4 G a = Char -1 2 v +1 2 3 v 4 -1 v +1 v 2 data Flobble = Flobble 2 1 v deriving (Eq) via (NonNegative (Large Int)) -1 v +1 v 2 deriving stock (Floo) -1 v +1 v 2 deriving anyclass (WibblyWoo, OtherlyWoo) -1 v +1 v 2 v 1 newtype Flobby = Flobby -1 v +1 2 v -v +v 1 foo :: -21 v +213 v Wibble -- wibble -2v 1 +2v 31 -> Wobble -- wobble -23 1 v +23 1 4 v -> Wobble -- wobble -23 1 v +23 1 4 v -> Wobble -- wobble -23 1 v +23 1 4 v -> (wob :: Wobble) -23 1 v +23 1 4 v -> (Wobble -- wobble -23 1 v +23 1 4 v a b c) -12 3 v +12 3 4 v -v1 2 +v12 3 (foo :: (Wibble Wobble)) foo -12 3 v +123 4 v -v1 2 +v12 3 newtype TestApp -2 1 v +2 31 v (logger :: TestLogger) -1 v +1 v 2 (scribe :: TestScribe) -1 v +1 v 2 config -1 v +1 v 2 a -1 v +1 v 2 = TestApp a -1 2 v +1 2 3 v -v 1 +v 12 optionsParser :: Opts.Parser Options -v +v 1 optionsParser = Options 2 1 v <$> (Opts.flag' Alloc (Opts.long "alloc" <> Opts.help "wibble") -2 3 1 v +2 3 4 1 v <|> Opts.flag' Entries (Opts.long "entry" <> Opts.help "wobble") -2 3 1 v +2 3 1 4 v <|> Opts.flag' Bytes (Opts.long "bytes" <> Opts.help "i'm a fish")) -2 1 3v +2 1 3v4 <*> optional -1 2 3v +1 2 3 4v (Opts.strArgument 2 3 45 1 v (Opts.metavar "MY-FILE" <> -2 3 45 61 v +2 3 45 617 v Opts.help "meh")) -1 2 3v 45 +1 2 3v 45 6 1 2 v34 56 type PhantomThing -1 v +1 2 v -v +v 1 type SomeApi = 2 v 1 "thing" :> Capture "bar" Index :> QueryParam "wibble" Text -2 3 v 1 +2 3 4 v 1 :> QueryParam "wobble" Natural -1 2 v +1 2 v 3 :> Header TracingHeader TracingId -1 2 v +1 2 v 3 :> ThingHeader -1 2 v +1 2 v 3 :> Get '[JSON] (The ReadResult) -2 1 3 v +2 1 3 v 4 :<|> "thing" :> ReqBody '[JSON] Request -2 v 3 1 4 +2 v 3 4 1 5 :> Header TracingHeader TracingId -1 2 3 v 4 +1 2 3 v 4 5 :> SpecialHeader -1 2 3 v 4 +1 2 3 v 4 5 :> Post '[JSON] (The Response) -1 2 3 v 4 +1 2 3 v 4 5 v 1 2 3 4 deriving instance FromJSONKey StateName -v +v 1 deriving anyclass instance FromJSON Base -v +v 1 deriving newtype instance FromJSON Treble -1 v +1 2 v -v +v 1 foo = do 2 1 v bar :: Wibble <- baz -2 1 v +2 1 3 4 v where baz = _ -2 3 1 v +2 3 4 1 v -- checking that comments are ignored in layout -2 3 1 v +2 3 4 1 v -- and that a starting syntax entry is ok -2 3 1 v +2 3 4 1 v (+) = _ -1 2 3 v +1 2 3 4 5 v -1 2 3 v +1 2 3 4 v test = 1 `shouldBe` 1 -v \ No newline at end of file +v 1 \ No newline at end of file