Disabling formatting of the block of code

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

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

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

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

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
 

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

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

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) <>

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

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"
+  ]

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
     ]