summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNeilMitchell <>2019-04-17 16:05:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-04-17 16:05:00 (GMT)
commit22c342b1af16f8cd4adf81b2ccc21f13c8ccabae (patch)
tree8c1cb1d71813229df62dad329ccb60da4643c05e
parent5b456378c446e6ac3c015c0a4c4256f1488d64fd (diff)
version 2.1.172.1.17
-rw-r--r--CHANGES.txt4
-rw-r--r--data/Test.hs3
-rw-r--r--data/hlint.yaml2
-rw-r--r--hlint.cabal2
-rw-r--r--src/Config/Type.hs3
-rw-r--r--src/HSE/Unify.hs21
-rw-r--r--src/Test/All.hs66
-rw-r--r--src/Test/Annotations.hs25
-rw-r--r--src/Test/InputOutput.hs19
-rw-r--r--src/Test/Translate.hs30
-rw-r--r--src/Test/Util.hs66
11 files changed, 155 insertions, 86 deletions
diff --git a/CHANGES.txt b/CHANGES.txt
index b7f1da4..59cbab0 100644
--- a/CHANGES.txt
+++ b/CHANGES.txt
@@ -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
diff --git a/data/Test.hs b/data/Test.hs
index d8c1ffe..94380cb 100644
--- a/data/Test.hs
+++ b/data/Test.hs
@@ -43,6 +43,8 @@ error = zip [1..length x] x ==> zipFrom 1 x
error = before a ==> after a
+warn "noop" = a ? 0 ==> a
+
{-
<TEST>
main = readFile "foo" >>= putStr \
@@ -95,6 +97,7 @@ test = id Control.Arrow.*** id -- id
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 ???
diff --git a/data/hlint.yaml b/data/hlint.yaml
index 1dd8308..d010099 100644
--- a/data/hlint.yaml
+++ b/data/hlint.yaml
@@ -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
diff --git a/hlint.cabal b/hlint.cabal
index 1299e31..acb6fa6 100644
--- a/hlint.cabal
+++ b/hlint.cabal
@@ -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
diff --git a/src/Config/Type.hs b/src/Config/Type.hs
index e7bd018..a0c9e13 100644
--- a/src/Config/Type.hs
+++ b/src/Config/Type.hs
@@ -44,7 +44,8 @@ data Severity
-- 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
---------------------------------------------------------------------
diff --git a/src/HSE/Unify.hs b/src/HSE/Unify.hs
index 9ec3132..008f9b9 100644
--- a/src/HSE/Unify.hs
+++ b/src/HSE/Unify.hs
@@ -51,8 +51,17 @@ substitute :: Subst Exp_ -> Exp_ -> Exp_
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_
@@ -94,6 +103,18 @@ unifyExp nm root x y | not root, isParen x || isParen y =
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) =
liftM2 (<>) (unifyExp nm False x1 y1) (unifyExp nm False x2 y2) `mplus`
diff --git a/src/Test/All.hs b/src/Test/All.hs
index ce56b77..e03894d 100644
--- a/src/Test/All.hs
+++ b/src/Test/All.hs
@@ -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 @@ import System.IO.Extra
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
diff --git a/src/Test/Annotations.hs b/src/Test/Annotations.hs
index fc9704c..962ef53 100644
--- a/src/Test/Annotations.hs
+++ b/src/Test/Annotations.hs
@@ -9,6 +9,9 @@ import Data.Char
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 @@ import Config.Yaml
-- 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 @@ testAnnotations setting file = do
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 @@ parseTestFile file =
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 @@ parseTestFile file =
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)
diff --git a/src/Test/InputOutput.hs b/src/Test/InputOutput.hs
index 602087d..d12a116 100644
--- a/src/Test/InputOutput.hs
+++ b/src/Test/InputOutput.hs
@@ -7,6 +7,7 @@ import Control.Applicative
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 Prelude
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 @@ parseInputOutputs = f z . lines
---------------------------------------------------------------------
-- 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
diff --git a/src/Test/Translate.hs b/src/Test/Translate.hs
index b5a5e8f..e8daee7 100644
--- a/src/Test/Translate.hs
+++ b/src/Test/Translate.hs
@@ -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 HSE.All
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 =
diff --git a/src/Test/Util.hs b/src/Test/Util.hs
index d2defac..33a9834 100644
--- a/src/Test/Util.hs
+++ b/src/Test/Util.hs
@@ -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)
+
+addIdeas :: [Idea] -> Test ()
+addIdeas xs = do
+ ref <- Test ask
+ liftIO $ modifyIORef' ref $ \s -> s{ideas = xs : ideas s}
+
+getIdeas :: Test [Idea]
+getIdeas = do
+ ref <- Test ask
+ liftIO $ concat . reverse . ideas <$> readIORef ref
-progress :: IO ()
-progress = putChar '.'
+progress :: Test ()
+progress = liftIO $ putChar '.'
-passed :: IO ()
-passed = atomicModifyIORef ref $ \(r:rs) -> (r{total=total r+1}:rs, ())
+passed :: Test ()
+passed = do
+ ref <- Test ask
+ liftIO $ modifyIORef' ref $ \s -> s{total=total s+1}
-failed :: [String] -> IO ()
+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 []