if it is single-line, otherwise using .
+haskell :: String -> [String]
+haskell s
+ | '\n' `elem` s = ["", s, "
"]
+ | otherwise = ["", s, "", "
"]
+
+showHint :: (String, Severity, Bool) -> BuiltinEx -> [String]
+showHint (hint, sev, refact) BuiltinEx{..} = row1 ++ row2
+ where
+ row1 = row
+ [ "" ++ hint ++ " | "
+ , "" ++ show sev ++ " | "
+ , "" ++ if refact then "Yes" else "No" ++ " | "
+ ]
+ row2 = row example
+ example =
+ [ ""
+ , "Example:"
+ ]
+ ++ haskell builtinInp
+ ++ ["Found:"]
+ ++ haskell builtinFrom
+ ++ ["Suggestion:"]
+ ++ haskell to
+ ++ [" | "]
+ to = case builtinTo of
+ Nothing -> ""
+ Just "" -> "Perhaps you should remove it."
+ Just s -> s
diff -Nru hlint-2.2.11/src/Test/Translate.hs hlint-3.1.6/src/Test/Translate.hs
--- hlint-2.2.11/src/Test/Translate.hs 2019-11-27 22:26:42.000000000 +0000
+++ hlint-3.1.6/src/Test/Translate.hs 2020-03-05 10:40:35.000000000 +0000
@@ -2,6 +2,19 @@
-- | Translate the hints to Haskell and run with GHC.
module Test.Translate(testTypeCheck, testQuickCheck) where
+import Config.Type
+import Control.Exception.Extra
+import Control.Monad.IO.Class
+import Test.Util
+
+testTypeCheck :: FilePath -> FilePath -> [[Setting]] -> Test ()
+testTypeCheck _ _ _ = liftIO $ errorIO "Test.Translate is disabled."
+
+-- | Given a set of hints, do all the HintRule hints satisfy QuickCheck
+testQuickCheck :: FilePath -> FilePath -> [[Setting]] -> Test ()
+testQuickCheck _ _ _ = liftIO $ errorIO "Test.Translate is disabled."
+
+{-
import Control.Monad
import Control.Monad.IO.Class
import Data.List.Extra
@@ -10,6 +23,8 @@
import System.Process
import System.Exit
import System.FilePath
+import Language.Haskell.Exts.Util(FreeVars, freeVars)
+import qualified Data.Set as Set
import Config.Type
import HSE.All
@@ -19,10 +34,10 @@
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
+ ms <- forM (zipFrom 1 xs) $ \(i,x) -> do
let m = "I" ++ show i
writeFile (dir m <.> "hs") $ replace "module Main" ("module " ++ m) x
- return m
+ pure m
writeFile (dir "Main.hs") $ unlines $
["import qualified " ++ m | m <- ms] ++
["main = do"] ++
@@ -46,13 +61,15 @@
["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules, ScopedTypeVariables, DeriveDataTypeable #-}"
,"{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-}"
,"module Main(main) where"] ++
- concat [map (prettyPrint . hackImport) $ scopeImports $ hintRuleScope x | x <- take 1 xs] ++
+ -- 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
+ -}
---------------------------------------------------------------------
@@ -61,10 +78,10 @@
toTypeCheck :: [HintRule] -> [String]
toTypeCheck hints =
["import HLint_TypeCheck hiding(main)"
- ,"main = return ()"] ++
+ ,"main = pure ()"] ++
["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" ++
prettyPrint (PatBind an (toNamed $ "test" ++ show i) bod Nothing)
- | (i, HintRule _ _ _ lhs rhs side _notes _ghcScope _ghcLhs _ghcRhs _ghcSide) <- zip [1..] hints, "noTypeCheck" `notElem` vars (maybeToList side)
+ | (i, HintRule _ _ lhs rhs side _notes _ghcScope _ghcLhs _ghcRhs _ghcSide) <- zipFrom 1 hints, "noTypeCheck" `notElem` vars (maybeToList side)
, let vs = map toNamed $ nubOrd $ 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]
@@ -88,7 +105,7 @@
Let an (BDecls an [PatBind an (toNamed "t") (UnGuardedRhs an bod) Nothing]) $
(toNamed "test" `app` str (fileName $ ann rhs) `app` int (startLine $ ann rhs) `app`
str (prettyPrint lhs ++ " ==> " ++ prettyPrint rhs)) `app` toNamed "t"
- | (i, HintRule _ _ _ lhs rhs side note _ghcScope _ghcLhs _ghcRhs _ghcSide) <- zip [1..] hints, "noQuickCheck" `notElem` vars (maybeToList side)
+ | (i, HintRule _ _ lhs rhs side note _ghcScope _ghcLhs _ghcRhs _ghcSide) <- zipFrom 1 hints, "noQuickCheck" `notElem` vars (maybeToList side)
, let vs = map (restrict side) $ nubOrd $ 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)
@@ -104,3 +121,7 @@
isRemovesError :: Note -> Bool
isRemovesError RemovesError{} = True
isRemovesError _ = False
+
+vars :: FreeVars a => a -> [String]
+vars = Set.toList . Set.map prettyPrint . freeVars
+-}
diff -Nru hlint-2.2.11/src/Test/Util.hs hlint-3.1.6/src/Test/Util.hs
--- hlint-2.2.11/src/Test/Util.hs 2019-04-16 15:19:57.000000000 +0000
+++ hlint-3.1.6/src/Test/Util.hs 2020-06-24 11:09:26.000000000 +0000
@@ -2,8 +2,9 @@
module Test.Util(
Test, withTests,
- tested, passed, failed, progress,
- addIdeas, getIdeas
+ passed, failed, progress,
+ addIdeas, getIdeas,
+ BuiltinSummary, BuiltinEx(..), addBuiltin, getBuiltins,
) where
import Idea
@@ -11,12 +12,25 @@
import Control.Monad.Trans.Reader
import Control.Monad.IO.Class
import Data.IORef
-
+import Data.List.Extra
+import Data.Map (Map)
+import qualified Data.Map.Strict as Map
+
+-- | A map from (hint name, hint severity, does hint support refactoring) to an example.
+type BuiltinSummary = Map (String, Severity, Bool) BuiltinEx
+
+data BuiltinEx = BuiltinEx
+ { builtinInp :: !String
+ , builtinFrom :: !String
+ , builtinTo :: !(Maybe String)
+ }
data S = S
{failures :: !Int
,total :: !Int
,ideas :: [[Idea]]
+ ,builtinHints :: BuiltinSummary
+ -- ^ A summary of builtin hints
}
newtype Test a = Test (ReaderT (IORef S) IO a)
@@ -25,14 +39,14 @@
-- | Returns the number of failing tests.
withTests :: Test a -> IO (Int, a)
withTests (Test act) = do
- ref <- newIORef $ S 0 0 []
+ ref <- newIORef $ S 0 0 [] Map.empty
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, res)
+ pure (failures, res)
addIdeas :: [Idea] -> Test ()
addIdeas xs = do
@@ -44,6 +58,21 @@
ref <- Test ask
liftIO $ concat . reverse . ideas <$> readIORef ref
+addBuiltin :: String -> Idea -> Test ()
+addBuiltin inp idea@Idea{..} = unless ("Parse error" `isPrefixOf` ideaHint) $ do
+ ref <- Test ask
+ liftIO $ modifyIORef' ref $ \s ->
+ let k = (ideaHint, ideaSeverity, notNull ideaRefactoring)
+ v = BuiltinEx inp ideaFrom ideaTo
+ -- Do not insert if the key already exists in the map. This has the effect
+ -- of picking the first test case of a hint as the example in the summary.
+ in s{builtinHints = Map.insertWith (curry snd) k v (builtinHints s)}
+
+getBuiltins :: Test BuiltinSummary
+getBuiltins = do
+ ref <- Test ask
+ liftIO $ builtinHints <$> readIORef ref
+
progress :: Test ()
progress = liftIO $ putChar '.'
@@ -57,6 +86,3 @@
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 -> Test ()
-tested b = if b then passed else failed []
diff -Nru hlint-2.2.11/src/Timing.hs hlint-3.1.6/src/Timing.hs
--- hlint-2.2.11/src/Timing.hs 2019-02-27 11:44:31.000000000 +0000
+++ hlint-3.1.6/src/Timing.hs 2020-05-31 22:44:28.000000000 +0000
@@ -41,9 +41,9 @@
let quiet = c == "Hint"
unless quiet $ whenLoud $ putStr $ "Performing " ++ c ++ " of " ++ i ++ "... "
(time, x) <- duration x
- atomicModifyIORef' timings $ \mp -> (Map.insertWith (+) (c, i) time mp, ())
+ atomicModifyIORef'_ timings $ Map.insertWith (+) (c, i) time
unless quiet $ whenLoud $ putStrLn $ "took " ++ showDuration time
- return x
+ pure x
startTimings :: IO ()
startTimings = do
diff -Nru hlint-2.2.11/src/Util.hs hlint-3.1.6/src/Util.hs
--- hlint-2.2.11/src/Util.hs 2020-01-27 17:28:56.000000000 +0000
+++ hlint-3.1.6/src/Util.hs 2020-06-14 18:45:05.000000000 +0000
@@ -1,22 +1,18 @@
{-# LANGUAGE ExistentialQuantification, Rank2Types #-}
module Util(
- parseExtensions,
- configExtensions,
forceList,
gzip, universeParentBi,
exitMessage, exitMessageImpure,
getContentsUTF8
) where
-import Data.List
import System.Exit
import System.IO
import System.IO.Unsafe
import Unsafe.Coerce
import Data.Data
-import Data.Generics.Uniplate.Operations
-import Language.Haskell.Exts.Extension
+import Data.Generics.Uniplate.DataOnly
---------------------------------------------------------------------
@@ -60,37 +56,11 @@
---------------------------------------------------------------------
-- DATA.GENERICS.UNIPLATE.OPERATIONS
-universeParent :: Uniplate a => a -> [(Maybe a, a)]
+universeParent :: Data a => a -> [(Maybe a, a)]
universeParent x = (Nothing,x) : f x
where
- f :: Uniplate a => a -> [(Maybe a, a)]
+ f :: Data a => a -> [(Maybe a, a)]
f x = concat [(Just x, y) : f y | y <- children x]
-universeParentBi :: Biplate a b => a -> [(Maybe b, b)]
+universeParentBi :: (Data a, Data b) => a -> [(Maybe b, b)]
universeParentBi = concatMap universeParent . childrenBi
-
-
----------------------------------------------------------------------
--- LANGUAGE.HASKELL.EXTS.EXTENSION
-
--- | Extensions we turn on by default when parsing. Aim to parse as many files as we can.
-parseExtensions :: [Extension]
-parseExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions
-
--- | Extensions we turn on when reading config files, don't have to deal with the whole world
--- of variations - in particular, we might require spaces in some places.
-configExtensions :: [Extension]
-configExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension reallyBadExtensions
-
-badExtensions = reallyBadExtensions ++
- [Arrows -- steals proc
- ,UnboxedTuples, UnboxedSums -- breaks (#) lens operator
- ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break
- ,DoRec, RecursiveDo -- breaks rec
- ,TypeApplications -- HSE fails on @ patterns
- ]
-
-reallyBadExtensions =
- [TransformListComp -- steals the group keyword
- ,XmlSyntax, RegularPatterns -- steals a-b and < operators
- ]