Pass enabled and disabled extensions to apply-refact

ndmitchell · Jun 1, 2020 · d699810 · d699810
1 parent 2007bd9
commit d699810
Show file tree

Hide file tree

Showing 8 changed files with 27 additions and 20 deletions.
diff --git a/data/hlint.yaml b/data/hlint.yaml
@@ -1100,8 +1100,7 @@
 # main = let (first, rest) = (take n l, drop n l) in rest -- splitAt n l
 # main = fst (splitAt n l) -- take n l
 # main = snd $ splitAt n l -- drop n l
-# main = map $ \ d -> ([| $d |], [| $d |]) @NoRefactor: apply-refact requires TemplateHaskell pragma
-# {-# LANGUAGE TemplateHaskell #-}; main = map $ \ d -> ([| $d |], [| $d |])
+# main = map $ \ d -> ([| $d |], [| $d |])
 # pairs (x:xs) = map (x,) xs ++ pairs xs
 # {-# ANN foo "HLint: ignore" #-};foo = map f (map g x) -- @Ignore ???
 # {-# HLINT ignore foo #-};foo = map f (map g x) -- @Ignore ???
@@ -1194,10 +1193,10 @@
 # fromList [] -- Data.Map.Lazy.empty
 # import Data.Map.Strict (fromList) \
 # fromList [] -- Data.Map.Strict.empty
-# test953 = for [] $ \n -> bar n >>= \case {Just n  -> pure (); Nothing -> baz n} @NoRefactor
+# test953 = for [] $ \n -> bar n >>= \case {Just n  -> pure (); Nothing -> baz n}
 # f = map (flip (,) "a") "123" -- (,"a")
 # f = map ((,) "a") "123" -- ("a",)
-# test979 = flip Map.traverseWithKey blocks \k v -> lots_of_code_goes_here @NoRefactor
+# test979 = flip Map.traverseWithKey blocks \k v -> lots_of_code_goes_here
 # infixl 4 <*! \
 # test993 = f =<< g <$> x <*! y
 # </TEST>
diff --git a/src/Extension.hs b/src/Extension.hs
@@ -24,6 +24,9 @@ reallyBadExtensions =
   {- , XmlSyntax , RegularPatterns -} -- steals a-b and < operators
   , AlternativeLayoutRule -- Does not play well with 'MultiWayIf'
   , NegativeLiterals -- Was not enabled by HSE and enabling breaks tests.
+  , StarIsType -- conflicts with TypeOperators. StarIsType is currently enabled by default,
+               -- so adding it here has no effect except avoiding passing it to apply-refact.
+               -- See https://github.com/mpickering/apply-refact/issues/58
   ]
 
 -- | Extensions we turn on by default when parsing. Aim to parse as

diff --git a/src/HLint.hs b/src/HLint.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 
@@ -8,6 +9,7 @@ import Control.Monad.Extra
 import Control.Exception.Extra
 import Control.Concurrent.Extra
 import System.Console.CmdArgs.Verbosity
+import GHC.LanguageExtensions.Type
 import GHC.Util.DynFlags
 import Data.List.Extra
 import GHC.Conc
@@ -153,7 +155,8 @@ runHints args settings cmd@CmdMain{..} = do
     j <- if cmdThreads == 0 then getNumProcessors else pure cmdThreads
     withNumCapabilities j $ do
         let outStrLn = whenNormal . putStrLn
-        ideas <- getIdeas cmd settings
+            flags@ParseFlags{enabledExtensions, disabledExtensions} = cmdParseFlags cmd
+        ideas <- getIdeas cmd flags settings
         ideas <- pure $ if cmdShowAll then ideas else  filter (\i -> ideaSeverity i /= Ignore) ideas
         if cmdJson then
             putStrLn $ showIdeasJson ideas
@@ -163,18 +166,17 @@ runHints args settings cmd@CmdMain{..} = do
             hSetBuffering stdout NoBuffering
             print $ map (show &&& ideaRefactoring) ideas
          else if cmdRefactor then
-            handleRefactoring ideas cmdFiles cmd
+            handleRefactoring ideas cmdFiles cmd enabledExtensions disabledExtensions
          else do
             usecolour <- cmdUseColour cmd
             showItem <- if usecolour then showANSI else pure show
             mapM_ (outStrLn . showItem) ideas
             handleReporting ideas cmd
         pure ideas
 
-getIdeas :: Cmd -> [Setting] -> IO [Idea]
-getIdeas cmd@CmdMain{..} settings = do
+getIdeas :: Cmd -> ParseFlags -> [Setting] -> IO [Idea]
+getIdeas CmdMain{..} flags settings = do
     settings <- pure $ settings ++ map (Builtin . fst) builtinHints
-    let flags = cmdParseFlags cmd
     ideas <- if cmdCross
         then applyHintFiles flags settings cmdFiles
         else concat <$> parallel cmdThreads [evaluateList =<< applyHintFile flags settings x Nothing | x <- cmdFiles]
@@ -184,8 +186,8 @@ getIdeas cmd@CmdMain{..} settings = do
 
 -- #746: run refactor even if no hint, which ensures consistent output
 -- whether there are hints or not.
-handleRefactoring :: [Idea] -> [String] -> Cmd -> IO ()
-handleRefactoring ideas files cmd@CmdMain{..} =
+handleRefactoring :: [Idea] -> [String] -> Cmd -> [Extension] -> [Extension] -> IO ()
+handleRefactoring ideas files cmd@CmdMain{..} ys ns =
     case cmdFiles of
         [file] -> do
             -- Ensure that we can find the executable
