From 18a128349f76f44fef11290976623cc157268bd3 Mon Sep 17 00:00:00 2001 From: Martin Huschenbett Date: Tue, 1 May 2018 13:58:19 +0200 Subject: Add new step to squash multiple spaces between some elements --- data/stylish-haskell.yaml | 5 + lib/Language/Haskell/Stylish/Align.hs | 4 - lib/Language/Haskell/Stylish/Config.hs | 7 ++ lib/Language/Haskell/Stylish/Step/Squash.hs | 62 +++++++++++ lib/Language/Haskell/Stylish/Util.hs | 14 ++- stylish-haskell.cabal | 3 + .../Language/Haskell/Stylish/Step/Squash/Tests.hs | 121 +++++++++++++++++++++ tests/TestSuite.hs | 2 + 8 files changed, 213 insertions(+), 5 deletions(-) create mode 100644 lib/Language/Haskell/Stylish/Step/Squash.hs create mode 100644 tests/Language/Haskell/Stylish/Step/Squash/Tests.hs 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) @@ -174,6 +176,11 @@ parseSimpleAlign c o = SimpleAlign.step withDef f k = fromMaybe (f SimpleAlign.defaultConfig) <$> (o A..:? k) +-------------------------------------------------------------------------------- +parseSquash :: Config -> A.Object -> A.Parser Step +parseSquash _ _ = return Squash.step + + -------------------------------------------------------------------------------- parseImports :: Config -> A.Object -> A.Parser Step parseImports config o = Imports.step 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, @@ -68,6 +70,16 @@ infoPoints :: H.SrcSpanInfo -> [((Int, Int), (Int, Int))] 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 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 -- cgit v1.2.3