hlint 1.8.61 → 1.9

raw patch · 34 files changed

+542/−206 lines, 34 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGES.txt +13/−0
• README.md +5/−4
• data/Default.hs +69/−55
• data/Generalise.hs +1/−0
• data/HLint_QuickCheck.hs +124/−0
• data/HLint_TypeCheck.hs +19/−0
• data/Test.hs +5/−1
• hlint.cabal +6/−2
• src/Apply.hs +11/−9
• src/CmdLine.hs +4/−0
• src/HLint.hs +2/−2
• src/HSE/All.hs +3/−3
• src/HSE/FreeVars.hs +1/−1
• src/Hint/All.hs +3/−0
• src/Hint/Bracket.hs +1/−1
• src/Hint/Comment.hs +37/−0
• src/Hint/Extensions.hs +1/−1
• src/Hint/Import.hs +1/−1
• src/Hint/Lambda.hs +1/−1
• src/Hint/List.hs +1/−1
• src/Hint/Match.hs +11/−3
• src/Hint/Monad.hs +1/−1
• src/Hint/Pragma.hs +1/−1
• src/Hint/Structure.hs +1/−1
• src/Hint/Type.hs +4/−2
• src/Settings.hs +2/−2
• src/Test/All.hs +53/−0
• src/Test/Annotations.hs +12/−9
• src/Test/InputOutput.hs +2/−1
• src/Test/Proof.hs +1/−0
• src/Test/Standard.hs +0/−93
• src/Test/Translate.hs +104/−0
• src/Test/Util.hs +2/−4
• src/Util.hs +40/−7

@@ -1,5 +1,18 @@ Changelog for HLint +1.9+    Remove not (isControl x) ==> isPrint (not true for '\173')+    #57, warn on invalid pragmas+    Make the API pass and require comments+    #59, make sure qualified operators match properly+    Rename notTypeSafe annotation to noTypeCheck+    Remove an invalid rule suggesting tanh+    #13, add a --quickcheck flag to test the hints+    Add --typecheck flag to test mode to type check the hints+    Remove incorrect for intercalate to unlines+    #37, remove incorrect hint for isAlphaNum+    #45, add mapMaybe id ==> catMaybes+    #42, add some repeat hints 1.8.61     #40, allow haskell-src-exts-1.15     Don't detect redundant Generics extension

@@ -1,4 +1,4 @@-# HLint [![Build Status](https://travis-ci.org/ndmitchell/hlint.png)](https://travis-ci.org/ndmitchell/hlint)+# HLint [![Build Status](https://travis-ci.org/ndmitchell/hlint.svg)](https://travis-ci.org/ndmitchell/hlint)  HLint is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. This document is structured as follows: @@ -8,15 +8,16 @@  ### Acknowledgements -This program has only been made possible by the presence of the [haskell-src-exts](http://www.cs.chalmers.se/~d00nibro/haskell-src-exts/) package, and many improvements have been made by [Niklas Broberg](http://www.cs.chalmers.se/~d00nibro/) in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott, Andy Stewart, Roman Leshchinskiy, Johannes Lippmann and others.+This program has only been made possible by the presence of the [haskell-src-exts](https://github.com/haskell-suite/haskell-src-exts) package, and many improvements have been made by [Niklas Broberg](http://www.nbroberg.se) in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott, Andy Stewart, Roman Leshchinskiy, Johannes Lippmann and others.  ### Bugs and limitations -Bugs can be reported [on the bug tracker](https://github.com/ndmitchell/hlint/issues). There are three common issues that I do not intend to fix:+Bugs can be reported [on the bug tracker](https://github.com/ndmitchell/hlint/issues). There are some issues that I do not intend to fix: +* HLint operates on each module at a time in isolation, as a result HLint does not know about types or which names are in scope. * The presence of `seq` may cause some hints (i.e. eta-reduction) to change the semantics of a program. * Either the monomorphism restriction, or rank-2 types, may cause transformed programs to require type signatures to be manually inserted.-* HLint operates on each module at a time in isolation, as a result HLint does not know about types or which names are in scope.+* The `RebindableSyntax` extension can cause HLint to suggest incorrect changes.  ## Installing and running HLint 

