diff --git a/lib/Language/Haskell/Stylish/Editor.hs b/lib/Language/Haskell/Stylish/Editor.hs index c2f8d23b..8a9531d3 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,19 @@ data Change | CLine Int Int String +-- | 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) + +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 +185,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 +210,36 @@ 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 -> + case changeLength change of + Just len -> all ((start, start + len - 1) `disjoint`) disRngs + Nothing -> True + switches = sortOn fst . mapMaybe getSwitch $ everything modu + 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) + 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..c9f8da67 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Disabling.hs @@ -0,0 +1,137 @@ +{-# 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 + , 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 + ] + +-------------------------------------------------------------------------------- +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" + ] + + +-------------------------------------------------------------------------------- +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" + ] 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 ]