Remove redundant ViewPatterns

See #4

4 files changed, 70 insertions, 15 deletions

diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml
index 688d853..661c516 100644
--- a/.stylish-haskell.yaml
+++ b/.stylish-haskell.yaml
@@ -1,18 +1,22 @@
 stylish:
   # Convert some ASCII sequences to their Unicode equivalents
-  - unicode_syntax: {}
+  # - unicode_syntax: {}
 
   # Import cleanup
   - imports:
-      # Align import names and import lists
+      # Align import names and import lists. Default: true.
       align: true
 
   # Language pragmas
-  - languages_pragmas: {}
+  - languages_pragmas:
+      # stylish-haskell can detect redundancy of some language pragmas. If this
+      # is set to true, it will remove those redundant pragmas. Default: true.
+      remove_redundant: true
 
   # Replace tabs by spaces
   - tabs:
-      # Number of spaces to use for each tab
+      # Number of spaces to use for each tab. Default: 8, as specified by the
+      # Haskell report.
       spaces: 8
 
   # Remove trailing whitespace
diff --git a/src/StylishHaskell/Config.hs b/src/StylishHaskell/Config.hs
index 18c1d24..4b1add8 100644
--- a/src/StylishHaskell/Config.hs
+++ b/src/StylishHaskell/Config.hs
@@ -14,8 +14,8 @@ import           Data.Aeson                                (FromJSON(..))
 import qualified Data.Aeson                                as A
 import qualified Data.Aeson.Types                          as A
 import qualified Data.ByteString                           as B
-import Data.Map (Map)
-import qualified Data.Map as M
+import           Data.Map                                  (Map)
+import qualified Data.Map                                  as M
 import           Data.Yaml                                 (decodeEither)
 import           System.Directory
 import           System.FilePath                           ((</>))
@@ -45,7 +45,7 @@ instance FromJSON Config where
 defaultConfig :: Config
 defaultConfig = Config $
     [ StylishHaskell.Stylish.Imports.stylish True
-    , StylishHaskell.Stylish.LanguagePragmas.stylish
+    , StylishHaskell.Stylish.LanguagePragmas.stylish True
     , StylishHaskell.Stylish.TrailingWhitespace.stylish
     ]
 
@@ -114,18 +114,19 @@ parseStylish val = do
 --------------------------------------------------------------------------------
 parseImports :: A.Object -> A.Parser Stylish
 parseImports o = StylishHaskell.Stylish.Imports.stylish
-    <$> o A..: "align"
+    <$> o A..:? "align" A..!= True
 
 
 --------------------------------------------------------------------------------
 parseLanguagePragmas :: A.Object -> A.Parser Stylish
-parseLanguagePragmas _ = return StylishHaskell.Stylish.LanguagePragmas.stylish
+parseLanguagePragmas o = StylishHaskell.Stylish.LanguagePragmas.stylish
+    <$> o A..:? "remove_redundant" A..!= True
 
 
 --------------------------------------------------------------------------------
 parseTabs :: A.Object -> A.Parser Stylish
 parseTabs o = StylishHaskell.Stylish.Tabs.stylish
-    <$> o A..: "spaces"
+    <$> o A..:? "spaces" A..!= 8
 
 
 --------------------------------------------------------------------------------
diff --git a/src/StylishHaskell/Stylish/LanguagePragmas.hs b/src/StylishHaskell/Stylish/LanguagePragmas.hs
index f4da813..60e3187 100644
--- a/src/StylishHaskell/Stylish/LanguagePragmas.hs
+++ b/src/StylishHaskell/Stylish/LanguagePragmas.hs
@@ -44,15 +44,19 @@ prettyPragmas pragmas' =
 
 
 --------------------------------------------------------------------------------
-stylish :: Stylish
-stylish ls (module', _)
+stylish :: Bool -> Stylish
+stylish removeRedundant ls (module', _)
     | null pragmas' = ls
     | otherwise     = applyChanges changes ls
   where
+    filterRedundant
+        | removeRedundant = filter (not . isRedundant module')
+        | otherwise       = id
+
     pragmas' = pragmas $ fmap linesFromSrcSpan module'
-    deletes  = map (delete . fst) pragmas'
-    uniques  = nub $ sort $ concatMap snd pragmas'
+    uniques  = filterRedundant $ nub $ sort $ snd =<< pragmas'
     loc      = firstLocation pragmas'
+    deletes  = map (delete . fst) pragmas'
     changes  = insert loc (prettyPragmas uniques) : deletes
 
 
@@ -66,3 +70,18 @@ addLanguagePragma pragma modu
     pragmas' = pragmas (fmap linesFromSrcSpan modu)
     present  = concatMap snd pragmas'
     line     = if null pragmas' then 1 else firstLocation pragmas'
+
+
+--------------------------------------------------------------------------------
+-- | Check if a language pragma is redundant. We can't do this for all pragmas,
+-- but we do a best effort.
+isRedundant :: H.Module H.SrcSpanInfo -> String -> Bool
+isRedundant m "ViewPatterns" = isRedundantViewPatterns m
+isRedundant _ _              = False
+
+
+--------------------------------------------------------------------------------
+-- | Check if the ViewPatterns language pragma is redundant.
+isRedundantViewPatterns :: H.Module H.SrcSpanInfo -> Bool
+isRedundantViewPatterns m = null
+    [() | H.PViewPat _ _ _ <- everything m :: [H.Pat H.SrcSpanInfo]]
diff --git a/tests/StylishHaskell/Stylish/LanguagePragmas/Tests.hs b/tests/StylishHaskell/Stylish/LanguagePragmas/Tests.hs
index 80a50bc..c802f62 100644
--- a/tests/StylishHaskell/Stylish/LanguagePragmas/Tests.hs
+++ b/tests/StylishHaskell/Stylish/LanguagePragmas/Tests.hs
@@ -19,12 +19,14 @@ import           StylishHaskell.Tests.Util
 tests :: Test
 tests = testGroup "StylishHaskell.Stylish.LanguagePragmas.Tests"
     [ case01
+    , case02
+    , case03
     ]
 
 
 --------------------------------------------------------------------------------
 case01 :: Test
-case01 = testCase "case 01" $ expected @=? testStylish stylish input
+case01 = testCase "case 01" $ expected @=? testStylish (stylish False) input
   where
     input = unlines
         [ "{-# LANGUAGE ViewPatterns #-}"
@@ -39,3 +41,32 @@ case01 = testCase "case 01" $ expected @=? testStylish stylish input
         , "{-# LANGUAGE ViewPatterns        #-}"
         , "module Main where"
         ]
+
+
+--------------------------------------------------------------------------------
+case02 :: Test
+case02 = testCase "case 02" $ expected @=? testStylish (stylish True) input
+  where
+    input = unlines
+        [ "{-# LANGUAGE ViewPatterns #-}"
+        , "increment ((+ 1) -> x) = x"
+        ]
+
+    expected = unlines
+        [ "{-# LANGUAGE ViewPatterns #-}"
+        , "increment ((+ 1) -> x) = x"
+        ]
+
+
+--------------------------------------------------------------------------------
+case03 :: Test
+case03 = testCase "case 03" $ expected @=? testStylish (stylish True) input
+  where
+    input = unlines
+        [ "{-# LANGUAGE ViewPatterns #-}"
+        , "increment x = x + 1"
+        ]
+
+    expected = unlines
+        [ "increment x = x + 1"
+        ]