@@ -68,9 +68,12 @@ error = head (sort x) ==> minimum x error = last (sort x) ==> maximum x error = head (sortBy f x) ==> minimumBy f x+    where _ = isCompare f error = last (sortBy f x) ==> maximumBy f x+    where _ = isCompare f error "Avoid reverse" = reverse (sort x) ==> sortBy (flip compare) x error "Avoid reverse" = reverse (sortBy f x) ==> sortBy (flip f) x+    where _ = isCompare f warn  = flip (g `on` h) ==> flip g `on` h warn  = (f `on` g) `on` h ==> f `on` (g . h) @@ -90,9 +93,13 @@ warn "Use map once" = map f (map g x) ==> map (f . g) x warn  = x !! 0 ==> head x error = take n (repeat x) ==> replicate n x+    where _ = noQuickCheck -- takes too long error = map f (replicate n x) ==> replicate n (f x)+    where _ = noQuickCheck -- takes too long error = map f (repeat x) ==> repeat (f x)+    where _ = noQuickCheck -- takes forever error = cycle [x] ==> repeat x+    where _ = noQuickCheck -- takes forever error = head (reverse x) ==> last x error = head (drop n x) ==> x !! n where _ = isNat n error = reverse (tail (reverse x)) ==> init x where note = IncreasesLaziness@@ -111,7 +118,6 @@ error = fst (break p x) ==> takeWhile (not . p) x error = snd (break p x) ==> dropWhile (not . p) x error = concatMap (++ "\n") ==> unlines-error = intercalate "\n" x ++ "\n" ==> unlines x error = map id ==> id error = or (map p x) ==> any p x error = and (map p x) ==> all p x@@ -156,6 +162,10 @@ error "Drop on a non-positive" = drop i x ==> x where _ = isNegZero i error = last (scanl f z x) ==> foldl f z x error = head (scanr f z x) ==> foldr f z x+error = iterate id ==> repeat+    where _ = noQuickCheck -- takes forever+error = zipWith f (repeat x) ==> map (f x)+error = zipWith f x (repeat y) ==> map (\x -> f x y) x  -- BY @@ -172,6 +182,7 @@ -- FOLDS  error = foldr  (>>) (return ()) ==> sequence_+    where _ = noQuickCheck error = foldr  (&&) True ==> and error = foldl  (&&) True ==> and where note = IncreasesLaziness error = foldr1 (&&)  ==> and where note = RemovesError "on []"@@ -193,6 +204,7 @@ error = foldl1 min   ==> minimum error = foldr1 min   ==> minimum error = foldr mplus mzero ==> msum+    where _ = noQuickCheck  -- FUNCTION @@ -217,11 +229,8 @@ error = a >= 'A' && a <= 'Z' ==> isAsciiUpper a error = a >= '0' && a <= '9' ==> isDigit a error = a >= '0' && a <= '7' ==> isOctDigit a-error = not (isControl a) ==> isPrint a error = isLower a || isUpper a ==> isAlpha a error = isUpper a || isLower a ==> isAlpha a-error = isAlpha a || isDigit a ==> isAlphaNum a-error = isDigit a || isAlpha a ==> isAlphaNum a  -- BOOL @@ -269,71 +278,72 @@  -- FUNCTOR -error "Functor law" = fmap f (fmap g x) ==> fmap (f . g) x-error "Functor law" = fmap id ==> id+error "Functor law" = fmap f (fmap g x) ==> fmap (f . g) x where _ = noQuickCheck+error "Functor law" = fmap id ==> id where _ = noQuickCheck warn = fmap f $ x ==> f Control.Applicative.<$> x-    where _ = isApp x || isAtom x+    where _ = (isApp x || isAtom x) && noQuickCheck  -- MONAD -error "Monad law, left identity" = return a >>= f ==> f a-error "Monad law, right identity" = m >>= return ==> m-warn  = m >>= return . f ==> Control.Monad.liftM f m -- cannot be fmap, because is in Functor not Monad-error = (if x then y else return ()) ==> Control.Monad.when x $ _noParen_ y where _ = not (isAtom y)-error = (if x then y else return ()) ==> Control.Monad.when x y where _ = isAtom y-error = (if x then return () else y) ==> Control.Monad.unless x $ _noParen_ y where _ = not (isAtom y)-error = (if x then return () else y) ==> Control.Monad.unless x y where _ = isAtom y-error = sequence (map f x) ==> mapM f x-error = sequence_ (map f x) ==> mapM_ f x-warn  = flip mapM ==> Control.Monad.forM-warn  = flip mapM_ ==> Control.Monad.forM_-warn  = flip forM ==> mapM-warn  = flip forM_ ==> mapM_-error = when (not x) ==> unless x-error = x >>= id ==> Control.Monad.join x-error = liftM f (liftM g x) ==> liftM (f . g) x-error = fmap f (fmap g x) ==> fmap (f . g) x+error "Monad law, left identity" = return a >>= f ==> f a where _ = noQuickCheck+error "Monad law, right identity" = m >>= return ==> m where _ = noQuickCheck+warn  = m >>= return . f ==> Control.Monad.liftM f m where _ = noQuickCheck -- cannot be fmap, because is in Functor not Monad+error = (if x then y else return ()) ==> Control.Monad.when x $ _noParen_ y where _ = not (isAtom y) && noQuickCheck+error = (if x then y else return ()) ==> Control.Monad.when x y where _ = isAtom y && noQuickCheck+error = (if x then return () else y) ==> Control.Monad.unless x $ _noParen_ y where _ = not (isAtom y) && noQuickCheck+error = (if x then return () else y) ==> Control.Monad.unless x y where _ = isAtom y && noQuickCheck+error = sequence (map f x) ==> mapM f x where _ = noQuickCheck+error = sequence_ (map f x) ==> mapM_ f x where _ = noQuickCheck+warn  = flip mapM ==> Control.Monad.forM where _ = noQuickCheck+warn  = flip mapM_ ==> Control.Monad.forM_ where _ = noQuickCheck+warn  = flip forM ==> mapM where _ = noQuickCheck+warn  = flip forM_ ==> mapM_ where _ = noQuickCheck+error = when (not x) ==> unless x where _ = noQuickCheck+error = x >>= id ==> Control.Monad.join x where _ = noQuickCheck+error = liftM f (liftM g x) ==> liftM (f . g) x where _ = noQuickCheck+error = fmap f (fmap g x) ==> fmap (f . g) x where _ = noQuickCheck warn  = a >> return () ==> Control.Monad.void a-    where _ = isAtom a || isApp a-error = fmap (const ()) ==> Control.Monad.void-error = flip (>=>) ==> (<=<)-error = flip (<=<) ==> (>=>)-warn  = (\x -> f x >>= g) ==> f Control.Monad.>=> g-warn  = (\x -> f =<< g x) ==> f Control.Monad.<=< g-error = a >> forever a ==> forever a-warn  = liftM2 id ==> ap-error = mapM (uncurry f) (zip l m) ==> zipWithM f l m+    where _ = (isAtom a || isApp a) && noQuickCheck+error = fmap (const ()) ==> Control.Monad.void where _ = noQuickCheck+error = flip (>=>) ==> (<=<) where _ = noQuickCheck+error = flip (<=<) ==> (>=>) where _ = noQuickCheck+warn  = (\x -> f x >>= g) ==> f Control.Monad.>=> g where _ = noQuickCheck+warn  = (\x -> f =<< g x) ==> f Control.Monad.<=< g where _ = noQuickCheck+error = a >> forever a ==> forever a where _ = noQuickCheck+warn  = liftM2 id ==> ap where _ = noQuickCheck+error = mapM (uncurry f) (zip l m) ==> zipWithM f l m where _ = noQuickCheck  -- STATE MONAD -error = fst (runState x y) ==> evalState x y-error = snd (runState x y) ==> execState x y+error = fst (runState x y) ==> evalState x y where _ = noQuickCheck+error = snd (runState x y) ==> execState x y where _ = noQuickCheck  -- MONAD LIST -error = liftM unzip (mapM f x) ==> Control.Monad.mapAndUnzipM f x-error = sequence (zipWith f x y) ==> Control.Monad.zipWithM f x y-error = sequence_ (zipWith f x y) ==> Control.Monad.zipWithM_ f x y-error = sequence (replicate n x) ==> Control.Monad.replicateM n x-error = sequence_ (replicate n x) ==> Control.Monad.replicateM_ n x-error = mapM f (replicate n x) ==> Control.Monad.replicateM n (f x)-error = mapM_ f (replicate n x) ==> Control.Monad.replicateM_ n (f x)-error = mapM f (map g x) ==> mapM (f . g) x-error = mapM_ f (map g x) ==> mapM_ (f . g) x-error = mapM id ==> sequence-error = mapM_ id ==> sequence_+error = liftM unzip (mapM f x) ==> Control.Monad.mapAndUnzipM f x where _ = noQuickCheck+error = sequence (zipWith f x y) ==> Control.Monad.zipWithM f x y where _ = noQuickCheck+error = sequence_ (zipWith f x y) ==> Control.Monad.zipWithM_ f x y where _ = noQuickCheck+error = sequence (replicate n x) ==> Control.Monad.replicateM n x where _ = noQuickCheck+error = sequence_ (replicate n x) ==> Control.Monad.replicateM_ n x where _ = noQuickCheck+error = mapM f (replicate n x) ==> Control.Monad.replicateM n (f x) where _ = noQuickCheck+error = mapM_ f (replicate n x) ==> Control.Monad.replicateM_ n (f x) where _ = noQuickCheck+error = mapM f (map g x) ==> mapM (f . g) x where _ = noQuickCheck+error = mapM_ f (map g x) ==> mapM_ (f . g) x where _ = noQuickCheck+error = mapM id ==> sequence where _ = noQuickCheck+error = mapM_ id ==> sequence_ where _ = noQuickCheck  -- APPLICATIVE / TRAVERSABLE -error = flip traverse ==> for-error = flip for ==> traverse-error = flip traverse_ ==> for_-error = flip for_ ==> traverse_-error = foldr (*>) (pure ()) ==> sequenceA_-error = foldr (<|>) empty ==> asum-error = liftA2 (flip ($)) ==> (<**>)-error = Just <$> a <|> pure Nothing ==> optional a+error = flip traverse ==> for where _ = noQuickCheck+error = flip for ==> traverse where _ = noQuickCheck+error = flip traverse_ ==> for_ where _ = noQuickCheck+error = flip for_ ==> traverse_ where _ = noQuickCheck+error = foldr (*>) (pure ()) ==> sequenceA_ where _ = noQuickCheck+error = foldr (<|>) empty ==> asum where _ = noQuickCheck+error = liftA2 (flip ($)) ==> (<**>) where _ = noQuickCheck+error = Just <$> a <|> pure Nothing ==> optional a where _ = noQuickCheck + -- LIST COMP  warn  "Use list comprehension" = (if b then [x] else []) ==> [x | b]@@ -374,6 +384,7 @@ error = isJust x && (fromJust x == y) ==> x == Just y error = mapMaybe f (map g x) ==> mapMaybe (f . g) x error = fromMaybe a (fmap f x) ==> maybe a f x+error = mapMaybe id ==> catMaybes warn = [x | Just x <- a] ==> Data.Maybe.catMaybes a warn = (case m of Nothing -> Nothing; Just x -> x) ==> Control.Monad.join m warn = maybe Nothing id ==> join@@ -403,7 +414,6 @@ error "Redundant negate" = negate (negate x) ==> x warn  = log y / log x ==> logBase x y warn  = sin x / cos x ==> tan x-warn  = sinh x / cosh x ==> tanh x warn  = n `rem` 2 == 0 ==> even n warn  = n `rem` 2 /= 0 ==> odd n warn  = not (even x) ==> odd x@@ -437,7 +447,9 @@ -- FOLDABLE  error "Use Foldable.forM_" = (case m of Nothing -> return (); Just x -> f x) ==> Data.Foldable.forM_ m f+    where _ = noQuickCheck error "Use Foldable.forM_" = when (isJust m) (f (fromJust m)) ==> Data.Foldable.forM_ m f+    where _ = noQuickCheck  -- EVALUATE @@ -574,6 +586,7 @@ foo = evaluate [12] -- return [12] test = \ a -> f a >>= \ b -> return (a, b) fooer input = catMaybes . map Just $ input -- mapMaybe Just+yes = mapMaybe id -- catMaybes main = print $ map (\_->5) [2,3,5] -- const 5 main = head $ drop n x main = head $ drop (-3) x -- x@@ -605,6 +618,7 @@ foo = return $! "test" bar = [x| (x,_) <- pts] return' x = x `seq` return x+foo = last (sortBy (compare `on` fst) xs) -- maximumBy (compare `on` fst) xs  import Prelude \ yes = flip mapM -- Control.Monad.forM

