packages feed

hlint 2.1.16 → 2.1.17

raw patch · 11 files changed

+155/−86 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

CHANGES.txt view
@@ -1,5 +1,9 @@ Changelog for HLint (* = breaking change) +2.1.17, released 2019-04-17+    #626, add operator wildcards with ?, ??, ??? etc+    #625, fix an rnf/rhs typo+    #562, make test --verbose show a list of matched hints 2.1.16, released 2019-04-15     Make `seq` and `rem` hints apply to prefix functions     #604, suggest rnf x `seq` () ==> rnf x
data/Test.hs view
@@ -43,6 +43,8 @@  error = before a ==> after a +warn "noop" = a ? 0 ==> a+ {- <TEST> main = readFile "foo" >>= putStr            \@@ -95,6 +97,7 @@ import Control.Arrow as Q; test = id Q.*** id -- id zip [1..length x] zip [1..length x] x -- zipFrom 1 x+test = 5 + 0 -- 5  {-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} \ {-# LANGUAGE RecordWildCards #-} -- @Ignore ???
data/hlint.yaml view
@@ -436,7 +436,7 @@     - warn: {lhs: seq x y, rhs: "y", side: isWHNF x, name: Redundant seq}     - warn: {lhs: f $! x, rhs: f x, side: isWHNF x, name: Redundant $!}     - warn: {lhs: evaluate x, rhs: return x, side: isWHNF x, name: Redundant evaluate}-    - warn: {lhs: seq (rnf x) (), rhs: rhs x, name: Redundant seq}+    - warn: {lhs: seq (rnf x) (), rhs: rnf x, name: Redundant seq}      # TUPLE
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               hlint-version:            2.1.16+version:            2.1.17 license:            BSD3 license-file:       LICENSE category:           Development
src/Config/Type.hs view
@@ -44,7 +44,8 @@ -- Any 1-letter variable names are assumed to be unification variables isUnifyVar :: String -> Bool isUnifyVar [x] = x == '?' || isAlpha x-isUnifyVar _ = False+isUnifyVar [] = False+isUnifyVar xs = all (== '?') xs   ---------------------------------------------------------------------
src/HSE/Unify.hs view
@@ -51,8 +51,17 @@ substitute (Subst bind) = transformBracketOld exp . transformBi pat     where         exp (Var _ (fromNamed -> x)) = lookup x bind+        exp (InfixApp s lhs (fromNamed -> x) rhs) =+            (\op -> InfixApp s lhs op rhs) <$> lookupOp x+        exp (LeftSection s exp (fromNamed -> x)) =+            LeftSection s exp <$> lookupOp x+        exp (RightSection s (fromNamed -> x) exp) =+            (\op -> RightSection s op exp) <$> lookupOp x         exp _ = Nothing +        -- Substition for operator must be an operator name+        lookupOp x = toNamed . fromNamed <$> lookup x bind+         pat (PVar _ (fromNamed -> x)) | Just y <- lookup x bind = toNamed $ fromNamed y         pat x = x :: Pat_ @@ -93,6 +102,18 @@  unifyExp nm root (Var _ (fromNamed -> v)) y | isUnifyVar v = Just $ Subst [(v,y)] unifyExp nm root (Var _ x) (Var _ y) | nm x y = Just mempty++-- Match wildcard operators+unifyExp nm root (InfixApp _ lhs1 (fromNamed -> v) rhs1) (InfixApp _ lhs2 (fromNamed -> op2) rhs2)+    | isUnifyVar v =+        (Subst [(v, toNamed op2)] <>) <$>+        liftM2 (<>) (unifyExp nm False lhs1 lhs2) (unifyExp nm False rhs1 rhs2)+unifyExp nm root (LeftSection _ exp1 (fromNamed -> v)) (LeftSection _ exp2 (fromNamed -> op2))+    | isUnifyVar v =+        (Subst [(v, toNamed op2)] <>) <$> unifyExp nm False exp1 exp2+unifyExp nm root (RightSection _ (fromNamed -> v) exp1) (RightSection _ (fromNamed -> op2) exp2)+    | isUnifyVar v =+        (Subst [(v, toNamed op2)] <>) <$> unifyExp nm False exp1 exp2  -- Options: match directly, and expand through . unifyExp nm root x@(App _ x1 x2) (App _ y1 y2) =
src/Test/All.hs view
@@ -4,7 +4,9 @@ module Test.All(test) where  import Control.Exception+import System.Console.CmdArgs import Control.Monad+import Control.Monad.IO.Class import Data.Char import Data.List import System.Directory@@ -25,45 +27,53 @@   test :: Cmd -> ([String] -> IO ()) -> FilePath -> [FilePath] -> IO Int-test CmdTest{..} main dataDir files = withBuffering stdout NoBuffering $ withTests $ do-    hasSrc <- doesFileExist "hlint.cabal"-    useSrc <- return $ hasSrc && null files-    testFiles <- if files /= [] then return files else do-        xs <- getDirectoryContents dataDir-        return [dataDir </> x | x <- xs, takeExtension x `elem` [".hs",".yml",".yaml"]-                              , not $ "HLint_" `isPrefixOf` takeBaseName x]-    testFiles <- forM testFiles $ \file -> do-        hints <- readFilesConfig [(file, Nothing)]-        return (file, hints ++ (if takeBaseName file /= "Test" then [] else map (Builtin . fst) builtinHints))-    let wrap msg act = putStr (msg ++ " ") >> act >> putStrLn ""+test CmdTest{..} main dataDir files = do+    (failures, ideas) <- withBuffering stdout NoBuffering $ withTests $ do+        hasSrc <- liftIO $ doesFileExist "hlint.cabal"+        useSrc <- return $ hasSrc && null files+        testFiles <- if files /= [] then return files else do+            xs <- liftIO $ getDirectoryContents dataDir+            return [dataDir </> x | x <- xs, takeExtension x `elem` [".hs",".yml",".yaml"]+                                , not $ "HLint_" `isPrefixOf` takeBaseName x]+        testFiles <- liftIO $ forM testFiles $ \file -> do+            hints <- readFilesConfig [(file, Nothing)]+            return (file, hints ++ (if takeBaseName file /= "Test" then [] else map (Builtin . fst) builtinHints))+        let wrap msg act = do liftIO $ putStr (msg ++ " "); act; liftIO $ putStrLn "" -    putStrLn "Testing"-    checkCommentedYaml $ dataDir </> "default.yaml"-    when useSrc $ wrap "Source annotations" $ do-        config <- readFilesConfig [(".hlint.yaml",Nothing)]-        forM_ builtinHints $ \(name,_) -> do-            progress-            testAnnotations (Builtin name : if name == "Restrict" then config else []) $ "src/Hint" </> name <.> "hs"-    when useSrc $ wrap "Input/outputs" $ testInputOutput main+        liftIO $ putStrLn "Testing"+        liftIO $ checkCommentedYaml $ dataDir </> "default.yaml"+        when useSrc $ wrap "Source annotations" $ do+            config <- liftIO $ readFilesConfig [(".hlint.yaml",Nothing)]+            forM_ builtinHints $ \(name,_) -> do+                progress+                testAnnotations (Builtin name : if name == "Restrict" then config else []) $ "src/Hint" </> name <.> "hs"+        when useSrc $ wrap "Input/outputs" $ testInputOutput main -    wrap "Hint names" $ mapM_ (\x -> do progress; testNames $ snd x) testFiles-    wrap "Hint annotations" $ forM_ testFiles $ \(file,h) -> do progress; testAnnotations h file-    when cmdTypeCheck $ wrap "Hint typechecking" $-        progress >> testTypeCheck cmdDataDir cmdTempDir [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"]-    when cmdQuickCheck $ wrap "Hint QuickChecking" $-        progress >> testQuickCheck cmdDataDir cmdTempDir [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"]+        wrap "Hint names" $ mapM_ (\x -> do progress; testNames $ snd x) testFiles+        wrap "Hint annotations" $ forM_ testFiles $ \(file,h) -> do progress; testAnnotations h file+        when cmdTypeCheck $ wrap "Hint typechecking" $+            progress >> testTypeCheck cmdDataDir cmdTempDir [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"]+        when cmdQuickCheck $ wrap "Hint QuickChecking" $+            progress >> testQuickCheck cmdDataDir cmdTempDir [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"] -    when (null files && not hasSrc) $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped"+        when (null files && not hasSrc) $ liftIO $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped"+        getIdeas+    whenLoud $ mapM_ print ideas+    return failures   --------------------------------------------------------------------- -- VARIOUS SMALL TESTS -testNames :: [Setting] -> IO ()-testNames  hints = sequence_+-- Check all hints in the standard config files get sensible names+testNames :: [Setting] -> Test ()+testNames hints = sequence_     [ failed ["No name for the hint " ++ prettyPrint hintRuleLHS ++ " ==> " ++ prettyPrint hintRuleRHS]     | SettingMatchExp x@HintRule{..} <- hints, hintRuleName == defaultHintName] ++-- Check that the default.yaml template I supply is valid when I strip off all the comments, since that's+-- what a user gets with --default checkCommentedYaml :: FilePath -> IO () checkCommentedYaml file = do     src <- lines <$> readFile' file
src/Test/Annotations.hs view
@@ -9,6 +9,9 @@ import Data.Either.Extra import Data.List.Extra import Data.Maybe+import Control.Monad+import System.FilePath+import Control.Monad.IO.Class import Data.Function import Data.Yaml import qualified Data.ByteString.Char8 as BS@@ -26,18 +29,24 @@ -- Input, Output -- Output = Nothing, should not match -- Output = Just xs, should match xs-data Test = Test SrcLoc String (Maybe String) [Setting] deriving (Show)+data TestCase = TestCase SrcLoc String (Maybe String) [Setting] deriving (Show) -testAnnotations :: [Setting] -> FilePath -> IO ()+testAnnotations :: [Setting] -> FilePath -> Test () testAnnotations setting file = do-    tests <- parseTestFile file+    tests <- liftIO $ parseTestFile file     mapM_ f tests     where-        f (Test loc inp out additionalSettings) = do-            ideas <- try_ $ do+        f (TestCase loc inp out additionalSettings) = do+            ideas <- liftIO $ try_ $ do                 res <- applyHintFile defaultParseFlags (setting ++ additionalSettings) file $ Just inp                 evaluate $ length $ show res                 return res++            -- the hints from data/Test.hs are really fake hints we don't actually deploy+            -- so don't record them+            when (takeFileName file /= "Test.hs") $+                either (const $ return ()) addIdeas ideas+             let good = case (out, ideas) of                     (Nothing, Right []) -> True                     (Just x, Right [idea]) | match x idea -> True@@ -69,7 +78,7 @@         norm = filter $ \x -> not (isSpace x) && x /= ';'  -parseTestFile :: FilePath -> IO [Test]+parseTestFile :: FilePath -> IO [TestCase] parseTestFile file =     -- we remove all leading # symbols since Yaml only lets us do comments that way     f Nothing . zip [1..] . map (\x -> fromMaybe x $ stripPrefix "# " x) . lines <$> readFile file@@ -87,7 +96,7 @@         shut :: String -> Bool         shut = isPrefixOf "</TEST>" -        f :: Maybe [Setting] -> [(Int, String)] -> [Test]+        f :: Maybe [Setting] -> [(Int, String)] -> [TestCase]         f Nothing ((i,x):xs) = f (open x) xs         f (Just s)  ((i,x):xs)             | shut x = f Nothing xs@@ -97,7 +106,7 @@         f _ [] = []  -parseTest file i x = uncurry (Test (SrcLoc file i 0)) $ f x+parseTest file i x = uncurry (TestCase (SrcLoc file i 0)) $ f x     where         f x | Just x <- stripPrefix "<COMMENT>" x = first ("--"++) $ f x         f (' ':'-':'-':xs) | null xs || " " `isPrefixOf` xs = ("", Just $ dropWhile isSpace xs)
src/Test/InputOutput.hs view
@@ -7,6 +7,7 @@ import Data.Tuple.Extra import Control.Exception import Control.Monad+import Control.Monad.IO.Class import Data.List.Extra import Data.IORef import System.Directory@@ -20,19 +21,19 @@ import Test.Util  -testInputOutput :: ([String] -> IO ()) -> IO ()+testInputOutput :: ([String] -> IO ()) -> Test () testInputOutput main = do-    xs <- getDirectoryContents "tests"+    xs <- liftIO $ getDirectoryContents "tests"     xs <- return $ filter ((==) ".test" . takeExtension) xs     forM_ xs $ \file -> do-        ios <- parseInputOutputs <$> readFile ("tests" </> file)+        ios <- liftIO $ parseInputOutputs <$> readFile ("tests" </> file)         forM_ (zip [1..] ios) $ \(i,io@InputOutput{..}) -> do             progress-            forM_ files $ \(name,contents) -> do+            liftIO $ forM_ files $ \(name,contents) -> do                 createDirectoryIfMissing True $ takeDirectory name                 writeFile name contents             checkInputOutput main io{name= "_" ++ takeBaseName file ++ "_" ++ show i}-        mapM_ (removeFile . fst) $ concatMap files ios+        liftIO $ mapM_ (removeFile . fst) $ concatMap files ios  data InputOutput = InputOutput     {name :: String@@ -62,14 +63,14 @@ --------------------------------------------------------------------- -- CHECK INPUT/OUTPUT PAIRS -checkInputOutput :: ([String] -> IO ()) -> InputOutput -> IO ()+checkInputOutput :: ([String] -> IO ()) -> InputOutput -> Test () checkInputOutput main InputOutput{..} = do-    code <- newIORef ExitSuccess-    got <- fmap (reverse . dropWhile null . reverse . map trimEnd . lines . fst) $ captureOutput $+    code <- liftIO $ newIORef ExitSuccess+    got <- liftIO $ fmap (reverse . dropWhile null . reverse . map trimEnd . lines . fst) $ captureOutput $         handle (\(e::SomeException) -> print e) $         handle (\(e::ExitCode) -> writeIORef code e) $         bracket getVerbosity setVerbosity $ const $ setVerbosity Normal >> main run-    code <- readIORef code+    code <- liftIO $ readIORef code     (want,got) <- return $ matchStarStar (lines output) got      if maybe False (/= code) exit then
src/Test/Translate.hs view
@@ -3,6 +3,7 @@ module Test.Translate(testTypeCheck, testQuickCheck) where  import Control.Monad+import Control.Monad.IO.Class import Data.List.Extra import System.IO.Extra import Data.Maybe@@ -15,29 +16,30 @@ import Test.Util  -runMains :: FilePath -> FilePath -> [String] -> IO ()-runMains datadir tmpdir xs = (if tmpdir == "" then withTempDir else ($ tmpdir)) $ \dir -> do-    ms <- forM (zip [1..] xs) $ \(i,x) -> do-        let m = "I" ++ show i-        writeFile (dir </> m <.> "hs") $ replace "module Main" ("module " ++ m) x-        return m-    writeFile (dir </> "Main.hs") $ unlines $-        ["import qualified " ++ m | m <- ms] ++-        ["main = do"] ++-        ["    " ++ m ++ ".main" | m <- ms]-    res <- system $ "runhaskell -i" ++ dir ++ " -i" ++ datadir ++ " Main"+runMains :: FilePath -> FilePath -> [String] -> Test ()+runMains datadir tmpdir xs = do+    res <- liftIO $ (if tmpdir == "" then withTempDir else ($ tmpdir)) $ \dir -> do+        ms <- forM (zip [1..] xs) $ \(i,x) -> do+            let m = "I" ++ show i+            writeFile (dir </> m <.> "hs") $ replace "module Main" ("module " ++ m) x+            return m+        writeFile (dir </> "Main.hs") $ unlines $+            ["import qualified " ++ m | m <- ms] +++            ["main = do"] +++            ["    " ++ m ++ ".main" | m <- ms]+        system $ "runhaskell -i" ++ dir ++ " -i" ++ datadir ++ " Main"     replicateM_ (length xs) $ tested $ res == ExitSuccess   -- | Given a set of hints, do all the HintRule hints type check-testTypeCheck :: FilePath -> FilePath -> [[Setting]] -> IO ()+testTypeCheck :: FilePath -> FilePath -> [[Setting]] -> Test () testTypeCheck = wrap toTypeCheck  -- | Given a set of hints, do all the HintRule hints satisfy QuickCheck-testQuickCheck :: FilePath -> FilePath -> [[Setting]] -> IO ()+testQuickCheck :: FilePath -> FilePath -> [[Setting]] -> Test () testQuickCheck = wrap toQuickCheck -wrap :: ([HintRule] -> [String]) -> FilePath -> FilePath -> [[Setting]] -> IO ()+wrap :: ([HintRule] -> [String]) -> FilePath -> FilePath -> [[Setting]] -> Test () wrap f datadir tmpdir hints = runMains datadir tmpdir [unlines $ body [x | SettingMatchExp x <- xs] | xs <- hints]     where         body xs =
src/Test/Util.hs view
@@ -1,44 +1,62 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving #-}  module Test.Util(-    withTests, tested, passed, failed, progress+    Test, withTests,+    tested, passed, failed, progress,+    addIdeas, getIdeas     ) where -import Data.IORef-import System.IO.Unsafe+import Idea import Control.Monad+import Control.Monad.Trans.Reader+import Control.Monad.IO.Class+import Data.IORef  -data Result = Result {failures :: Int, total :: Int} deriving Show--{-# NOINLINE ref #-}-ref :: IORef [Result]-ref = unsafePerformIO $ newIORef []+data S = S+    {failures :: !Int+    ,total :: !Int+    ,ideas :: [[Idea]]+    } +newtype Test a = Test (ReaderT (IORef S) IO a)+    deriving (Functor, Applicative, Monad, MonadIO)  -- | Returns the number of failing tests.---   Warning: Not multithread safe, but is reenterant-withTests :: IO () -> IO Int-withTests act = do-    atomicModifyIORef ref $ \r -> (Result 0 0 : r, ())-    act-    Result{..} <- atomicModifyIORef ref $ \(r:rs) -> (rs, r)+withTests :: Test a -> IO (Int, a)+withTests (Test act) = do+    ref <- newIORef $ S 0 0 []+    res <- runReaderT act ref+    S{..} <- readIORef ref     putStrLn ""     putStrLn $ if failures == 0         then "Tests passed (" ++ show total ++ ")"         else "Tests failed (" ++ show failures ++ " of " ++ show total ++ ")"-    return failures+    return (failures, res) -progress :: IO ()-progress = putChar '.'+addIdeas :: [Idea] -> Test ()+addIdeas xs = do+    ref <- Test ask+    liftIO $ modifyIORef' ref $ \s -> s{ideas = xs : ideas s} -passed :: IO ()-passed = atomicModifyIORef ref $ \(r:rs) -> (r{total=total r+1}:rs, ())+getIdeas :: Test [Idea]+getIdeas = do+    ref <- Test ask+    liftIO $ concat . reverse . ideas <$> readIORef ref -failed :: [String] -> IO ()+progress :: Test ()+progress = liftIO $ putChar '.'++passed :: Test ()+passed = do+    ref <- Test ask+    liftIO $ modifyIORef' ref $ \s -> s{total=total s+1}++failed :: [String] -> Test () failed xs = do-    unless (null xs) $ putStrLn $ unlines $ "" : xs-    atomicModifyIORef ref $ \(r:rs) -> (r{total=total r+1, failures=failures r+1}:rs, ())+    unless (null xs) $ liftIO $ putStrLn $ unlines $ "" : xs+    ref <- Test ask+    liftIO $ modifyIORef' ref $ \s -> s{total=total s+1, failures=failures s+1} -tested :: Bool -> IO ()+tested :: Bool -> Test () tested b = if b then passed else failed []