Add new step to squash multiple spaces between some elements

8 files changed, 213 insertions, 5 deletions

diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml
index 10301be..c1d822d 100644
--- a/data/stylish-haskell.yaml
+++ b/data/stylish-haskell.yaml
@@ -198,6 +198,11 @@ steps:
   # Remove trailing whitespace
   - trailing_whitespace: {}
 
+  # Squash multiple spaces between the left and right hand sides of some
+  # elements into single spaces. Basically, this undoes the effect of
+  # simple_align but is a bit less conservative.
+  # - squash: {}
+
 # A common setting is the number of columns (parts of) code will be wrapped
 # to. Different steps take this into account. Default: 80.
 columns: 80
diff --git a/lib/Language/Haskell/Stylish/Align.hs b/lib/Language/Haskell/Stylish/Align.hs
index 8e6665f..53549b9 100644
--- a/lib/Language/Haskell/Stylish/Align.hs
+++ b/lib/Language/Haskell/Stylish/Align.hs
@@ -7,7 +7,6 @@ module Language.Haskell.Stylish.Align
 
 
 --------------------------------------------------------------------------------
-import           Data.Char                       (isSpace)
 import           Data.List                       (nub)
 import qualified Language.Haskell.Exts           as H
 
@@ -81,9 +80,6 @@ align maxColumns alignment
             (pre, post) = splitAt column str
         in [padRight longestLeft (trimRight pre) ++ trimLeft post]
 
-    trimLeft  = dropWhile isSpace
-    trimRight = reverse . trimLeft . reverse
-
 
 --------------------------------------------------------------------------------
 -- | Checks that all the alignables appear on a single line, and that they do
diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs
index f88aef0..19588b7 100644
--- a/lib/Language/Haskell/Stylish/Config.hs
+++ b/lib/Language/Haskell/Stylish/Config.hs
@@ -36,6 +36,7 @@ import           Language.Haskell.Stylish.Step
 import qualified Language.Haskell.Stylish.Step.Imports            as Imports
 import qualified Language.Haskell.Stylish.Step.LanguagePragmas    as LanguagePragmas
 import qualified Language.Haskell.Stylish.Step.SimpleAlign        as SimpleAlign
+import qualified Language.Haskell.Stylish.Step.Squash             as Squash
 import qualified Language.Haskell.Stylish.Step.Tabs               as Tabs
 import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace
 import qualified Language.Haskell.Stylish.Step.UnicodeSyntax      as UnicodeSyntax