@@ -6,5 +6,6 @@  warn = concatMap ==> (=<<) warn = liftM ==> fmap+    where _ = noQuickCheck warn = map ==> fmap warn = a ++ b ==> a `Data.Monoid.mappend` b

@@ -0,0 +1,124 @@+{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules, ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, GeneralizedNewtypeDeriving #-}++-- | Used with --quickcheck+module HLint_QuickCheck(module HLint_QuickCheck, module X) where++import System.IO.Unsafe+import Data.Typeable+import Data.List+import Data.Maybe+import Data.IORef+import Control.Exception+import Control.Monad+import System.IO+import Control.Concurrent.Chan+import System.Mem.Weak(Weak)+import Test.QuickCheck hiding ((==>))+import Test.QuickCheck.Test hiding (test)+import Test.QuickCheck.Modifiers as X++default(Maybe Bool,Int,Dbl)++newtype Dbl = Dbl Double deriving (Enum,Floating,Fractional,Num,Read,Real,RealFloat,RealFrac,Show,Typeable,Arbitrary,CoArbitrary)++instance Eq Dbl where+    Dbl a == Dbl b | isNaN a && isNaN b = True+                   | otherwise = abs (a - b) < 1e-4 || let s = a+b in s /= 0 && abs ((a-b)/s) < 1e-8++instance Ord Dbl where+    compare a b | a == b = EQ+    compare (Dbl a) (Dbl b) = compare a b++newtype NegZero a = NegZero a deriving (Typeable, Show)+instance (Num a, Arbitrary a) => Arbitrary (NegZero a) where+    arbitrary = fmap (NegZero . negate . abs) arbitrary++newtype Nat a = Nat a deriving (Typeable, Show)+instance (Num a, Arbitrary a) => Arbitrary (Nat a) where+    arbitrary = fmap (Nat . abs) arbitrary++newtype Compare a = Compare (a -> a -> Ordering) deriving (Typeable, Show)+instance (Ord a, Arbitrary a) => Arbitrary (Compare a) where+    arbitrary = fmap (\b -> Compare $ (if b then flip else id) compare) arbitrary++instance (Show a, Show b) => Show (a -> b) where show _ = "<func>"+instance Show a => Show (IO a) where show _ = "<IO>"+instance Show a => Show (Weak a) where show _ = "<Weak>"+instance Show a => Show (Chan a) where show _ = "<Chan>"++instance Eq (IO a) where _ == _ = True+instance Eq SomeException where a == b = show a == show b++instance Typeable IOMode where typeOf _ = typeOf ()++instance Arbitrary Handle where arbitrary = elements [stdin, stdout, stderr]+instance CoArbitrary Handle where coarbitrary _ = variant 0+instance Arbitrary IOMode where arbitrary = elements [ReadMode,WriteMode,AppendMode,ReadWriteMode]+instance Arbitrary a => Arbitrary (IO a) where arbitrary = fmap return arbitrary+instance Arbitrary (Chan a) where arbitrary = return $ unsafePerformIO newChan++instance Exception (Maybe Bool)++data Test a = Test Bool a a deriving (Show, Typeable)+instance Functor Test where+    fmap f (Test a b c) = Test a (f b) (f c)++a ==> b = Test False a b+a ?==> b = Test True a b++class Testable2 a where+    property2 :: Test a -> Property+instance Testable2 a => Testable (Test a) where+    property = property2+instance Eq a => Testable2 a where+    property2 (Test bx (catcher -> x) (catcher -> y)) =+        property $ (bx && isNothing x) || x == y+instance (Arbitrary a, Show a, Testable2 b) => Testable2 (a -> b) where+    property2 x = property $ \a -> fmap ($ a) x++{-# NOINLINE bad #-}+bad :: IORef Int+bad = unsafePerformIO $ newIORef 0++test :: (Show p, Testable p, Typeable p) => FilePath -> Int -> String -> p -> IO ()+test file line hint p = do+    res <- quickCheckWithResult stdArgs{chatty=False} p+    unless (isSuccess res) $ do+        putStrLn $ "\n" ++ file ++ ":" ++ show line ++ ": " ++ hint+        print $ typeOf p+        putStr $ output res+        modifyIORef bad (+1)++catcher :: a -> Maybe a+catcher x = unsafePerformIO $ do+    res <- try $ evaluate x+    return $ case res of+        Left (_ :: SomeException) -> Nothing+        Right v -> Just v++_noParen_ = id+_eval_ = id++withMain :: IO () -> IO ()+withMain act = do+    act+    bad <- readIORef bad+    when (bad > 0) $+        error $ "Failed " ++ show bad ++ " tests"++---------------------------------------------------------------------+-- EXAMPLES++main :: IO ()+main = withMain $ do+    test "data\\Default.hs" 144 "findIndex ((==) a) ==> elemIndex a" $+        \ a -> (findIndex ((==) a)) ==> (elemIndex a)+    test "data\\Default.hs" 179 "foldr1 (&&) ==> and" $+        ((foldr1 (&&)) ?==> (and))+    test "data\\Default.hs" 407 "sinh x / cosh x ==> tanh x" $+        \ x -> (sqrt x) ==> (x ** 0.5)+    test "data\\Default.hs" 154 "take i x ==> []" $+        \ (NegZero i) x -> (take i x) ==> ([])+    test "data\\Default.hs" 70 "head (sortBy f x) ==> minimumBy f x" $+        \ (Compare f) x -> (head (sortBy f x)) ==> (minimumBy f x)

@@ -0,0 +1,19 @@++-- Used with --typecheck+module HLint_TypeCheck where++(==>) :: a -> a -> a+(==>) = undefined++_noParen_ = id+_eval_ = id+++---------------------------------------------------------------------+-- EXAMPLES++main :: IO ()+main = return ()++{-# LINE 116 "data\\Default.hs" #-}+_test64 = \ p x -> (and (map p x)) ==> (all p x)

@@ -11,7 +11,7 @@ error = Prelude.readFile ==> bad  error = (x :: Int) ==> (x :: Int32)-    where _ = notTypeSafe+    where _ = noTypeCheck   error "Test1" = scanr ==> scanr@@ -38,6 +38,7 @@  error = Array.head ==> head error = tail ==> Array.tail+warn = id Control.Arrow.*** id ==> id  error = zip [1..length x] x ==> zipFrom 1 x @@ -88,6 +89,9 @@ import Array as A; test = A.head -- head test = tail -- Array.tail import qualified Array as B; test = tail -- B.tail+import Control.Arrow; test = id *** id -- id+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 

@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               hlint-version:            1.8.61+version:            1.9 license:            BSD3 license-file:       LICENSE category:           Development@@ -24,6 +24,8 @@     hs-lint.el     hlint.1     hlint.ghci+    HLint_QuickCheck.hs+    HLint_TypeCheck.hs extra-source-files:     README.md     CHANGES.txt@@ -72,6 +74,7 @@         HSE.Util         Hint.All         Hint.Bracket+        Hint.Comment         Hint.Duplicate         Hint.Extensions         Hint.Import@@ -85,10 +88,11 @@         Hint.Structure         Hint.Type         Hint.Util+        Test.All         Test.Annotations         Test.InputOutput         Test.Proof-        Test.Standard+        Test.Translate         Test.Util  

@@ -32,28 +32,30 @@  -- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's. --   The 'Idea' values will be ordered within a file.-applyHints :: [Classify] -> Hint -> [Module SrcSpanInfo] -> [Idea]+applyHints :: [Classify] -> Hint -> [(Module SrcSpanInfo, [Comment])] -> [Idea] applyHints cls hints_ ms = concat $     [ map (classify $ cls ++ mapMaybe readPragma (universeBi m)) $-        order "" (hintModule hints nm m) ++-        concat [order (fromNamed d) $ decHints d | d <- moduleDecls m]-    | (nm,m) <- mns+        order "" (hintModule hints nm m) `merge`+        concat [order (fromNamed d) $ decHints d | d <- moduleDecls m] `merge`+        concat [order "" $ hintComment hints c | c <- cs]+    | (nm,(m,cs)) <- mns     , let decHints = hintDecl hints nm m -- partially apply-    , let order n = map (\i -> i{ideaModule=moduleName m, ideaDecl=n}) . sortBy (comparing ideaSpan)] ++-    [map (classify cls) (hintModules hints mns)]+    , let order n = map (\i -> i{ideaModule=moduleName m, ideaDecl=n}) . sortBy (comparing ideaSpan)+    , let merge = mergeBy (comparing ideaSpan)] +++    [map (classify cls) (hintModules hints $ map (second fst) mns)]     where-        mns = map (scopeCreate &&& id) ms+        mns = map (scopeCreate . fst &&& id) ms         hints = (if length ms <= 1 then noModules else id) hints_         noModules h = h{hintModules = \_ -> []} `mappend` mempty{hintModule = \a b -> hintModules h [(a,b)]}   -- | Given a list of settings (a way to classify) and a list of hints, run them over a list of modules.-executeHints :: [Setting] -> [Module_] -> [Idea]+executeHints :: [Setting] -> [(Module_, [Comment])] -> [Idea] executeHints s = applyHints [x | SettingClassify x <- s] (allHints s)   -- | Return either an idea (a parse error) or the module. In IO because might call the C pre processor.-parseModuleApply :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO (Either Idea Module_)+parseModuleApply :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO (Either Idea (Module_, [Comment])) parseModuleApply flags s file src = do     res <- parseModuleEx (parseFlagsAddFixities [x | Infix x <- s] flags) file src     case res of

@@ -95,6 +95,8 @@         ,cmdDataDir :: FilePath          -- ^ the data directory         ,cmdReports :: [FilePath]        -- ^ where to generate reports         ,cmdWithHints :: [String]        -- ^ hints that are given on the command line+        ,cmdQuickCheck :: Bool+        ,cmdTypeCheck :: Bool         }     | CmdHSE         {cmdFiles :: [FilePath]@@ -130,6 +132,8 @@         } &= explicit &= name "grep"     ,CmdTest         {cmdProof = nam_ "proof" &= typFile &= help "Isabelle/HOLCF theory file"+        ,cmdTypeCheck = nam_ "typecheck" &= help "Use GHC to type check the hints"+        ,cmdQuickCheck = nam_ "quickcheck" &= help "Use QuickCheck to check the hints"         } &= explicit &= name "test"         &= details ["HLint gives hints on how to improve Haskell code."                  ,""

@@ -13,7 +13,7 @@ import Report import Idea import Apply-import Test.Standard+import Test.All import Grep import Test.Proof import Util@@ -78,7 +78,7 @@         let reps = if cmdReports == ["report.html"] then ["report.txt"] else cmdReports         mapM_ (proof reps s) cmdProof      else do-        failed <- test (\args -> do errs <- hlint args; when (length errs > 0) $ exitWith $ ExitFailure 1) cmdDataDir cmdGivenHints+        failed <- test cmd (\args -> do errs <- hlint args; when (length errs > 0) $ exitWith $ ExitFailure 1) cmdDataDir cmdGivenHints         when (failed > 0) exitFailure  hlintGrep :: Cmd -> IO ()

@@ -64,12 +64,12 @@  -- | Parse a Haskell module. Applies the C pre processor, and uses best-guess fixity resolution if there are ambiguities. --   The filename @-@ is treated as @stdin@. Requires some flags (often 'defaultParseFlags'), the filename, and optionally the contents of that file.-parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError (Module SrcSpanInfo))+parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError (Module SrcSpanInfo, [Comment])) parseModuleEx flags file str = do         str <- maybe (readFileEncoding (encoding flags) file) return str         ppstr <- runCpp (cppFlags flags) file str-        case parseFileContentsWithMode (mode flags) ppstr of-            ParseOk x -> return $ Right $ applyFixity fixity x+        case parseFileContentsWithComments (mode flags) ppstr of+            ParseOk (x, cs) -> return $ Right (applyFixity fixity x, cs)             ParseFailed sl msg -> do                 -- figure out the best line number to grab context from, by reparsing                 flags <- return $ parseFlagsNoLocations flags

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}  module HSE.FreeVars(FreeVars, freeVars, vars, varss, pvars, declBind) where 

