From 12c1454b2c51991a59524e4b23cc214dcde2fe03 Mon Sep 17 00:00:00 2001 From: Lev Dvorkin Date: Thu, 29 Dec 2022 19:06:03 +0300 Subject: [PATCH 1/2] Disabling formatting of the block of code --- lib/Language/Haskell/Stylish/Editor.hs | 56 ++++++++++++- lib/Language/Haskell/Stylish/Step/Data.hs | 2 +- lib/Language/Haskell/Stylish/Step/Imports.hs | 2 +- .../Haskell/Stylish/Step/LanguagePragmas.hs | 2 +- .../Haskell/Stylish/Step/ModuleHeader.hs | 2 +- .../Haskell/Stylish/Step/SimpleAlign.hs | 2 +- lib/Language/Haskell/Stylish/Step/Squash.hs | 4 +- .../Haskell/Stylish/Step/UnicodeSyntax.hs | 2 +- stylish-haskell.cabal | 1 + tests/Language/Haskell/Stylish/Disabling.hs | 78 +++++++++++++++++++ tests/TestSuite.hs | 2 + 11 files changed, 141 insertions(+), 12 deletions(-) create mode 100644 tests/Language/Haskell/Stylish/Disabling.hs diff --git a/lib/Language/Haskell/Stylish/Editor.hs b/lib/Language/Haskell/Stylish/Editor.hs index c2f8d23b..c1df2fd6 100644 --- a/lib/Language/Haskell/Stylish/Editor.hs +++ b/lib/Language/Haskell/Stylish/Editor.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} -------------------------------------------------------------------------------- -- | This module provides you with a line-based editor. It's main feature is @@ -24,12 +25,18 @@ module Language.Haskell.Stylish.Editor -------------------------------------------------------------------------------- import qualified Data.Map as M -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block +import Language.Haskell.Stylish.Module (Module) +import Language.Haskell.Stylish.Util (everything) +import qualified GHC.Hs as GHC +import Data.Char (toLower) +import Data.List (sortOn) +import Data.Foldable (foldl') -------------------------------------------------------------------------------- @@ -42,6 +49,16 @@ data Change | CLine Int Int String +changeLength :: Change -> Int +changeLength (CBlock n _) = n +changeLength _ = 1 + +-------------------------------------------------------------------------------- +type RowRange = (Int, Int) + +disjoint :: RowRange -> RowRange -> Bool +disjoint (l1, r1) (l2, r2) = r1 < l2 || r2 < l1 + -------------------------------------------------------------------------------- -- | Due to the function in CBlock we cannot write a lawful Ord instance, but -- this lets us merge-sort changes. @@ -165,12 +182,13 @@ conflicts (Edits edits) = M.toAscList edits >>= uncurry checkChanges -------------------------------------------------------------------------------- -apply :: Edits -> [String] -> [String] -apply (Edits edits) = case conflicts (Edits edits) of +apply :: Edits -> Module -> [String] -> [String] +apply allEdits modul = case conflicts edits of c : _ -> error $ "Language.Haskell.Stylish.Editor: " ++ prettyConflict c _ -> go 1 (editsFor 1) where - editsFor i = fromMaybe [] $ M.lookup i edits + edits = filterEdits allEdits modul + editsFor i = fromMaybe [] $ M.lookup i (unEdits edits) go _ _ [] = [] go i [] (l : ls) = l : go (i + 1) (editsFor $ i + 1) ls @@ -189,3 +207,33 @@ apply (Edits edits) = case conflicts (Edits edits) of let offset = length x - (xend - xstart) in CLine (ystart + offset) (yend + offset) y | otherwise = CLine ystart yend y + +------------------------------------------------------------------------------- +filterEdits :: Edits -> Module -> Edits +filterEdits (Edits allEdits) modu = Edits $ M.mapWithKey filt allEdits + where + filt start = filter \change -> + let rng = (start, start + changeLength change) + in all (rng `disjoint`) disRngs + switches = sortOn fst . mapMaybe getSwitch $ everything modu + disRngs = fst $ foldl' step ([], Nothing) switches + + step (xs, Nothing) (start, StylishDisable) + = (xs, Just start) + step (xs, Just start) (stop, StylishEnable) + = (xs ++ [(start, stop)], Nothing) + step state _ = state + +data Switch = StylishEnable | StylishDisable + deriving (Eq, Ord, Show) + +getSwitch :: GHC.LEpaComment -> Maybe (Int, Switch) +getSwitch (GHC.L l (GHC.EpaComment comm _)) + | GHC.EpaBlockComment str <- comm + , ["{-", str', "-}"] <- words str + , line <- GHC.srcLocLine (GHC.realSrcSpanStart (GHC.anchor l)) + = case toLower <$> str' of + "stylish_disable" -> Just (line, StylishDisable) + "stylish_enable" -> Just (line, StylishEnable) + _ -> Nothing + | otherwise = Nothing diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index a2db12d4..130b92e1 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -87,7 +87,7 @@ defaultConfig = Config } step :: Config -> Step -step cfg = makeStep "Data" \ls m -> Editor.apply (changes m) ls +step cfg = makeStep "Data" \ls m -> Editor.apply (changes m) m ls where changes :: Module -> Editor.Edits changes = foldMap (formatDataDecl cfg) . dataDecls diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index 881030ba..206b825c 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -204,7 +204,7 @@ step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns -------------------------------------------------------------------------------- printImports :: Maybe Int -> Options -> Lines -> Module -> Lines -printImports maxCols options ls m = Editor.apply changes ls +printImports maxCols options ls m = Editor.apply changes m ls where groups = moduleImportGroups m moduleStats = foldMap importStats . fmap GHC.unLoc $ concatMap toList groups diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs index 24b2c886..9b092a25 100644 --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -121,7 +121,7 @@ step = ((((makeStep "LanguagePragmas" .) .) .) .) . step' step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines step' columns style align removeRedundant lngPrefix ls m | null languagePragmas = ls - | otherwise = Editor.apply changes ls + | otherwise = Editor.apply changes m ls where isRedundant' | removeRedundant = isRedundant m diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index a420e186..60c227bf 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -113,7 +113,7 @@ printModuleHeader maxCols conf ls lmodul = (Editor.Block startLine endLine) (const printedModuleHeader) in - Editor.apply changes ls + Editor.apply changes lmodul ls where doSort = if sort conf then fmap (commentGroupSort compareLIE) else id diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index 28d77f91..df8a3809 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -196,4 +196,4 @@ step maxColumns config = makeStep "Cases" $ \ls module' -> changes records (recordToAlignable config) <> changes everything (matchGroupToAlignable config) <> changes everything (multiWayIfToAlignable config) in - Editor.apply configured ls + Editor.apply configured module' ls diff --git a/lib/Language/Haskell/Stylish/Step/Squash.hs b/lib/Language/Haskell/Stylish/Step/Squash.hs index f8a2f1ae..0ac0e809 100644 --- a/lib/Language/Haskell/Stylish/Step/Squash.hs +++ b/lib/Language/Haskell/Stylish/Step/Squash.hs @@ -82,8 +82,8 @@ matchSeparator _ = Nothing -------------------------------------------------------------------------------- step :: Step -step = makeStep "Squash" $ \ls (module') -> +step = makeStep "Squash" $ \ls module' -> let changes = foldMap squashFieldDecl (everything module') <> foldMap squashMatch (everything module') in - Editor.apply changes ls + Editor.apply changes module' ls diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 04626433..2dd52418 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -44,7 +44,7 @@ step = (makeStep "UnicodeSyntax" .) . step' -------------------------------------------------------------------------------- step' :: Bool -> String -> Lines -> Module -> Lines -step' alp lg ls modu = Editor.apply edits ls +step' alp lg ls modu = Editor.apply edits modu ls where edits = foldMap hsTyReplacements (everything modu) <> diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index a2145520..36397a6a 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -122,6 +122,7 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish.Config.Tests Language.Haskell.Stylish.Parse.Tests Language.Haskell.Stylish.Regressions + Language.Haskell.Stylish.Disabling Language.Haskell.Stylish.Step.Data.Tests Language.Haskell.Stylish.Step.Imports.FelixTests Language.Haskell.Stylish.Step.Imports.Tests diff --git a/tests/Language/Haskell/Stylish/Disabling.hs b/tests/Language/Haskell/Stylish/Disabling.hs new file mode 100644 index 00000000..57cd4e10 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Disabling.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedLists #-} +module Language.Haskell.Stylish.Disabling where + +import qualified Language.Haskell.Stylish.Step.ModuleHeader as Header +import qualified Language.Haskell.Stylish.Step.Data as Data +import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as Unicode +import Language.Haskell.Stylish.Tests.Util (assertSnippet) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion) + + +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Disabling" + [ testCase "Header formatiing disabled" case00 + , testCase "One of several Datas formatting disabled" case01 + , testCase "Unicode (one-symbol replacement)" case02 + ] + +-------------------------------------------------------------------------------- +case00 :: Assertion +case00 = assertSnippet (Header.step (Just 80) Header.defaultConfig) inp inp + where + inp = + [ "{- STYLISH_DISABLE -}" + , "module Main (foo, bar) where" + , "{- STYLISH_ENABLE -}" + ] + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = assertSnippet (Data.step Data.defaultConfig) + [ "data Foo = Foo" + , "" + , "{- stylish_disable -}" + , "data Bar = Bar" + , "{- stylish_enable -}" + , "data Baz = Baz" + ] + [ "data Foo" + , " = Foo" + , "" + , "{- stylish_disable -}" + , "data Bar = Bar" + , "{- stylish_enable -}" + , "data Baz" + , " = Baz" + ] + + +-------------------------------------------------------------------------------- +case02 :: Assertion +case02 = assertSnippet (Unicode.step True "LANGUAGE") + [ "foo :: Int -> String" + , "foo = undefined" + , "{- stylish_disable -}" + , "bar :: Int" + , "bar = undefined" + , "{- stylish_enable -}" + , "" + , "baz :: String {- stylish_disable -}" + , "baz = undefined" + , "{- stylish_enable -} baz' :: Int" + , "baz' = undefined" + ] + [ "{-# LANGUAGE UnicodeSyntax #-}" + , "foo ∷ Int → String" + , "foo = undefined" + , "{- stylish_disable -}" + , "bar :: Int" + , "bar = undefined" + , "{- stylish_enable -}" + , "" + , "baz :: String {- stylish_disable -}" + , "baz = undefined" + , "{- stylish_enable -} baz' :: Int" + , "baz' = undefined" + ] diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index 8d4b6956..8811bba1 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -23,6 +23,7 @@ import qualified Language.Haskell.Stylish.Step.TrailingWhitespace.Tests import qualified Language.Haskell.Stylish.Step.UnicodeSyntax.Tests import qualified Language.Haskell.Stylish.Tests import qualified Language.Haskell.Stylish.Regressions +import qualified Language.Haskell.Stylish.Disabling -------------------------------------------------------------------------------- @@ -42,4 +43,5 @@ main = defaultMain , Language.Haskell.Stylish.Step.UnicodeSyntax.Tests.tests , Language.Haskell.Stylish.Tests.tests , Language.Haskell.Stylish.Regressions.tests + , Language.Haskell.Stylish.Disabling.tests ] From da911811dbb914de981c4b754f6cb6110ae6e83a Mon Sep 17 00:00:00 2001 From: Lev Dvorkin Date: Fri, 30 Dec 2022 10:33:36 +0300 Subject: [PATCH 2/2] Some edge cases added (see tests) --- lib/Language/Haskell/Stylish/Editor.hs | 18 ++++--- tests/Language/Haskell/Stylish/Disabling.hs | 59 +++++++++++++++++++++ 2 files changed, 71 insertions(+), 6 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Editor.hs b/lib/Language/Haskell/Stylish/Editor.hs index c1df2fd6..8a9531d3 100644 --- a/lib/Language/Haskell/Stylish/Editor.hs +++ b/lib/Language/Haskell/Stylish/Editor.hs @@ -49,9 +49,12 @@ data Change | CLine Int Int String -changeLength :: Change -> Int -changeLength (CBlock n _) = n -changeLength _ = 1 +-- | Used for filtering changes from the disabled blocks +-- Returns `Nothing` if the change shouldn't be reverted in any case +changeLength :: Change -> Maybe Int +changeLength (CInsert _) = Nothing +changeLength (CBlock n _) = Just n +changeLength (CLine{}) = Just 1 -------------------------------------------------------------------------------- type RowRange = (Int, Int) @@ -213,10 +216,13 @@ filterEdits :: Edits -> Module -> Edits filterEdits (Edits allEdits) modu = Edits $ M.mapWithKey filt allEdits where filt start = filter \change -> - let rng = (start, start + changeLength change) - in all (rng `disjoint`) disRngs + case changeLength change of + Just len -> all ((start, start + len - 1) `disjoint`) disRngs + Nothing -> True switches = sortOn fst . mapMaybe getSwitch $ everything modu - disRngs = fst $ foldl' step ([], Nothing) switches + disRngs = addLast $ foldl' step ([], Nothing) switches + addLast (xs, Just start) = xs ++ [(start, maxBound)] + addLast (xs, Nothing) = xs step (xs, Nothing) (start, StylishDisable) = (xs, Just start) diff --git a/tests/Language/Haskell/Stylish/Disabling.hs b/tests/Language/Haskell/Stylish/Disabling.hs index 57cd4e10..c9f8da67 100644 --- a/tests/Language/Haskell/Stylish/Disabling.hs +++ b/tests/Language/Haskell/Stylish/Disabling.hs @@ -15,6 +15,9 @@ tests = testGroup "Language.Haskell.Stylish.Disabling" [ testCase "Header formatiing disabled" case00 , testCase "One of several Datas formatting disabled" case01 , testCase "Unicode (one-symbol replacement)" case02 + , testCase "Disabling at the next line should not effect" case03 + , testCase "Disabling to the end of file" case04 + , testCase "Insertion works even when stylish is disabled in this region" case05 ] -------------------------------------------------------------------------------- @@ -76,3 +79,59 @@ case02 = assertSnippet (Unicode.step True "LANGUAGE") , "{- stylish_enable -} baz' :: Int" , "baz' = undefined" ] + + +-------------------------------------------------------------------------------- +case03 :: Assertion +case03 = assertSnippet (Unicode.step True "LANGUAGE") + [ "foo :: Int -> String" + , "{- stylish_disable -}" + , "foo = undefined" + , "{- stylish_enable -}" + ] + [ "{-# LANGUAGE UnicodeSyntax #-}" + , "foo ∷ Int → String" + , "{- stylish_disable -}" + , "foo = undefined" + , "{- stylish_enable -}" + ] + + +case04 :: Assertion +case04 = assertSnippet (Unicode.step True "Language") + [ "foo :: Int -> String" + , "foo = undefined" + , "" + , "{- stylish_disable -}" + , "bar :: Int" + , "bar = unedefined" + ] + [ "{-# Language UnicodeSyntax #-}" + , "foo ∷ Int → String" + , "foo = undefined" + , "" + , "{- stylish_disable -}" + , "bar :: Int" + , "bar = unedefined" + ] + +-------------------------------------------------------------------------------- +case05 :: Assertion +case05 = assertSnippet (Unicode.step True "LANGUAGE") + [ "{- stylish_disable -}" + , "{-# LANGUAGE LambdaCase #-}" + , "" + , "{- stylish_enable -}" + , "" + , "foo :: Int -> String" + , "foo = undefined" + ] + [ "{- stylish_disable -}" + , "{-# LANGUAGE UnicodeSyntax #-}" + , "{-# LANGUAGE LambdaCase #-}" + , "" + , "{- stylish_enable -}" + , "" + , "foo ∷ Int → String" + , "foo = undefined" + ]