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