@@ -20,6 +20,7 @@ import Hint.Pragma import Hint.Extensions import Hint.Duplicate+import Hint.Comment   -- | A list of builtin hints, currently including entries such as @\"List\"@ and @\"Bracket\"@.@@ -36,11 +37,13 @@     ,"Pragma"     + pragmaHint     ,"Extensions" + extensionsHint     ,"Duplicate"  * duplicateHint+    ,"Comment"    - commentHint     ]     where         x!y = (x,mempty{hintDecl=y})         x+y = (x,mempty{hintModule=y})         x*y = (x,mempty{hintModules=y})+        x-y = (x,mempty{hintComment=y})  -- | Transform a list of 'HintRule' into a 'Hint'. hintRules :: [HintRule] -> Hint

@@ -58,7 +58,7 @@ -}  -module Hint.Bracket where+module Hint.Bracket(bracketHint) where  import Hint.Type 

@@ -0,0 +1,37 @@++{-+<TEST>+{- MISSING HASH #-} -- {-# MISSING HASH #-}+<COMMENT> {- INLINE X -}+{- INLINE Y -} -- {-# INLINE Y #-}+{- INLINE[~k] f -} -- {-# INLINE[~k] f #-}+{- NOINLINE Y -} -- {-# NOINLINE Y #-}+{- UNKNOWN Y -}+<COMMENT> INLINE X+</TEST>+-}+++module Hint.Comment(commentHint) where++import Hint.Type+import Data.Char+import Data.List+import Util+++pragmas = words $+    "LANGUAGE OPTIONS_GHC INCLUDE WARNING DEPRECATED MINIMAL INLINE NOINLINE INLINABLE " +++    "CONLIKE LINE SPECIALIZE SPECIALISE UNPACK NOUNPACK SOURCE"+++commentHint :: Comment -> [Idea]+commentHint c@(Comment True span s)+    | "#" `isSuffixOf` s && not ("#" `isPrefixOf` s) = [suggest "Fix pragma markup" c $ '#':s]+    | name `elem` pragmas = [suggest "Use pragma syntax" c $ "# " ++ trim s ++ " #"]+        where name = takeWhile (\x -> isAlphaNum x || x == '_') $ dropWhile isSpace s+commentHint _ = []++suggest :: String -> Comment -> String -> Idea+suggest msg (Comment typ pos s1) s2 = rawIdea Warning msg pos (f s1) (Just $ f s2) []+    where f s = if typ then "{-" ++ s ++ "-}" else "--" ++ s

@@ -65,7 +65,7 @@ -}  -module Hint.Extensions where+module Hint.Extensions(extensionsHint) where  import Hint.Type import Data.Maybe

@@ -40,7 +40,7 @@ -}  -module Hint.Import where+module Hint.Import(importHint) where  import Hint.Type import Util