@@ -137,6 +138,7 @@ catalog = M.fromList
     [ ("imports",             parseImports)
     , ("language_pragmas",    parseLanguagePragmas)
     , ("simple_align",        parseSimpleAlign)
+    , ("squash",              parseSquash)
     , ("tabs",                parseTabs)
     , ("trailing_whitespace", parseTrailingWhitespace)
     , ("unicode_syntax",      parseUnicodeSyntax)
@@ -175,6 +177,11 @@ parseSimpleAlign c o = SimpleAlign.step
 
 
 --------------------------------------------------------------------------------
+parseSquash :: Config -> A.Object -> A.Parser Step
+parseSquash _ _ = return Squash.step
+
+
+--------------------------------------------------------------------------------
 parseImports :: Config -> A.Object -> A.Parser Step
 parseImports config o = Imports.step
     <$> pure (configColumns config)
diff --git a/lib/Language/Haskell/Stylish/Step/Squash.hs b/lib/Language/Haskell/Stylish/Step/Squash.hs
new file mode 100644
index 0000000..0eb4895
--- /dev/null
+++ b/lib/Language/Haskell/Stylish/Step/Squash.hs
@@ -0,0 +1,62 @@
+--------------------------------------------------------------------------------
+module Language.Haskell.Stylish.Step.Squash
+    ( step
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Data.Maybe                      (mapMaybe)
+import qualified Language.Haskell.Exts           as H
+
+
+--------------------------------------------------------------------------------
+import           Language.Haskell.Stylish.Editor
+import           Language.Haskell.Stylish.Step
+import           Language.Haskell.Stylish.Util
+
+
+--------------------------------------------------------------------------------
+squash
+    :: (H.Annotated l, H.Annotated r)
+    => l H.SrcSpan -> r H.SrcSpan -> Maybe (Change String)
+squash left right
+  | H.srcSpanEndLine lAnn == H.srcSpanStartLine rAnn = Just $
+        changeLine (H.srcSpanEndLine lAnn) $ \str ->
+        let (pre, post) = splitAt (H.srcSpanEndColumn lAnn) str
+        in  [trimRight pre ++ " " ++ trimLeft post]
+  | otherwise = Nothing
+  where
+    lAnn = H.ann left
+    rAnn = H.ann right
+
+
+--------------------------------------------------------------------------------
+squashFieldDecl :: H.FieldDecl H.SrcSpan -> Maybe (Change String)
+squashFieldDecl (H.FieldDecl _ names type')
+  | null names = Nothing
+  | otherwise  = squash (last names) type'
+
+
+--------------------------------------------------------------------------------
+squashMatch :: H.Match H.SrcSpan -> Maybe (Change String)
+squashMatch (H.InfixMatch _ _ _ _ _ _) = Nothing
+squashMatch (H.Match _ name pats rhs _)
+  | null pats = squash name        rhs
+  | otherwise = squash (last pats) rhs
+
+
+--------------------------------------------------------------------------------
+squashAlt :: H.Alt H.SrcSpan -> Maybe (Change String)
+squashAlt (H.Alt _ pat rhs _) = squash pat rhs
+
+
+--------------------------------------------------------------------------------
+step :: Step
+step = makeStep "Squash" $ \ls (module', _) ->
+    let module'' = fmap H.srcInfoSpan module'
+        changes  = concat
+            [ mapMaybe squashAlt       (everything module'')
+            , mapMaybe squashMatch     (everything module'')
+            , mapMaybe squashFieldDecl (everything module'')
+            ]
+    in applyChanges changes ls
diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs
index 54abef5..c634043 100644
--- a/lib/Language/Haskell/Stylish/Util.hs
+++ b/lib/Language/Haskell/Stylish/Util.hs
@@ -6,6 +6,8 @@ module Language.Haskell.Stylish.Util
     , padRight
     , everything
     , infoPoints
+    , trimLeft
+    , trimRight
     , wrap
     , wrapRest
 
@@ -18,7 +20,7 @@ module Language.Haskell.Stylish.Util
 
 --------------------------------------------------------------------------------
 import           Control.Arrow                 ((&&&), (>>>))
-import           Data.Char                     (isAlpha)
+import           Data.Char                     (isAlpha, isSpace)
 import           Data.Data                     (Data)
 import qualified Data.Generics                 as G
 import           Data.Maybe                    (fromMaybe, listToMaybe,
@@ -69,6 +71,16 @@ infoPoints = H.srcInfoPoints >>> map (H.srcSpanStart &&& H.srcSpanEnd)
 
 
 --------------------------------------------------------------------------------
+trimLeft :: String -> String
+trimLeft  = dropWhile isSpace
+
+
+--------------------------------------------------------------------------------
+trimRight :: String -> String
+trimRight = reverse . trimLeft . reverse
+
+
+--------------------------------------------------------------------------------
 wrap :: Int       -- ^ Maximum line width
      -> String    -- ^ Leading string
      -> Int       -- ^ Indentation
diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal
index 65fd271..3ee4988 100644
--- a/stylish-haskell.cabal
+++ b/stylish-haskell.cabal
@@ -32,6 +32,7 @@ Library
     Language.Haskell.Stylish.Step.Imports
     Language.Haskell.Stylish.Step.LanguagePragmas
     Language.Haskell.Stylish.Step.SimpleAlign
+    Language.Haskell.Stylish.Step.Squash
     Language.Haskell.Stylish.Step.Tabs
     Language.Haskell.Stylish.Step.TrailingWhitespace
     Language.Haskell.Stylish.Step.UnicodeSyntax
@@ -99,6 +100,8 @@ Test-suite stylish-haskell-tests
     Language.Haskell.Stylish.Step
     Language.Haskell.Stylish.Step.SimpleAlign
     Language.Haskell.Stylish.Step.SimpleAlign.Tests
+    Language.Haskell.Stylish.Step.Squash
+    Language.Haskell.Stylish.Step.Squash.Tests
     Language.Haskell.Stylish.Step.Imports
     Language.Haskell.Stylish.Step.Imports.Tests
     Language.Haskell.Stylish.Step.LanguagePragmas
diff --git a/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs b/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs
new file mode 100644
index 0000000..a785d9a
--- /dev/null
+++ b/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs
@@ -0,0 +1,121 @@
+--------------------------------------------------------------------------------
+module Language.Haskell.Stylish.Step.Squash.Tests
+    ( tests
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Test.Framework                            (Test, testGroup)
+import           Test.Framework.Providers.HUnit            (testCase)
+import           Test.HUnit                                (Assertion, (@=?))
+
+
+--------------------------------------------------------------------------------
+import           Language.Haskell.Stylish.Step.Squash
+import           Language.Haskell.Stylish.Tests.Util
+
+
+--------------------------------------------------------------------------------
+tests :: Test
+tests = testGroup "Language.Haskell.Stylish.Step.SimpleSquash.Tests"
+    [ testCase "case 01" case01
+    , testCase "case 02" case02
+    , testCase "case 03" case03
+    , testCase "case 04" case04
+    , testCase "case 05" case05
+    ]
+
+
+--------------------------------------------------------------------------------
+case01 :: Assertion
+case01 = expected @=? testStep step input
+  where
+    input = unlines
+        [ "data Foo = Foo"
+        , "    { foo    :: Int"
+        , "    , barqux :: String"
+        , "    } deriving (Show)"
+        ]
+
+    expected = unlines
+        [ "data Foo = Foo"
+        , "    { foo :: Int"
+        , "    , barqux :: String"
+        , "    } deriving (Show)"
+        ]
+
+
+--------------------------------------------------------------------------------
+case02 :: Assertion
+case02 = expected @=? testStep step input
+  where
+    input = unlines
+        [ "data Foo = Foo"
+        , "    { fooqux"
+        , "    , bar    :: String"
+        , "    } deriving (Show)"
+        ]
+
+    expected = unlines
+        [ "data Foo = Foo"
+        , "    { fooqux"
+        , "    , bar :: String"
+        , "    } deriving (Show)"
+        ]
+
+
+--------------------------------------------------------------------------------
+case03 :: Assertion
+case03 = expected @=? testStep step input
+  where
+    input = unlines
+        [ "maybe y0 f mx ="
+        , "    case mx of"
+        , "        Nothing -> y0"
+        , "        Just x  -> f x"
+        ]
+
+    expected = unlines
+        [ "maybe y0 f mx ="
+        , "    case mx of"
+        , "        Nothing -> y0"
+        , "        Just x -> f x"
+        ]
+
+
+--------------------------------------------------------------------------------
+case04 :: Assertion
+case04 = expected @=? testStep step input
+  where
+    input = unlines
+        [ "maybe y0 f mx ="
+        , "    case mx of"
+        , "        Nothing ->"
+        , "            y0"
+        , "        Just x  ->"
+        , "            f x"
+        ]
+
+    expected = unlines
+        [ "maybe y0 f mx ="
+        , "    case mx of"
+        , "        Nothing ->"
+        , "            y0"
+        , "        Just x ->"
+        , "            f x"
+        ]
+
+
+--------------------------------------------------------------------------------
+case05 :: Assertion
+case05 = expected @=? testStep step input
+  where
+    input = unlines
+        [ "maybe y0 _ Nothing  = y"
+        , "maybe _  f (Just x) = f x"
+        ]
+
+    expected = unlines
+        [ "maybe y0 _ Nothing = y"
+        , "maybe _  f (Just x) = f x"
+        ]
diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs
index 853126d..27963a0 100644
--- a/tests/TestSuite.hs
+++ b/tests/TestSuite.hs
@@ -13,6 +13,7 @@ import qualified Language.Haskell.Stylish.Parse.Tests
 import qualified Language.Haskell.Stylish.Step.Imports.Tests
 import qualified Language.Haskell.Stylish.Step.LanguagePragmas.Tests
 import qualified Language.Haskell.Stylish.Step.SimpleAlign.Tests
+import qualified Language.Haskell.Stylish.Step.Squash.Tests
 import qualified Language.Haskell.Stylish.Step.Tabs.Tests
 import qualified Language.Haskell.Stylish.Step.TrailingWhitespace.Tests
 import qualified Language.Haskell.Stylish.Step.UnicodeSyntax.Tests
@@ -25,6 +26,7 @@ main = defaultMain
     , Language.Haskell.Stylish.Step.Imports.Tests.tests
     , Language.Haskell.Stylish.Step.LanguagePragmas.Tests.tests
     , Language.Haskell.Stylish.Step.SimpleAlign.Tests.tests
+    , Language.Haskell.Stylish.Step.Squash.Tests.tests
     , Language.Haskell.Stylish.Step.Tabs.Tests.tests
     , Language.Haskell.Stylish.Step.TrailingWhitespace.Tests.tests
     , Language.Haskell.Stylish.Step.UnicodeSyntax.Tests.tests