@@ -194,7 +196,7 @@ handleRefactoring ideas files cmd@CmdMain{..} =
             let hints =  show $ map (show &&& ideaRefactoring) ideas
             withTempFile $ \f -> do
                 writeFile f hints
-                exitWith =<< runRefactoring path file f cmdRefactorOptions
+                exitWith =<< runRefactoring path file f ys ns cmdRefactorOptions
         _ -> errorIO "Refactor flag can only be used with an individual file"
 
 

diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs
@@ -41,7 +41,7 @@ issue909 = foo (\((x : z) -> y) -> 9 + x * 7) -- \(x : z -> y) -> 9 + x * 7
 issue909 = let ((x:: y) -> z) = q in q
 issue909 = do {((x :: y) -> z) <- e; return 1}
 issue970 = (f x +) (g x) -- f x + (g x) @NoRefactor
-issue969 = (Just \x -> x || x) *> Just True @NoRefactor
+issue969 = (Just \x -> x || x) *> Just True
 
 -- type bracket reduction
 foo :: (Int -> Int) -> Int

diff --git a/src/Hint/Pattern.hs b/src/Hint/Pattern.hs
@@ -26,17 +26,17 @@ foo = case v of v -> x -- x
 foo = case v of z -> z
 foo = case v of _ | False -> x
 foo x | x < -2 * 3 = 4 @NoRefactor: ghc-exactprint bug; -2 becomes 2.
-foo = case v of !True -> x -- True @NoRefactor: apply-refact requires BangPatterns pragma
+foo = case v of !True -> x -- True
 {-# LANGUAGE BangPatterns #-}; foo = case v of !True -> x -- True
 {-# LANGUAGE BangPatterns #-}; foo = case v of !(Just x) -> x -- (Just x)
 {-# LANGUAGE BangPatterns #-}; foo = case v of !(x : xs) -> x -- (x:xs)
 {-# LANGUAGE BangPatterns #-}; foo = case v of !1 -> x -- 1
 {-# LANGUAGE BangPatterns #-}; foo = case v of !x -> x
-{-# LANGUAGE BangPatterns #-}; foo = case v of !(I# x) -> y -- (I# x) @NoRefactor
+{-# LANGUAGE BangPatterns #-}; foo = case v of !(I# x) -> y -- (I# x)
 foo = let ~x = 1 in y -- x
 foo = let ~(x:xs) = y in z
 {-# LANGUAGE BangPatterns #-}; foo = let !x = undefined in y
-{-# LANGUAGE BangPatterns #-}; foo = let !(I# x) = 4 in x @NoRefactor
+{-# LANGUAGE BangPatterns #-}; foo = let !(I# x) = 4 in x
 {-# LANGUAGE BangPatterns #-}; foo = let !(Just x) = Nothing in 3
 {-# LANGUAGE BangPatterns #-}; foo = 1 where f !False = 2 -- False
 {-# LANGUAGE BangPatterns #-}; foo = 1 where !False = True

diff --git a/src/Hint/Pragma.hs b/src/Hint/Pragma.hs
@@ -20,7 +20,7 @@
 {-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-} @NoRefactor -foo is not a valid flag
 {-# OPTIONS_GHC -cpp -w #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -w #-} @NoRefactor: the two pragmas are switched in the refactoring output
 {-# OPTIONS_GHC -cpp #-} \
-{-# LANGUAGE CPP, Text #-} -- @NoRefactor
+{-# LANGUAGE CPP, Text #-} --
 {-# LANGUAGE RebindableSyntax #-} \
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RebindableSyntax #-} \

diff --git a/src/Refact.hs b/src/Refact.hs
@@ -10,6 +10,7 @@ import Control.Exception.Extra
 import Control.Monad
 import Data.Maybe
 import Data.Version.Extra
+import GHC.LanguageExtensions.Type
 import System.Directory.Extra
 import System.Exit
 import System.IO.Extra
@@ -53,9 +54,10 @@ refactorPath rpath = do
                        , "<https://github.com/mpickering/apply-refact>"
                        ]
 
-runRefactoring :: FilePath -> FilePath -> FilePath -> String -> IO ExitCode
-runRefactoring rpath fin hints opts =  do
+runRefactoring :: FilePath -> FilePath -> FilePath -> [Extension] -> [Extension] -> String -> IO ExitCode
+runRefactoring rpath fin hints ys ns opts =  do
     let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints]
+          ++ [yes | e <- ys, yes <- ["-X", show e]] ++ [no | e <- ns, no <- ["-X", "No" ++ show e]]
     (_, _, _, phand) <- createProcess $ proc rpath args
     try $ hSetBuffering stdin LineBuffering :: IO (Either IOException ())
     hSetBuffering stdout LineBuffering

diff --git a/src/Test/Annotations.hs b/src/Test/Annotations.hs
@@ -23,6 +23,7 @@ import qualified Data.ByteString.Char8 as BS
 import Config.Type
 import Idea
 import Apply
+import Extension
 import Refact
 import Test.Util
 import Prelude
@@ -161,7 +162,7 @@ testRefactor (Just rpath) midea inp = withTempFile $ \tempInp -> withTempFile $
         x `isProperSubsequenceOf` y = x /= y && x `isSubsequenceOf` y
     writeFile tempInp inp
     writeFile tempHints (show refacts)
-    exitCode <- runRefactoring rpath tempInp tempHints "--inplace"
+    exitCode <- runRefactoring rpath tempInp tempHints defaultExtensions [] "--inplace"
     refactored <- readFile tempInp
     pure $ case exitCode of
         ExitFailure ec -> ["Refactoring failed: exit code " ++ show ec]