@@ -66,7 +66,7 @@ -}  -module Hint.Lambda where+module Hint.Lambda(lambdaHint) where  import Hint.Util import Hint.Type

@@ -23,7 +23,7 @@ -}  -module Hint.List where+module Hint.List(listHint) where  import Control.Applicative import Hint.Type

@@ -16,7 +16,7 @@ isFoo x - is the root constructor of x a "Foo" notEq x y - are x and y not equal notIn xs ys - are all x variables not in ys expressions-notTypeSafe - no semantics, a hint for testing only+noTypeCheck, noQuickCheck - no semantics, a hint for testing only  ($) AND (.) We see through ($)/(.) by expanding it if nothing else matches.@@ -114,6 +114,12 @@  type NameMatch = QName S -> QName S -> Bool +nmOp :: NameMatch -> QOp S -> QOp S -> Bool+nmOp nm (QVarOp _ x) (QVarOp _ y) = nm x y+nmOp nm (QConOp _ x) (QConOp _ y) = nm x y+nmOp nm  _ _ = False++ -- unify a b = c, a[c] = b unify :: Data a => NameMatch -> Bool -> a -> a -> Maybe [(String,Exp_)] unify nm root x y | Just x <- cast x = unifyExp nm root x (unsafeCoerce y)@@ -136,7 +142,7 @@     liftM2 (++) (unifyExp nm False x1 y1) (unifyExp nm False x2 y2) `mplus`     (do guard $ not root; InfixApp _ y11 dot y12 <- return $ fromParen y1; guard $ isDot dot; unifyExp nm root x (App an y11 (App an y12 y2))) unifyExp nm root x (InfixApp _ lhs2 op2 rhs2)-    | InfixApp _ lhs1 op1 rhs1 <- x = guard (op1 == op2) >> liftM2 (++) (unifyExp nm False lhs1 lhs2) (unifyExp nm False rhs1 rhs2)+    | InfixApp _ lhs1 op1 rhs1 <- x = guard (nmOp nm op1 op2) >> liftM2 (++) (unifyExp nm False lhs1 lhs2) (unifyExp nm False rhs1 rhs2)     | isDol op2 = unifyExp nm root x $ App an lhs2 rhs2     | otherwise = unifyExp nm root x $ App an (App an (opExp op2) lhs2) rhs2 unifyExp nm root x y | isOther x, isOther y = unifyDef nm x y@@ -195,9 +201,11 @@         f (App _ (App _ cond (sub -> x)) (sub -> y))             | cond ~= "notIn" = and [x `notElem` universe y | x <- list x, y <- list y]             | cond ~= "notEq" = x /= y-        f x | x ~= "notTypeSafe" = True+        f x | x ~= "noTypeCheck" = True+        f x | x ~= "noQuickCheck" = True         f x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x +        isType "Compare" x = True -- just a hint for proof stuff         isType "Atom" x = isAtom x         isType "WHNF" x = isWHNF x         isType "Nat" (asInt -> Just x) | x >= 0 = True

