Merge branch 'master' of github.com:ndmitchell/hlint into typeOf

ndmitchell · Apr 24, 2020 · aa10770 · aa10770
2 parents 12fcea3 + dafb909
commit aa10770
Show file tree

Hide file tree

Showing 9 changed files with 27 additions and 15 deletions.
diff --git a/CHANGES.txt b/CHANGES.txt
@@ -1,5 +1,6 @@
 Changelog for HLint (* = breaking change)
 
+    #952, improve refactorings with qualified imports
     #945, suggest Map.fromList [] ==> Map.empty
     #949, warn about redundant fmaps with binds
     #950, reduce the span of "Redundant $" to only cover the "$"

diff --git a/data/hlint.yaml b/data/hlint.yaml
@@ -1006,7 +1006,7 @@
 # yes = if nullPS s then return False else if headPS s /= '\n' then return False else alter_input tailPS >> return True \
 #     -- if nullPS s || (headPS s /= '\n') then return False else alter_input tailPS >> return True
 # yes = if foo then do stuff; moreStuff; lastOfTheStuff else return () \
-#     -- Control.Monad.when foo $ do stuff ; moreStuff ; lastOfTheStuff @NoRefactor: hlint bug
+#     -- Control.Monad.when foo $ do stuff ; moreStuff ; lastOfTheStuff
 # yes = if foo then stuff else return () -- Control.Monad.when foo stuff
 # yes = foo $ \(a, b) -> (a, y + b) -- Data.Bifunctor.second ((+) y)
 # no  = foo $ \(a, b) -> (a, a + b)
@@ -1137,8 +1137,7 @@
 # import qualified Control.Monad \
 # yes = flip mapM -- Control.Monad.forM
 # import qualified Control.Monad as CM \
-# yes = flip mapM -- CM.forM @NoRefactor hlint bug: expected CM.forM, actual Control.Monad.forM
-# @NoRefactor hlint bug: expected CM.forM, actual Control.Monad.forM \
+# yes = flip mapM -- CM.forM
 # import qualified Control.Monad as CM(forM,filterM) \
 # yes = flip mapM -- CM.forM
 # import Control.Monad as CM(forM,filterM) \
@@ -1153,7 +1152,7 @@
 # main = A.id (stringValue id')
 # import Prelude((==)) \
 # import qualified Prelude as P \
-# main = P.length xs == 0 -- P.null xs @NoRefactor hlint bug: null xs (missing "P.")
+# main = P.length xs == 0 -- P.null xs
 # main = hello .~ Just 12 -- hello ?~ 12
 # foo = liftIO $ window `on` deleteEvent $ do a; b
 # no = sort <$> f input `shouldBe` sort <$> x

diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs
@@ -74,7 +74,7 @@ foo = (case x of y -> z; q -> w) :: Int
 main = do a += b . c; return $ a . b
 
 -- <$> bracket tests
-yes = (foo . bar x) <$> baz q -- foo . bar x <$> baz q @NoRefactor hlint bug: ideaRefactoring = []
+yes = (foo . bar x) <$> baz q -- foo . bar x <$> baz q @NoRefactor: refactoring for "(v1 . v2) <$> v3" is not implemented
 no = foo . bar x <$> baz q
 
 -- annotations

diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs
@@ -192,7 +192,7 @@ foo = Foo{x}
 foo = bar{x}
 {-# LANGUAGE NamedFieldPuns #-} --
 {-# LANGUAGE StaticPointers #-} \
-static = 42 -- @NoRefactor: cannot refactor parse errors
+static = 42 --
 </TEST>
 -}
 

diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs
@@ -26,7 +26,7 @@ f (Just a) = \a -> a + a -- f (Just _) a = a + a @NoRefactor
 f a = \x -> x + x where _ = test
 f (test -> a) = \x -> x + x
 f = \x -> x + x -- f x = x + x
-fun x y z = f x y z -- fun = f @NoRefactor: hlint bug, ideaRefactoring = []
+fun x y z = f x y z -- fun = f @NoRefactor: refactoring for eta reduce is not implemented
 fun x y z = f x x y z -- fun x = f x x @NoRefactor
 fun x y z = f g z -- fun x y = f g @NoRefactor
 fun x = f . g $ x -- fun = f . g @NoRefactor

diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs
@@ -158,7 +158,7 @@ matchIdea' sb declName HintRule{..} parent x = do
   guard $ checkDefine' declName parent res
 
   (u, tpl) <- pure $ if any ((== noSrcSpan) . getLoc . snd) (fromSubst' u) then (mempty, res) else (u, tpl)
-  tpl <- pure (performSpecial' tpl)
+  tpl <- pure $ unqualify' sa sb (performSpecial' tpl)
 
   pure (res, tpl, hintRuleNotes, [(s, toSS' pos) | (s, pos) <- fromSubst' u, getLoc pos /= noSrcSpan])
 

diff --git a/src/Hint/NewType.hs b/src/Hint/NewType.hs
@@ -5,7 +5,7 @@
     quantified data types because it is not valid.
 
 <TEST>
-data Foo = Foo Int -- newtype Foo = Foo Int @NoRefactor hlint bug: ideaRefactoring = []
+data Foo = Foo Int -- newtype Foo = Foo Int @NoRefactor: refactoring for "Use newtype" is not implemented
 data Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo Int deriving (Show, Eq) @NoRefactor
 data Foo = Foo { field :: Int } deriving Show -- newtype Foo = Foo { field :: Int } deriving Show @NoRefactor
 data Foo a b = Foo a -- newtype Foo a b = Foo a @NoRefactor

diff --git a/src/Hint/Pattern.hs b/src/Hint/Pattern.hs
@@ -16,7 +16,7 @@ foo b | c <- f b = c \
       | c <- f b = c
 foo x = yes x x where yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e
 foo x | otherwise = y -- foo x = y
-foo x = x + x where --
+foo x = x + x where -- @NoRefactor: refactoring for "Redundant where" is not implemented
 foo x | a = b | True = d -- foo x | a = b ; | otherwise = d
 foo (Bar _ _ _ _) = x -- Bar{}
 foo (Bar _ x _ _) = x

diff --git a/src/Test/Annotations.hs b/src/Test/Annotations.hs
@@ -5,17 +5,18 @@ module Test.Annotations(testAnnotations) where
 
 import Control.Exception.Extra
 import Control.Monad
-import Data.Tuple.Extra
+import Control.Monad.IO.Class
 import Data.Char
 import Data.Either.Extra
+import Data.Function
+import Data.Functor
 import Data.List.Extra
 import Data.Maybe
+import Data.Tuple.Extra
+import Data.Yaml
 import System.Exit
 import System.FilePath
 import System.IO.Extra
-import Control.Monad.IO.Class
-import Data.Function
-import Data.Yaml
 import HSE.All
 import qualified Data.ByteString.Char8 as BS
 
@@ -24,7 +25,6 @@ import Idea
 import Apply
 import Refact
 import Test.Util
-import Data.Functor
 import Prelude
 import Config.Yaml
 import GHC.Util.Outputable
@@ -77,11 +77,14 @@ testAnnotations setting file rpath = do
                         | i@Idea{..} <- fromRight [] ideas, let GHC.SrcLoc{..} = GHC.srcSpanStart ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 0]
                         -- TODO: shouldn't these checks be == -1 instead?
 
+            -- Skip refactoring test if the hlint test failed, or if the
+            -- test is annotated with @NoRefactor.
             let skipRefactor = notNull bad || refact == SkipRefactor
             badRefactor <- if skipRefactor then pure [] else liftIO $ do
                 refactorErr <- case ideas of
                     Right [] -> testRefactor rpath Nothing inp
                     Right [idea] -> testRefactor rpath (Just idea) inp
+                    -- Skip refactoring test if there are multiple hints
                     _ -> pure []
                 pure $ [failed $
                            ["TEST FAILURE (BAD REFACTORING)"
@@ -144,12 +147,16 @@ parseTest refact file i x = uncurry (TestCase (GHC.mkSrcLoc (mkFastString file)
 -- Returns an empty list if the refactoring test passes, otherwise
 -- returns error messages.
 testRefactor :: Maybe FilePath -> Maybe Idea -> String -> IO [String]
+-- Skip refactoring test if the refactor binary is not found.
 testRefactor Nothing _ _ = pure []
+-- Skip refactoring test if the hint has no suggestion (i.e., a parse error).
+testRefactor _ (Just idea) _ | isNothing (ideaTo idea) = pure []
 testRefactor (Just rpath) midea inp = withTempFile $ \tempInp -> withTempFile $ \tempHints -> do
     let refacts = map (show &&& ideaRefactoring) (maybeToList midea)
         -- Ignores spaces and semicolons since apply-refact may change them.
         process = filter (\c -> not (isSpace c) && c /= ';')
         matched expected g actual = process expected `g` process actual
+        x `isProperSubsequenceOf` y = x /= y && x `isSubsequenceOf` y
     writeFile tempInp inp
     writeFile tempHints (show refacts)
     exitCode <- runRefactoring rpath tempInp tempHints "--inplace"
@@ -160,6 +167,11 @@ testRefactor (Just rpath) midea inp = withTempFile $ \tempInp -> withTempFile $
             -- No hints. Refactoring should be a no-op.
             Nothing | not (matched inp (==) refactored) ->
                 ["Expected refactor output: " ++ inp, "Actual: " ++ refactored]
+            -- The hint's suggested replacement is @Just ""@, which means the hint
+            -- suggests removing something from the input. The refactoring output
+            -- should be a proper subsequence of the input.
+            Just (Just "") | not (matched refactored isProperSubsequenceOf inp) ->
+                ["Refactor output is expected to be a proper subsequence of: " ++ inp, "Actual: " ++ refactored]
             -- The hint has a suggested replacement. The suggested replacement
             -- should be a substring of the refactoring output.
             Just (Just to) | not (matched to isInfixOf refactored) ->