@@ -34,7 +34,7 @@ -}  -module Hint.Monad where+module Hint.Monad(monadHint) where  import Control.Arrow import Control.Applicative

@@ -24,7 +24,7 @@ -}  -module Hint.Pragma where+module Hint.Pragma(pragmaHint) where  import Hint.Type import Data.List

@@ -36,7 +36,7 @@ -}  -module Hint.Structure where+module Hint.Structure(structureHint) where  import Hint.Type import Util

@@ -17,8 +17,10 @@     ,hintDecl :: Scope -> Module SrcSpanInfo -> Decl SrcSpanInfo -> [Idea]         -- ^ Given a declaration (with a module and scope) generate some 'Idea's.         --   This function will be partially applied with one module/scope, then used on multiple 'Decl' values.+    ,hintComment :: Comment -> [Idea] -- ^ Given a comment generate some 'Idea's.     }  instance Monoid Hint where-    mempty = Hint (\_ -> []) (\_ _ -> []) (\_ _ _ -> [])-    mappend (Hint x1 x2 x3) (Hint y1 y2 y3) = Hint (\a -> x1 a ++ y1 a) (\a b -> x2 a b ++ y2 a b) (\a b c -> x3 a b c ++ y3 a b c)+    mempty = Hint (\_ -> []) (\_ _ -> []) (\_ _ _ -> []) (\_ -> [])+    mappend (Hint x1 x2 x3 x4) (Hint y1 y2 y3 y4) =+        Hint (\a -> x1 a ++ y1 a) (\a b -> x2 a b ++ y2 a b) (\a b c -> x3 a b c ++ y3 a b c) (\a -> x4 a ++ y4 a)

@@ -142,7 +142,7 @@     res <- parseModuleEx flags file contents     case res of         Left (ParseError sl msg err) -> exitMessage $ "Parse failure at " ++ showSrcLoc sl ++ ": " ++ msg ++ "\n" ++ err-        Right m -> do+        Right (m, _) -> do             ys <- sequence [f $ fromNamed $ importModule i | i <- moduleImports m, importPkg i `elem` [Just "hint", Just "hlint"]]             return $ concat2 $ ([],[m]) : ys     where@@ -249,7 +249,7 @@     case x of         Left (ParseError sl msg _) ->             return ("-- Parse error " ++ showSrcLoc sl ++ ": " ++ msg, [])-        Right m -> do+        Right (m, _) -> do             let xs = concatMap (findSetting $ UnQual an) (moduleDecls m)                 s = unlines $ ["-- hints found in " ++ file] ++ map prettyPrint xs ++ ["-- no hints found" | null xs]                 r = concatMap (readSetting mempty) xs

@@ -0,0 +1,53 @@+{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards, ViewPatterns #-}++module Test.All(test) where++import Control.Monad+import Data.List+import System.Directory+import System.FilePath++import Settings+import CmdLine+import Util+import HSE.All+import Hint.All+import Test.Util+import Test.InputOutput+import Test.Annotations+import Test.Translate+import System.IO+++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 == ".hs", not $ "HLint" `isPrefixOf` takeBaseName x]+    testFiles <- forM testFiles $ \file -> fmap ((,) file) $ readSettings2 dataDir [file] []+    let wrap msg act = putStr (msg ++ " ") >> act >> putStrLn ""++    putStrLn "Testing"+    when useSrc $ wrap "Source annotations" $+        forM_ builtinHints $ \(name,_) -> do progress; testAnnotations [Builtin name] $ "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 [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"]+    when cmdQuickCheck $ wrap "Hint QuickChecking" $+        progress >> testQuickCheck [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"+++---------------------------------------------------------------------+-- VARIOUS SMALL TESTS++testNames :: [Setting] -> IO ()+testNames  hints = sequence_+    [ failed ["No name for the hint " ++ prettyPrint (hintRuleLHS x)]+    | SettingMatchExp x@HintRule{} <- hints, hintRuleName x == defaultHintName]

@@ -1,7 +1,9 @@ {-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards, ViewPatterns #-} -module Test.Annotations(checkAnnotations) where+-- | Check the <TEST> annotations within source and hint files.+module Test.Annotations(testAnnotations) where +import Control.Arrow import Data.Char import Data.List import Data.Maybe@@ -20,8 +22,8 @@ -- Output = Just xs, should match xs data Test = Test SrcLoc String (Maybe String) -checkAnnotations :: [Setting] -> FilePath -> IO ()-checkAnnotations setting file = do+testAnnotations :: [Setting] -> FilePath -> IO ()+testAnnotations setting file = do     tests <- parseTestFile file     mapM_ f tests     where@@ -69,14 +71,15 @@         f False ((i,x):xs) = f (open x) xs         f True  ((i,x):xs)             | shut x = f False xs-            | null x || "--" `isPrefixOf` x = f True xs+            | null x || "-- " `isPrefixOf` x = f True xs             | "\\" `isSuffixOf` x, (_,y):ys <- xs = f True $ (i,init x++"\n"++y):ys             | otherwise = parseTest file i x : f True xs         f _ [] = []  -parseTest file i x = Test (SrcLoc file i 0) x $-    case dropWhile (/= "--") $ words x of-        [] -> Nothing-        _:xs -> Just $ unwords xs-+parseTest file i x = uncurry (Test (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)+        f (x:xs) = first (x:) $ f xs+        f [] = ([], Nothing)

@@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards, ViewPatterns #-} +-- | Check the input/output pairs in the tests/ directory module Test.InputOutput(testInputOutput) where  import Control.Applicative@@ -25,12 +26,12 @@     forM_ xs $ \file -> do         ios <- parseInputOutputs <$> readFile ("tests" </> file)         forM_ (zip [1..] ios) $ \(i,io@InputOutput{..}) -> do+            progress             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-    progress  data InputOutput = InputOutput     {name :: String

@@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards, PatternGuards #-} +-- | Check the coverage of the hints given a list of Isabelle theorems module Test.Proof(proof) where  import Control.Applicative

@@ -1,93 +0,0 @@-{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards, ViewPatterns #-}--module Test.Standard(test) where--import Control.Exception-import Control.Monad-import Data.List-import Data.Maybe-import System.Directory-import System.FilePath-import System.IO-import System.Cmd-import System.Exit--import Settings-import HSE.All-import Hint.All-import Test.Util-import Test.InputOutput-import Test.Annotations---test :: ([String] -> IO ()) -> FilePath -> [FilePath] -> IO Int-test main dataDir files = withTests $-    if null files then do-        src <- doesFileExist "hlint.cabal"-        sequence_ $ (if src then id else take 1)-            [testHintFiles dataDir, testSourceFiles, testInputOutput main]-        putStrLn ""-        unless src $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped"-    else do-        mapM_ (testHintFile dataDir) files---testHintFiles :: FilePath -> IO ()-testHintFiles dataDir = do-    xs <- getDirectoryContents dataDir-    mapM_ (testHintFile dataDir)-        [dataDir </> x | x <- xs, takeExtension x == ".hs", not $ "HLint" `isPrefixOf` takeBaseName x]---testHintFile :: FilePath -> FilePath -> IO ()-testHintFile dataDir file = do-    hints <- readSettings2 dataDir [file] []-    sequence_ $ nameCheckHints hints : checkAnnotations hints file :-                [typeCheckHints hints | takeFileName file /= "Test.hs"]-    progress---testSourceFiles :: IO ()-testSourceFiles = sequence_-    [checkAnnotations [Builtin name] ("src/Hint" </> name <.> "hs") | (name,h) <- builtinHints]-------------------------------------------------------------------------- VARIOUS SMALL TESTS--nameCheckHints :: [Setting] -> IO ()-nameCheckHints hints = do-    sequence_ [failed ["No name for the hint " ++ prettyPrint (hintRuleLHS x)] | SettingMatchExp x@HintRule{} <- hints, hintRuleName x == defaultHintName]----- | Given a set of hints, do all the HintRule hints type check-typeCheckHints :: [Setting] -> IO ()-typeCheckHints hints = bracket-    (openTempFile "." "hlinttmp.hs")-    (\(file,h) -> removeFile file)-    $ \(file,h) -> do-        hPutStrLn h $ unlines contents-        hClose h-        res <- system $ "runhaskell " ++ file-        progress-        tested $ res == ExitSuccess-    where-        matches = [x | SettingMatchExp x <- hints]--        -- Hack around haskell98 not being compatible with base anymore-        hackImport i@ImportDecl{importAs=Just a,importModule=b}-            | prettyPrint b `elem` words "Maybe List Monad IO Char" = i{importAs=Just b,importModule=a}-        hackImport i = i--        contents =-            ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules #-}"] ++-            concat [map (prettyPrint . hackImport) $ scopeImports $ hintRuleScope x | x <- take 1 matches] ++-            ["main = return ()"-            ,"(==>) :: a -> a -> a; (==>) = undefined"-            ,"_noParen_ = id"-            ,"_eval_ = id"] ++-            ["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" ++-             prettyPrint (PatBind an (toNamed $ "test" ++ show i) Nothing bod Nothing)-            | (i, HintRule _ _ _ lhs rhs side _) <- zip [1..] matches, "notTypeSafe" `notElem` vars (maybeToList side)-            , let vs = map toNamed $ nub $ filter isUnifyVar $ vars lhs ++ vars rhs-            , let inner = InfixApp an (Paren an lhs) (toNamed "==>") (Paren an rhs)-            , let bod = UnGuardedRhs an $ if null vs then inner else Lambda an vs inner]

@@ -0,0 +1,104 @@+{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards, ViewPatterns #-}++-- | Translate the hints to Haskell and run with GHC.+module Test.Translate(testTypeCheck, testQuickCheck) where++import Control.Monad+import Data.List+import Data.Maybe+import System.Cmd+import System.Exit+import System.FilePath++import Paths_hlint+import Settings+import Util+import HSE.All+import Test.Util+++runMains :: [String] -> IO ()+runMains xs = withTemporaryFiles "HLint_tmp.hs" (length xs + 1) $ \(root:bodies) -> do+    forM_ (zip bodies xs) $ \(file,x) -> do+        writeFile file $ replace "module Main" ("module " ++ takeBaseName file) x+    let ms = map takeBaseName bodies+    writeFile root $ unlines $+        ["import qualified " ++ m | m <- ms] +++        ["main = do"] +++        ["    " ++ m ++ ".main" | m <- ms]+    dat <- getDataDir+    res <- system $ "runhaskell -i" ++ takeDirectory root ++ " -i" ++ dat ++ " " ++ root+    replicateM_ (length xs) $ tested $ res == ExitSuccess+++-- | Given a set of hints, do all the HintRule hints type check+testTypeCheck :: [[Setting]] -> IO ()+testTypeCheck = wrap toTypeCheck++-- | Given a set of hints, do all the HintRule hints satisfy QuickCheck+testQuickCheck :: [[Setting]] -> IO ()+testQuickCheck = wrap toQuickCheck++wrap :: ([HintRule] -> [String]) -> [[Setting]] -> IO ()+wrap f hints = runMains [unlines $ body [x | SettingMatchExp x <- xs] | xs <- hints]+    where+        body xs =+            ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules, ScopedTypeVariables, DeriveDataTypeable #-}"+            ,"{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-}"+            ,"module Main(main) where"] +++            concat [map (prettyPrint . hackImport) $ scopeImports $ hintRuleScope x | x <- take 1 xs] +++            f xs++        -- Hack around haskell98 not being compatible with base anymore+        hackImport i@ImportDecl{importAs=Just a,importModule=b}+            | prettyPrint b `elem` words "Maybe List Monad IO Char" = i{importAs=Just b,importModule=a}+        hackImport i = i+++---------------------------------------------------------------------+-- TYPE CHECKING++toTypeCheck :: [HintRule] -> [String]+toTypeCheck hints =+    ["import HLint_TypeCheck hiding(main)"+    ,"main = return ()"] +++    ["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" +++     prettyPrint (PatBind an (toNamed $ "test" ++ show i) Nothing bod Nothing)+    | (i, HintRule _ _ _ lhs rhs side _) <- zip [1..] hints, "noTypeCheck" `notElem` vars (maybeToList side)+    , let vs = map toNamed $ nub $ filter isUnifyVar $ vars lhs ++ vars rhs+    , let inner = InfixApp an (Paren an lhs) (toNamed "==>") (Paren an rhs)+    , let bod = UnGuardedRhs an $ if null vs then inner else Lambda an vs inner]+++---------------------------------------------------------------------+-- QUICKCHECK++toQuickCheck :: [HintRule] -> [String]+toQuickCheck hints =+    ["import HLint_QuickCheck hiding(main)"+    ,"default(Maybe Bool,Int,Dbl)"+    ,prettyPrint $ PatBind an (toNamed "main") Nothing (UnGuardedRhs an $ toNamed "withMain" $$ Do an tests) Nothing]+    where+        str x = Lit an $ String an x (show x)+        int x = Lit an $ Int an (toInteger x) (show x)+        app = App an+        a $$ b = InfixApp an a (toNamed "$") b+        tests =+            [ Qualifier an $+                (toNamed "test" `app` str (fileName $ ann rhs) `app` int (startLine $ ann rhs) `app`+                 str (prettyPrint lhs ++ " ==> " ++ prettyPrint rhs)) $$ bod+            | (i, HintRule _ _ _ lhs rhs side note) <- zip [1..] hints, "noQuickCheck" `notElem` vars (maybeToList side)+            , let vs = map (restrict side) $ nub $ filter isUnifyVar $ vars lhs ++ vars rhs+            , let op = if any isRemovesError note then "?==>" else "==>"+            , let inner = InfixApp an (Paren an lhs) (toNamed op) (Paren an rhs)+            , let bod = if null vs then Paren an inner else Lambda an vs inner]++        restrict (Just side) v+            | any (=~= App an (toNamed "isNegZero") (toNamed v)) (universe side) = PApp an (toNamed "NegZero") [toNamed v]+            | any (=~= App an (toNamed "isNat") (toNamed v)) (universe side) = PApp an (toNamed "Nat") [toNamed v]+            | any (=~= App an (toNamed "isCompare") (toNamed v)) (universe side) = PApp an (toNamed "Compare") [toNamed v]+        restrict _ v = toNamed v+++isRemovesError RemovesError{} = True+isRemovesError _ = False

@@ -6,9 +6,7 @@  import Data.IORef import System.IO.Unsafe-import Control.Exception import Control.Monad-import System.IO   data Result = Result {failures :: Int, total :: Int} deriving Show@@ -17,11 +15,11 @@ ref :: IORef [Result] ref = unsafePerformIO $ newIORef [] + -- | Returns the number of failing tests. --   Warning: Not multithread safe, but is reenterant withTests :: IO () -> IO Int-withTests act = bracket (hGetBuffering stdout) (hSetBuffering stdout) $ const $ do-    hSetBuffering stdout NoBuffering+withTests act = do     atomicModifyIORef ref $ \r -> (Result 0 0 : r, ())     act     Result{..} <- atomicModifyIORef ref $ \(r:rs) -> (rs, r)

@@ -87,6 +87,9 @@ limit n s = if null post then s else pre ++ "..."     where (pre,post) = splitAt n s +trim :: String -> String+trim = ltrim . rtrim+ ltrim :: String -> String ltrim = dropWhile isSpace @@ -116,7 +119,13 @@ concatUnzip :: [([a], [b])] -> ([a], [b]) concatUnzip = (concat *** concat) . unzip +mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+mergeBy f (x:xs) (y:ys)+    | f x y == GT = y : mergeBy f (x:xs) ys+    | otherwise = x : mergeBy f xs (y:ys)+mergeBy f xs ys = xs ++ ys + --------------------------------------------------------------------- -- DATA.TUPLE @@ -140,7 +149,12 @@ concat2 xs = (concat a, concat b)     where (a,b) = unzip xs +replace :: String -> String -> String -> String+replace from to xs | Just xs <- stripPrefix from xs = to ++ replace from to xs+replace from to (x:xs) = x : replace from to xs+replace from to [] = [] + --------------------------------------------------------------------- -- SYSTEM.IO @@ -208,11 +222,24 @@     exitWith $ ExitFailure 1  --- FIXME: This could use a lot more bracket calls!-captureOutput :: IO () -> IO String-captureOutput act = do+withTemporaryFile :: String -> (FilePath -> IO a) -> IO a+withTemporaryFile pat act = do     tmp <- getTemporaryDirectory-    (f,h) <- openTempFile tmp "hlint"+    bracket (openTempFile tmp pat) (removeFile . fst) $+        \(file,h) -> hClose h >> act file++withTemporaryFiles :: String -> Int -> ([FilePath] -> IO a) -> IO a+withTemporaryFiles pat 0 act = act []+withTemporaryFiles pat i act | i > 0 =+    withTemporaryFile pat $ \file ->+        withTemporaryFiles pat (i-1) $ \files ->+            act $ file : files++captureOutput :: IO () -> IO String+captureOutput act = withTemporaryFile "hlint_capture_output.txt" $ \file -> do+    h <- openFile file ReadWriteMode+    bout <- hGetBuffering stdout+    berr <- hGetBuffering stderr     sto <- hDuplicate stdout     ste <- hDuplicate stderr     hDuplicateTo h stdout@@ -221,9 +248,15 @@     act     hDuplicateTo sto stdout     hDuplicateTo ste stderr-    res <- readFile' f-    removeFile f-    return res+    hSetBuffering stdout bout+    hSetBuffering stderr berr+    readFile' file+++withBuffering :: Handle -> BufferMode -> IO a -> IO a+withBuffering h m act = bracket (hGetBuffering h) (hSetBuffering h) $ const $ do+    hSetBuffering h m+    act   -- FIXME: Should use strict ByteString