Report generated by HLint $VERSION - a tool to suggest improvements to your Haskell code.
$CONTENT| Hint | ", "Severity | ", "Support Refactoring? | "] ++ Map.foldMapWithKey showHint builtins ++ ["
|---|
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
hlint-3.1.6/src/Test/Proof.hs 0000644 0000000 0000000 00000022045 13630153376 014166 0 ustar 00 0000000 0000000
-- | Check the coverage of the hints given a list of Isabelle theorems
module Test.Proof(proof) where
import Config.Type
import Control.Exception.Extra
proof :: [FilePath] -> [Setting] -> FilePath -> IO ()
proof _ _ _ = errorIO "Test.Proof is disabled."
{-
import Data.Tuple.Extra
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.State
import Language.Haskell.Exts.Util(paren, FreeVars, freeVars)
import qualified Data.Set as Set
import Data.Char
import Data.List.Extra
import Data.Maybe
import Data.Function
import System.FilePath
import Config.Type
import HSE.All
import Prelude
data Theorem = Theorem
{original :: Maybe HintRule
,location :: String
,lemma :: String
}
instance Eq Theorem where
t1 == t2 = lemma t1 == lemma t2
instance Ord Theorem where
compare t1 t2 = compare (lemma t1) (lemma t2)
instance Show Theorem where
show Theorem{..} = location ++ ":\n" ++ maybe "" f original ++ lemma ++ "\n"
where f HintRule{..} = "(* " ++ prettyPrint hintRuleLHS ++ " ==> " ++ prettyPrint hintRuleRHS ++ " *)\n"
proof :: [FilePath] -> [Setting] -> FilePath -> IO ()
proof reports hints thy = do
got <- isabelleTheorems (takeFileName thy) <$> readFile thy
let want = nubOrd $ hintTheorems hints
let unused = got \\ want
let missing = want \\ got
let reasons = map (\x -> (fst $ head x, map snd x)) $ groupBy ((==) `on` fst) $
sortBy (compare `on` fst) $ map (classifyMissing &&& id) missing
let summary = table $ let (*) = (,) in
["HLint hints" * want
,"HOL proofs" * got
,"Useful proofs" * (got `intersect` want)
,"Unused proofs" * unused
,"Unproved hints" * missing] ++
[(" " ++ name) * ps | (name,ps) <- reasons]
putStr $ unlines summary
forM_ reports $ \report -> do
let out = ("Unused proofs",unused) : map (first ("Unproved hints - " ++)) reasons
writeFile report $ unlines $ summary ++ "" : concat
[("== " ++ a ++ " ==") : "" : map show b | (a,b) <- out]
putStrLn $ "Report written to " ++ report
where
table xs = [a ++ replicate (n + 6 - length a - length bb) ' ' ++ bb | (a,b) <- xs, let bb = show $ length b]
where n = maximum $ map (length . fst) xs
missingFuncs :: [(String, String)]
missingFuncs = let a*b = [(b,a) | b <- words b] in concat
["IO" * "putChar putStr print putStrLn getLine getChar getContents hReady hPrint stdin"
,"Exit" * "exitSuccess"
,"Ord" * "(>) (<=) (>=) (<) compare minimum maximum sort sortBy"
,"Show" * "show shows showIntAtBase"
,"Read" * "reads read"
,"String" * "lines unlines words unwords"
,"Monad" * "mapM mapM_ sequence sequence_ msum mplus mzero liftM when unless return evaluate join void (>>=) (<=<) (>=>) forever ap"
,"Functor" * "fmap"
,"Numeric" * "(+) (*) fromInteger fromIntegral negate log (/) (-) (*) (^^) (^) subtract sqrt even odd"
,"Char" * "isControl isPrint isUpper isLower isAlpha isDigit"
,"Arrow" * "second first (***) (&&&)"
,"Applicative+" * "traverse for traverse_ for_ pure (<|>) (<**>)"
,"Exception" * "catch handle catchJust bracket error toException"
,"WeakPtr" * "mkWeak"
]
-- | Guess why a theorem is missing
classifyMissing :: Theorem -> String
classifyMissing Theorem{original = Just HintRule{..}}
| _:_ <- [v :: Exp_ | v@Case{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "case"
| _:_ <- [v :: Exp_ | v@ListComp{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "list-comp"
| v:_ <- mapMaybe (`lookup` missingFuncs) [prettyPrint (v :: Name S) | v <- universeBi (hintRuleLHS,hintRuleRHS)] = v
classifyMissing _ = "?unknown"
-- Extract theorems out of Isabelle code (HLint.thy)
isabelleTheorems :: FilePath -> String -> [Theorem]
isabelleTheorems file = find . lexer 1
where
find ((i,"lemma"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest
find ((i,"lemma"):(_,name):(_,":"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest
find ((i,"lemma"):(_,"assumes"):(_,'\"':assumes):(_,"shows"):(_,'\"':lemma):rest) =
Theorem Nothing (file ++ ":" ++ show i) (assumes ++ " \\ " ++ lemma) : find rest
find ((i,"lemma"):rest) = Theorem Nothing (file ++ ":" ++ show i) "Unsupported lemma format" : find rest
find (x:xs) = find xs
find [] = []
lexer i x
| i `seq` False = []
| Just x <- stripPrefix "(*" x, (a,b) <- breaks "*)" x = lexer (add a i) b
| Just x <- stripPrefix "\"" x, (a,b) <- breaks "\"" x = (i,'\"':a) : lexer (add a i) b -- NOTE: drop the final "
| x:xs <- x, isSpace x = lexer (add [x] i) xs
| (a@(_:_),b) <- span (\y -> y == '_' || isAlpha y) x = (i,a) : lexer (add a i) b
lexer i (x:xs) = (i,[x]) : lexer (add [x] i) xs
lexer i [] = []
add s i = length (filter (== '\n') s) + i
breaks s x | Just x <- stripPrefix s x = ("",x)
breaks s (x:xs) = let (a,b) = breaks s xs in (x:a,b)
breaks s [] = ([],[])
reparen :: Setting -> Setting
reparen (SettingMatchExp m@HintRule{..}) = SettingMatchExp m{hintRuleLHS = f False hintRuleLHS, hintRuleRHS = f True hintRuleRHS}
where f right x = if isLambda x || isIf x || badInfix x then Paren (ann x) x else x
badInfix (InfixApp _ _ op _) = prettyPrint op `elem` words "|| && ."
badInfix _ = False
reparen x = x
-- Extract theorems out of the hints
hintTheorems :: [Setting] -> [Theorem]
hintTheorems xs =
[ Theorem (Just m) (loc $ ann hintRuleLHS) $ maybe "" assumes hintRuleSide ++ relationship hintRuleNotes a b
| SettingMatchExp m@HintRule{..} <- map reparen xs, let a = exp1 $ typeclasses hintRuleNotes hintRuleLHS, let b = exp1 hintRuleRHS, a /= b]
where
loc (SrcSpanInfo (SrcSpan file ln _ _ _) _) = takeFileName file ++ ":" ++ show ln
subs xs = flip lookup [(reverse b, reverse a) | x <- words xs, let (a,'=':b) = break (== '=') $ reverse x]
funs = subs "id=ID not=neg or=the_or and=the_and (||)=tror (&&)=trand (++)=append (==)=eq (/=)=neq ($)=dollar"
ops = subs "||=orelse &&=andalso .=oo ===eq /==neq ++=++ !!=!! $=dollar $!=dollarBang"
pre = flip elem $ words "eq neq dollar dollarBang"
cons = subs "True=TT False=FF"
typeclasses hintRuleNotes x = foldr f x hintRuleNotes
where
f (ValidInstance cls var) x = evalState (transformM g x) True
where g v@Var{} | v ~= var = do
b <- get; put False
pure $ if b then Paren an $ toNamed $ prettyPrint v ++ "::'a::" ++ cls ++ "_sym" else v
g v = pure v :: State Bool Exp_
f _ x = x
relationship hintRuleNotes a b | any lazier hintRuleNotes = a ++ " \\ " ++ b
| DecreasesLaziness `elem` hintRuleNotes = b ++ " \\ " ++ a
| otherwise = a ++ " = " ++ b
where lazier IncreasesLaziness = True
lazier RemovesError{} = True
lazier _ = False
assumes (App _ op var)
| op ~= "isNat" = "le\\0\\" ++ prettyPrint var ++ " \\ FF \\ "
| op ~= "isNegZero" = "gt\\0\\" ++ prettyPrint var ++ " \\ FF \\ "
assumes (App _ op var) | op ~= "isWHNF" = prettyPrint var ++ " \\ \\ \\ "
assumes _ = ""
exp1 = exp . transformBi unqual
-- Syntax translations
exp (App _ a b) = exp a ++ "\\" ++ exp b
exp (Paren _ x) = "(" ++ exp x ++ ")"
exp (Var _ x) | Just x <- funs $ prettyPrint x = x
exp (Con _ (Special _ (TupleCon _ _ i))) = "\\" ++ replicate (i-1) ',' ++ "\\"
exp (Con _ x) | Just x <- cons $ prettyPrint x = x
exp (Tuple _ _ xs) = "\\" ++ intercalate ", " (map exp xs) ++ "\\"
exp (If _ a b c) = "If " ++ exp a ++ " then " ++ exp b ++ " else " ++ exp c
exp (Lambda _ xs y) = "\\ " ++ unwords (map pat xs) ++ ". " ++ exp y
exp (InfixApp _ x op y) | Just op <- ops $ prettyPrint op =
if pre op then op ++ "\\" ++ exp (paren x) ++ "\\" ++ exp (paren y) else exp x ++ " " ++ op ++ " " ++ exp y
-- Translations from the Haskell 2010 report
exp (InfixApp l a (QVarOp _ b) c) = exp $ App l (App l (Var l b) a) c -- S3.4
exp x@(LeftSection l e op) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l e op (toNamed v) -- S3.5
exp x@(RightSection l op e) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l (toNamed v) op e -- S3.5
exp x = prettyPrint x
pat (PTuple _ _ xs) = "\\" ++ intercalate ", " (map pat xs) ++ "\\"
pat x = prettyPrint x
fresh x = head $ ("z":["v" ++ show i | i <- [1..]]) \\ vars x
vars :: FreeVars a => a -> [String]
vars = Set.toList . Set.map prettyPrint . freeVars
-}
hlint-3.1.6/src/Test/InputOutput.hs 0000644 0000000 0000000 00000010421 13633646646 015426 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards, ViewPatterns #-}
-- | Check the input/output pairs in the tests/ directory
module Test.InputOutput(testInputOutput) where
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
import System.FilePath
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Verbosity
import System.Exit
import System.IO.Extra
import Prelude
import Test.Util
testInputOutput :: ([String] -> IO ()) -> Test ()
testInputOutput main = do
xs <- liftIO $ getDirectoryContents "tests"
xs <- pure $ filter ((==) ".test" . takeExtension) xs
forM_ xs $ \file -> do
ios <- liftIO $ parseInputOutputs <$> readFile ("tests" file)
forM_ (zipFrom 1 ios) $ \(i,io@InputOutput{..}) -> do
progress
liftIO $ forM_ files $ \(name,contents) -> do
createDirectoryIfMissing True $ takeDirectory name
writeFile name contents
checkInputOutput main io{name= "_" ++ takeBaseName file ++ "_" ++ show i}
liftIO $ mapM_ (removeFile . fst) $ concatMap files ios
data InputOutput = InputOutput
{name :: String
,files :: [(FilePath, String)]
,run :: [String]
,output :: String
,exit :: Maybe ExitCode
} deriving Eq
parseInputOutputs :: String -> [InputOutput]
parseInputOutputs = f z . lines
where
z = InputOutput "unknown" [] [] "" Nothing
interest x = any (`isPrefixOf` x) ["----","FILE","RUN","OUTPUT","EXIT"]
f io ((stripPrefix "RUN " -> Just flags):xs) = f io{run = splitArgs flags} xs
f io ((stripPrefix "EXIT " -> Just code):xs) = f io{exit = Just $ let i = read code in if i == 0 then ExitSuccess else ExitFailure i} xs
f io ((stripPrefix "FILE " -> Just file):xs) | (str,xs) <- g xs = f io{files = files io ++ [(file,unlines str)]} xs
f io ("OUTPUT":xs) | (str,xs) <- g xs = f io{output = unlines str} xs
f io ((isPrefixOf "----" -> True):xs) = [io | io /= z] ++ f z xs
f io [] = [io | io /= z]
f io (x:xs) = error $ "Unknown test item, " ++ x
g = first (reverse . dropWhile null . reverse) . break interest
---------------------------------------------------------------------
-- CHECK INPUT/OUTPUT PAIRS
checkInputOutput :: ([String] -> IO ()) -> InputOutput -> Test ()
checkInputOutput main InputOutput{..} = do
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 <- liftIO $ readIORef code
(want,got) <- pure $ matchStarStar (lines output) got
if maybe False (/= code) exit then
failed
["TEST FAILURE IN tests/" ++ name
,"WRONG EXIT CODE"
,"GOT : " ++ show code
,"WANT: " ++ show exit
]
else if length got == length want && and (zipWith matchStar want got) then
passed
else do
let trail = replicate (max (length got) (length want)) ""
let (i,g,w):_ = [(i,g,w) | (i,g,w) <- zip3 [1..] (got++trail) (want++trail), not $ matchStar w g]
failed $
["TEST FAILURE IN tests/" ++ name
,"DIFFER ON LINE: " ++ show i
,"GOT : " ++ g
,"WANT: " ++ w
,"FULL OUTPUT FOR GOT:"] ++ got
-- | First string may have stars in it (the want)
matchStar :: String -> String -> Bool
matchStar ('*':xs) ys = any (matchStar xs) $ tails ys
matchStar ('/':x:xs) ('\\':'\\':ys) | x /= '/' = matchStar (x:xs) ys -- JSON escaped newlines
matchStar (x:xs) (y:ys) = eq x y && matchStar xs ys
where
-- allow path differences between Windows and Linux
eq '/' y = isPathSeparator y
eq x y = x == y
matchStar [] [] = True
matchStar _ _ = False
matchStarStar :: [String] -> [String] -> ([String], [String])
matchStarStar want got = case break (== "**") want of
(_, []) -> (want, got)
(w1,_:w2) -> (w1++w2, g1 ++ takeEnd (length w2) g2)
where (g1,g2) = splitAt (length w1) got
hlint-3.1.6/src/Test/Annotations.hs 0000644 0000000 0000000 00000020701 13674632146 015400 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, PatternGuards, RecordWildCards, ViewPatterns #-}
-- | Check the annotations within source and hint files.
module Test.Annotations(testAnnotations) where
import Control.Exception.Extra
import Control.Monad
import Control.Monad.IO.Class
import Data.Char
import Data.Either.Extra
import Data.Function
import Data.Functor
import Data.List.Extra
import Data.Maybe
import Data.Tuple.Extra
import System.Exit
import System.FilePath
import System.IO.Extra
import GHC.All
import qualified Data.ByteString.Char8 as BS
import Config.Type
import Idea
import Apply
import Extension
import Refact
import Test.Util
import Prelude
import Config.Yaml
import FastString
import GHC.Util
import SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
#ifdef HS_YAML
import Data.YAML.Aeson (decode1Strict)
import Data.YAML (Pos)
import Data.ByteString (ByteString)
decodeEither' :: ByteString -> Either (Pos, String) ConfigYaml
decodeEither' = decode1Strict
#else
import Data.Yaml
#endif
-- Input, Output
-- Output = Nothing, should not match
-- Output = Just xs, should match xs
data TestCase = TestCase SrcLoc Refactor String (Maybe String) [Setting] deriving (Show)
data Refactor = TestRefactor | SkipRefactor deriving (Eq, Show)
testAnnotations :: [Setting] -> FilePath -> Maybe FilePath -> Test ()
testAnnotations setting file rpath = do
tests <- liftIO $ parseTestFile file
mapM_ f tests
where
f (TestCase loc refact inp out additionalSettings) = do
ideas <- liftIO $ try_ $ do
res <- applyHintFile defaultParseFlags (setting ++ additionalSettings) file $ Just inp
evaluate $ length $ show res
pure res
when ("src/Hint" `isPrefixOf` file) $ mapM_ (mapM_ (addBuiltin inp)) ideas
-- 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 $ pure ()) addIdeas ideas
let good = case (out, ideas) of
(Nothing, Right []) -> True
(Just x, Right [idea]) | match x idea -> True
_ -> False
let bad =
[failed $
["TEST FAILURE (" ++ show (either (const 1) length ideas) ++ " hints generated)"
,"SRC: " ++ unsafePrettyPrint loc
,"INPUT: " ++ inp] ++
map ("OUTPUT: " ++) (either (pure . show) (map show) ideas) ++
["WANTED: " ++ fromMaybe "" out]
| not good] ++
[failed
["TEST FAILURE (BAD LOCATION)"
,"SRC: " ++ unsafePrettyPrint loc
,"INPUT: " ++ inp
,"OUTPUT: " ++ show i]
| i@Idea{..} <- fromRight [] ideas, let SrcLoc{..} = srcSpanStart ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 0]
-- TODO: shouldn't these checks be == -1 instead?
-- Skip refactoring test if the hlint test failed, or if the
-- test is annotated with @NoRefactor.
let skipRefactor = notNull bad || refact == SkipRefactor
badRefactor <- if skipRefactor then pure [] else liftIO $ do
refactorErr <- case ideas of
Right [] -> testRefactor rpath Nothing inp
Right [idea] -> testRefactor rpath (Just idea) inp
-- Skip refactoring test if there are multiple hints
_ -> pure []
pure $ [failed $
["TEST FAILURE (BAD REFACTORING)"
,"SRC: " ++ unsafePrettyPrint loc
,"INPUT: " ++ inp] ++ refactorErr
| notNull refactorErr]
if null bad && null badRefactor then passed else sequence_ (bad ++ badRefactor)
match "???" _ = True
match (word1 -> ("@Message",msg)) i = ideaHint i == msg
match (word1 -> ("@Note",note)) i = map show (ideaNote i) == [note]
match "@NoNote" i = null (ideaNote i)
match (word1 -> ('@':sev, msg)) i = sev == show (ideaSeverity i) && match msg i
match msg i = on (==) norm (fromMaybe "" $ ideaTo i) msg
-- FIXME: Should use a better check for expected results
norm = filter $ \x -> not (isSpace x) && x /= ';'
parseTestFile :: FilePath -> IO [TestCase]
parseTestFile file =
-- we remove all leading # symbols since Yaml only lets us do comments that way
f Nothing TestRefactor . zipFrom 1 . map (dropPrefix "# ") . lines <$> readFile file
where
open :: String -> Maybe [Setting]
open line
| "" `isPrefixOf` line =
let suffix = dropPrefix "" line
config = decodeEither' $ BS.pack suffix
in case config of
Left err -> Just []
Right config -> Just $ settingsFromConfigYaml [config]
| otherwise = Nothing
shut :: String -> Bool
shut = isPrefixOf " "
f :: Maybe [Setting] -> Refactor -> [(Int, String)] -> [TestCase]
f Nothing _ ((i,x):xs) = f (open x) TestRefactor xs
f (Just s) refact ((i,x):xs)
| shut x = f Nothing TestRefactor xs
| Just (x',_) <- stripInfix "@NoRefactor" x =
f (Just s) SkipRefactor ((i, trimEnd x' ++ ['\\' | "\\" `isSuffixOf` x]) : xs)
| null x || "-- " `isPrefixOf` x = f (Just s) refact xs
| Just x <- stripSuffix "\\" x, (_,y):ys <- xs = f (Just s) refact $ (i,x++"\n"++y):ys
| otherwise = parseTest refact file i x s : f (Just s) TestRefactor xs
f _ _ [] = []
parseTest :: Refactor -> String -> Int -> String -> [Setting] -> TestCase
parseTest refact file i x = uncurry (TestCase (mkSrcLoc (mkFastString file) i 0) refact) $ f x
where
f x | Just x <- stripPrefix "" x = first ("--"++) $ f x
f (' ':'-':'-':xs) | null xs || " " `isPrefixOf` xs = ("", Just $ trimStart xs)
f (x:xs) = first (x:) $ f xs
f [] = ([], Nothing)
-- Returns an empty list if the refactoring test passes, otherwise
-- returns error messages.
testRefactor :: Maybe FilePath -> Maybe Idea -> String -> IO [String]
-- Skip refactoring test if the refactor binary is not found.
testRefactor Nothing _ _ = pure []
-- Skip refactoring test if the hint has no suggestion (i.e., a parse error).
testRefactor _ (Just idea) _ | isNothing (ideaTo idea) = pure []
testRefactor (Just rpath) midea inp = withTempFile $ \tempInp -> withTempFile $ \tempHints -> do
-- Note that we test the refactoring even if there are no suggestions,
-- as an extra test of apply-refact, on which we rely.
-- See https://github.com/ndmitchell/hlint/issues/958 for a discussion.
let refacts = map (show &&& ideaRefactoring) (maybeToList midea)
-- Ignores spaces and semicolons since apply-refact may change them.
process = filter (\c -> not (isSpace c) && c /= ';')
matched expected g actual = process expected `g` process actual
x `isProperSubsequenceOf` y = x /= y && x `isSubsequenceOf` y
writeFile tempInp inp
writeFile tempHints (show refacts)
exitCode <- runRefactoring rpath tempInp tempHints defaultExtensions [] "--inplace"
refactored <- readFile tempInp
pure $ case exitCode of
ExitFailure ec -> ["Refactoring failed: exit code " ++ show ec]
ExitSuccess -> case fmap ideaTo midea of
-- No hints. Refactoring should be a no-op.
Nothing | not (matched inp (==) refactored) ->
["Expected refactor output: " ++ inp, "Actual: " ++ refactored]
-- The hint's suggested replacement is @Just ""@, which means the hint
-- suggests removing something from the input. The refactoring output
-- should be a proper subsequence of the input.
Just (Just "") | not (matched refactored isProperSubsequenceOf inp) ->
["Refactor output is expected to be a proper subsequence of: " ++ inp, "Actual: " ++ refactored]
-- The hint has a suggested replacement. The suggested replacement
-- should be a substring of the refactoring output.
Just (Just to) | not (matched to isInfixOf refactored) ->
["Refactor output is expected to contain: " ++ to, "Actual: " ++ refactored]
_ -> []
hlint-3.1.6/src/Test/All.hs 0000644 0000000 0000000 00000007722 13674632146 013623 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
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.Either.Extra
import Data.Foldable
import Data.List
import Data.Maybe
import System.Directory
import System.FilePath
import Data.Functor
import Prelude
import Config.Type
import Config.Read
import CmdLine
import Refact
import Hint.All
import Test.Annotations
import Test.InputOutput
import Test.Summary
import Test.Translate
import Test.Util
import System.IO.Extra
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
test :: Cmd -> ([String] -> IO ()) -> FilePath -> [FilePath] -> IO Int
test CmdTest{..} main dataDir files = do
rpath <- refactorPath (if cmdWithRefactor == "" then Nothing else Just cmdWithRefactor)
(failures, (ideas, builtins)) <- withBuffering stdout NoBuffering $ withTests $ do
hasSrc <- liftIO $ doesFileExist "hlint.cabal"
let useSrc = hasSrc && null files
testFiles <- if files /= [] then pure files else do
xs <- liftIO $ getDirectoryContents dataDir
pure [dataDir x | x <- xs, takeExtension x `elem` [".yml",".yaml"]]
testFiles <- liftIO $ forM testFiles $ \file -> do
hints <- readFilesConfig [(file, Nothing),("CommandLine.yaml", Just "- group: {name: testing, enabled: true}")]
pure (file, hints ++ (if takeBaseName file /= "Test" then [] else map (Builtin . fst) builtinHints))
let wrap msg act = do liftIO $ putStr (msg ++ " "); act; liftIO $ putStrLn ""
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")
(eitherToMaybe rpath)
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 (eitherToMaybe rpath)
let hs = [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"]
when cmdTypeCheck $ wrap "Hint typechecking" $
progress >> testTypeCheck cmdDataDir cmdTempDir hs
when cmdQuickCheck $ wrap "Hint QuickChecking" $
progress >> testQuickCheck cmdDataDir cmdTempDir hs
when (null files && not hasSrc) $ liftIO $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped"
(,) <$> getIdeas <*> getBuiltins
whenLoud $ mapM_ print ideas
when cmdGenerateSummary $ writeFile "builtin.md" (genBuiltinSummaryMd builtins)
case rpath of
Left refactorNotFound -> putStrLn $ unlines [refactorNotFound, "Refactoring tests skipped"]
_ -> pure ()
pure failures
---------------------------------------------------------------------
-- VARIOUS SMALL TESTS
-- Check all hints in the standard config files get sensible names
testNames :: [Setting] -> Test ()
testNames hints = sequence_
[ failed ["No name for the hint " ++ unsafePrettyPrint hintRuleLHS ++ " ==> " ++ unsafePrettyPrint 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
let src2 = [x | x <- src, Just x <- [stripPrefix "# " x], not $ all (\x -> isAlpha x || x == '$') $ take 1 x]
e <- readFilesConfig [(file, Just $ unlines src2)]
void $ evaluate $ length e
hlint-3.1.6/src/Language/ 0000755 0000000 0000000 00000000000 13674744764 013365 5 ustar 00 0000000 0000000 hlint-3.1.6/src/Language/Haskell/ 0000755 0000000 0000000 00000000000 13674744764 014750 5 ustar 00 0000000 0000000 hlint-3.1.6/src/Language/Haskell/HLint.hs 0000644 0000000 0000000 00000014231 13671470061 016302 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, RecordWildCards #-}
-- | This module provides a way to apply HLint hints. If you want to just run @hlint@ in-process
-- and collect the results see 'hlint'.
--
-- If you want to approximate the @hlint@ experience with
-- a more structured API try:
--
-- @
-- (flags, classify, hint) <- 'autoSettings'
-- Right m <- 'parseModuleEx' flags \"MyFile.hs\" Nothing
-- print $ 'applyHints' classify hint [m]
-- @
module Language.Haskell.HLint(
-- * Generate hints
hlint, applyHints,
-- * Idea data type
Idea(..), Severity(..), Note(..), unpackSrcSpan,
-- * Settings
Classify(..),
getHLintDataDir, autoSettings, argsSettings,
findSettings, readSettingsFile,
-- * Hints
Hint,
-- * Modules
ModuleEx, parseModuleEx, createModuleEx, ParseError(..),
-- * Parse flags
defaultParseFlags,
ParseFlags(..), CppFlags(..), FixityInfo,
parseFlagsAddFixities,
) where
import Config.Type
import Config.Read
import Control.Exception.Extra
import Idea
import qualified Apply as H
import HLint
import Fixity
import FastString
import GHC.All
import Hint.All hiding (resolveHints)
import qualified Hint.All as H
import SrcLoc
import CmdLine
import Paths_hlint
import Data.List.Extra
import Data.Maybe
import System.FilePath
import Data.Functor
import Prelude
-- | Get the Cabal configured data directory of HLint.
getHLintDataDir :: IO FilePath
getHLintDataDir = getDataDir
-- | The function produces a tuple containg 'ParseFlags' (for 'parseModuleEx'),
-- and 'Classify' and 'Hint' for 'applyHints'.
-- It approximates the normal HLint configuration steps, roughly:
--
-- 1. Use 'findSettings' with 'readSettingsFile' to find and load the HLint settings files.
--
-- 1. Use 'parseFlagsAddFixities' and 'resolveHints' to transform the outputs of 'findSettings'.
--
-- If you want to do anything custom (e.g. using a different data directory, storing intermediate outputs,
-- loading hints from a database) you are expected to copy and paste this function, then change it to your needs.
autoSettings :: IO (ParseFlags, [Classify], Hint)
autoSettings = do
(fixities, classify, hints) <- findSettings (readSettingsFile Nothing) Nothing
pure (parseFlagsAddFixities fixities defaultParseFlags, classify, hints)
-- | A version of 'autoSettings' which respects some of the arguments supported by HLint.
-- If arguments unrecognised by HLint are used it will result in an error.
-- Arguments which have no representation in the return type are silently ignored.
argsSettings :: [String] -> IO (ParseFlags, [Classify], Hint)
argsSettings args = do
cmd <- getCmd args
case cmd of
CmdMain{..} -> do
-- FIXME: One thing that could be supported (but isn't) is 'cmdGivenHints'
(_,settings) <- readAllSettings args cmd
let (fixities, classify, hints) = splitSettings settings
let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ parseFlagsAddFixities fixities $
defaultParseFlags{cppFlags = cmdCpp cmd}
let ignore = [Classify Ignore x "" "" | x <- cmdIgnore]
pure (flags, classify ++ ignore, hints)
_ -> errorIO "Can only invoke autoSettingsArgs with the root process"
-- | Given a directory (or 'Nothing' to imply 'getHLintDataDir'), and a module name
-- (e.g. @HLint.Default@), find the settings file associated with it, returning the
-- name of the file, and (optionally) the contents.
--
-- This function looks for all settings files starting with @HLint.@ in the directory
-- argument, and all other files relative to the current directory.
readSettingsFile :: Maybe FilePath -> String -> IO (FilePath, Maybe String)
readSettingsFile dir x
| takeExtension x `elem` [".yml",".yaml"] = do
dir <- maybe getHLintDataDir pure dir
pure (dir x, Nothing)
| Just x <- "HLint." `stripPrefix` x = do
dir <- maybe getHLintDataDir pure dir
pure (dir x <.> "hs", Nothing)
| otherwise = pure (x <.> "hs", Nothing)
-- | Given a function to load a module (typically 'readSettingsFile'), and a module to start from
-- (defaults to @hlint.yaml@) find the information from all settings files.
findSettings :: (String -> IO (FilePath, Maybe String)) -> Maybe String -> IO ([FixityInfo], [Classify], Hint)
findSettings load start = do
(file,contents) <- load $ fromMaybe "hlint.yaml" start
splitSettings <$> readFilesConfig [(file,contents)]
-- | Split a list of 'Setting' for separate use in parsing and hint resolution
splitSettings :: [Setting] -> ([FixityInfo], [Classify], Hint)
splitSettings xs =
([x | Infix x <- xs]
,[x | SettingClassify x <- xs]
,H.resolveHints $ [Right x | SettingMatchExp x <- xs] ++ map Left enumerate)
-- | 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.
--
-- Given a set of modules, it may be faster to pass each to 'applyHints' in a singleton list.
-- When given multiple modules at once this function attempts to find hints between modules,
-- which is slower and often pointless (by default HLint passes modules singularly, using
-- @--cross@ to pass all modules together).
applyHints :: [Classify] -> Hint -> [ModuleEx] -> [Idea]
applyHints = H.applyHints
-- | Snippet from the documentation, if this changes, update the documentation
_docs :: IO ()
_docs = do
(flags, classify, hint) <- autoSettings
Right m <- parseModuleEx flags "MyFile.hs" Nothing
print $ applyHints classify hint [m]
-- | Unpack a 'SrcSpan' value. Useful to allow using the 'Idea' information without
-- adding a dependency on @ghc@ or @ghc-lib-parser@. Unpacking gives:
--
-- > (filename, (startLine, startCol), (endLine, endCol))
--
-- Following the GHC API, he end column is the column /after/ the end of the error.
-- Lines and columns are 1-based. Returns 'Nothing' if there is no helpful location information.
unpackSrcSpan :: SrcSpan -> Maybe (FilePath, (Int, Int), (Int, Int))
unpackSrcSpan (RealSrcSpan x) = Just
(unpackFS $ srcSpanFile x
,(srcSpanStartLine x, srcSpanStartCol x)
,(srcSpanEndLine x, srcSpanEndCol x))
unpackSrcSpan _ = Nothing
hlint-3.1.6/src/Hint/ 0000755 0000000 0000000 00000000000 13674744765 012545 5 ustar 00 0000000 0000000 hlint-3.1.6/src/Hint/Unsafe.hs 0000644 0000000 0000000 00000006641 13671470061 014307 0 ustar 00 0000000 0000000
{-
Find things that are unsafe
{-# NOINLINE slaves #-}; slaves = unsafePerformIO newIO
slaves = unsafePerformIO Multimap.newIO -- {-# NOINLINE slaves #-} ; slaves = unsafePerformIO Multimap.newIO
slaves = unsafePerformIO $ f y where foo = 1 -- {-# NOINLINE slaves #-} ; slaves = unsafePerformIO $ f y where foo = 1
slaves v = unsafePerformIO $ Multimap.newIO where foo = 1
slaves v = x where x = unsafePerformIO $ Multimap.newIO
slaves = x where x = unsafePerformIO $ Multimap.newIO -- {-# NOINLINE slaves #-} ; slaves = x where x = unsafePerformIO $ Multimap.newIO
slaves = unsafePerformIO . bar
slaves = unsafePerformIO . baz $ x -- {-# NOINLINE slaves #-} ; slaves = unsafePerformIO . baz $ x
slaves = unsafePerformIO . baz $ x -- {-# NOINLINE slaves #-} ; slaves = unsafePerformIO . baz $ x
-}
module Hint.Unsafe(unsafeHint) where
import Hint.Type(DeclHint,ModuleEx(..),Severity(..),rawIdea,toSS)
import Data.List.Extra
import Refact.Types hiding(Match)
import Data.Generics.Uniplate.DataOnly
import GHC.Hs
import OccName
import RdrName
import FastString
import BasicTypes
import SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
-- The conditions on which to fire this hint are subtle. We are
-- interested exclusively in application constants involving
-- 'unsafePerformIO'. For example,
-- @
-- f = \x -> unsafePerformIO x
-- @
-- is not such a declaration (the right hand side is a lambda, not an
-- application) whereas,
-- @
-- f = g where g = unsafePerformIO Multimap.newIO
-- @
-- is. We advise that such constants should have a @NOINLINE@ pragma.
unsafeHint :: DeclHint
unsafeHint _ (ModuleEx (L _ m) _) = \(L loc d) ->
[rawIdea Hint.Type.Warning "Missing NOINLINE pragma" loc
(unsafePrettyPrint d)
(Just $ trimStart (unsafePrettyPrint $ gen x) ++ "\n" ++ unsafePrettyPrint d)
[] [InsertComment (toSS (L loc d)) (unsafePrettyPrint $ gen x)]
-- 'x' does not declare a new function.
| d@(ValD _
FunBind {fun_id=L _ (Unqual x)
, fun_matches=MG{mg_origin=FromSource,mg_alts=L _ [L _ Match {m_pats=[]}]}}) <- [d]
-- 'x' is a synonym for an appliciation involing 'unsafePerformIO'
, isUnsafeDecl d
-- 'x' is not marked 'NOINLINE'.
, x `notElem` noinline]
where
gen :: OccName -> LHsDecl GhcPs
gen x = noLoc $
SigD noExtField (InlineSig noExtField (noLoc (mkRdrUnqual x))
(InlinePragma (SourceText "{-# NOINLINE") NoInline Nothing NeverActive FunLike))
noinline :: [OccName]
noinline = [q | L _(SigD _ (InlineSig _ (L _ (Unqual q))
(InlinePragma _ NoInline Nothing NeverActive FunLike))
) <- hsmodDecls m]
isUnsafeDecl :: HsDecl GhcPs -> Bool
isUnsafeDecl (ValD _ FunBind {fun_matches=MG {mg_origin=FromSource,mg_alts=L _ alts}}) =
any isUnsafeApp (childrenBi alts) || any isUnsafeDecl (childrenBi alts)
isUnsafeDecl _ = False
-- Am I equivalent to @unsafePerformIO x@?
isUnsafeApp :: HsExpr GhcPs -> Bool
isUnsafeApp (OpApp _ (L _ l) op _ ) | isDol op = isUnsafeFun l
isUnsafeApp (HsApp _ (L _ x) _) = isUnsafeFun x
isUnsafeApp _ = False
-- Am I equivalent to @unsafePerformIO . x@?
isUnsafeFun :: HsExpr GhcPs -> Bool
isUnsafeFun (HsVar _ (L _ x)) | x == mkVarUnqual (fsLit "unsafePerformIO") = True
isUnsafeFun (OpApp _ (L _ l) op _) | isDot op = isUnsafeFun l
isUnsafeFun _ = False
hlint-3.1.6/src/Hint/Type.hs 0000644 0000000 0000000 00000002611 13671470061 014000 0 ustar 00 0000000 0000000
module Hint.Type(
DeclHint, ModuHint, CrossHint, Hint(..),
module Export
) where
import Data.Semigroup
import Config.Type
import GHC.All as Export
import Idea as Export
import Prelude
import Refact as Export
import GHC.Hs.Extension
import GHC.Hs.Decls
import GHC.Util.Scope
type DeclHint = Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]
type ModuHint = Scope -> ModuleEx -> [Idea]
type CrossHint = [(Scope, ModuleEx)] -> [Idea]
-- | Functions to generate hints, combined using the 'Monoid' instance.
data Hint {- PUBLIC -} = Hint
{ hintModules :: [Setting] -> [(Scope, ModuleEx)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's.
, hintModule :: [Setting] -> Scope -> ModuleEx -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's.
, hintDecl :: [Setting] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [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.
}
instance Semigroup Hint where
Hint x1 x2 x3 <> Hint y1 y2 y3 = Hint
(\a b -> x1 a b ++ y1 a b)
(\a b c -> x2 a b c ++ y2 a b c)
(\a b c d -> x3 a b c d ++ y3 a b c d)
instance Monoid Hint where
mempty = Hint (\_ _ -> []) (\_ _ _ -> []) (\_ _ _ _ -> [])
mappend = (<>)
hlint-3.1.6/src/Hint/Smell.hs 0000644 0000000 0000000 00000011775 13671470061 014146 0 ustar 00 0000000 0000000
module Hint.Smell (
smellModuleHint,
smellHint
) where
{-
[{smell: { type: many arg functions, limit: 2 }}]
f :: Int -> Int \
f = undefined
f :: Int -> Int -> Int \
f = undefined --
f :: Int -> Int \
f = undefined
f :: Int -> Int -> Int \
f = undefined
[{smell: { type: long functions, limit: 3}}]
f = do \
x <- y \
return x --
f = do \
return z \
\
where \
z = do \
a \
b --
f = do \
return z \
\
where \
z = a
f = Con \
{ a = x \
, b = y \
, c = z \
}
f = return x
f = do \
x <- y \
return x
f = return x
[{smell: { type: long type lists, limit: 2}}]
f :: Bool -> Int -> (Int -> Proxy '[a, b]) --
f :: Proxy '[a]
f :: Proxy '[a, b]
f :: Proxy '[a]
[{smell: { type: many imports, limit: 2}}]
import A; import B --
import A
import A; import B
import A
-}
import Hint.Type(ModuHint,ModuleEx(..),DeclHint,Idea(..),rawIdea,warn)
import Config.Type
import Data.Generics.Uniplate.DataOnly
import Data.List.Extra
import qualified Data.Map as Map
import BasicTypes
import GHC.Hs
import RdrName
import Outputable
import Bag
import SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
smellModuleHint :: [Setting] -> ModuHint
smellModuleHint settings scope m =
let (L _ mod) = ghcModule m
imports = hsmodImports mod in
case Map.lookup SmellManyImports (smells settings) of
Just n | length imports >= n ->
let span = foldl1 combineSrcSpans $ getLoc <$> imports
displayImports = unlines $ f <$> imports
in [rawIdea Config.Type.Warning "Many imports" span displayImports Nothing [] [] ]
where
f :: LImportDecl GhcPs -> String
f = trimStart . unsafePrettyPrint
_ -> []
smellHint :: [Setting] -> DeclHint
smellHint settings scope m d =
sniff smellLongFunctions SmellLongFunctions ++
sniff smellLongTypeLists SmellLongTypeLists ++
sniff smellManyArgFunctions SmellManyArgFunctions
where
sniff f t = fmap (\i -> i {ideaTo = Nothing }) . take 1 $ maybe [] (f d) $ Map.lookup t (smells settings)
smellLongFunctions :: LHsDecl GhcPs -> Int -> [Idea]
smellLongFunctions d n = [ idea
| (span, idea) <- declSpans d
, spanLength span >= n
]
-- I've tried to be faithful to the original here but I'm doubtful
-- about it. I think I've replicated the behavior of the original but
-- is the original correctly honoring the intent?
-- A function with with one alternative, one rhs and its 'where'
-- clause (perhaps we should be looping over alts and all guarded
-- right hand sides?)
declSpans :: LHsDecl GhcPs -> [(SrcSpan, Idea)]
declSpans
(L _ (ValD _
FunBind {fun_matches=MG {
mg_origin=FromSource
, mg_alts=(L _ [L _ Match {
m_ctxt=ctx
, m_grhss=GRHSs{grhssGRHSs=[locGrhs]
, grhssLocalBinds=where_}}])}})) =
-- The span of the right hand side and the spans of each binding in
-- the where clause.
rhsSpans ctx locGrhs ++ whereSpans where_
-- Any other kind of function.
declSpans f@(L l (ValD _ FunBind {})) = [(l, warn "Long function" f f [])]
declSpans _ = []
-- The span of a guarded right hand side.
rhsSpans :: HsMatchContext RdrName -> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)]
rhsSpans _ (L _ (GRHS _ _ (L _ RecordCon {}))) = [] -- record constructors get a pass
rhsSpans ctx (L _ r@(GRHS _ _ (L l _))) =
[(l, rawIdea Config.Type.Warning "Long function" l (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])]
rhsSpans _ _ = []
-- The spans of a 'where' clause are the spans of its bindings.
whereSpans :: LHsLocalBinds GhcPs -> [(SrcSpan, Idea)]
whereSpans (L l (HsValBinds _ (ValBinds _ bs _))) =
concatMap (declSpans . (\(L loc bind) -> L loc (ValD noExtField bind))) (bagToList bs)
whereSpans _ = []
spanLength :: SrcSpan -> Int
spanLength (RealSrcSpan span) = srcSpanEndLine span - srcSpanStartLine span + 1
spanLength (UnhelpfulSpan _) = -1
smellLongTypeLists :: LHsDecl GhcPs -> Int -> [Idea]
smellLongTypeLists d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n =
warn "Long type list" d d [] <$ filter longTypeList (universe t)
where
longTypeList (HsExplicitListTy _ IsPromoted x) = length x >= n
longTypeList _ = False
smellLongTypeLists _ _ = []
smellManyArgFunctions :: LHsDecl GhcPs -> Int -> [Idea]
smellManyArgFunctions d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n =
warn "Many arg function" d d [] <$ filter manyArgFunction (universe t)
where
manyArgFunction t = countFunctionArgs t >= n
smellManyArgFunctions _ _ = []
countFunctionArgs :: HsType GhcPs -> Int
countFunctionArgs (HsFunTy _ _ t) = 1 + countFunctionArgs (unLoc t)
countFunctionArgs (HsParTy _ t) = countFunctionArgs (unLoc t)
countFunctionArgs _ = 0
smells :: [Setting] -> Map.Map SmellType Int
smells settings = Map.fromList [ (smellType, smellLimit) | SettingSmell smellType smellLimit <- settings]
hlint-3.1.6/src/Hint/Restrict.hs 0000644 0000000 0000000 00000020464 13671470061 014664 0 ustar 00 0000000 0000000 {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Hint.Restrict(restrictHint) where
{-
-- These tests rely on the .hlint.yaml file in the root
foo = unsafePerformIO --
foo = bar `unsafePerformIO` baz --
module Util where otherFunc = unsafePerformIO $ print 1 --
module Util where exitMessageImpure = System.IO.Unsafe.unsafePerformIO $ print 1
foo = unsafePerformOI
import Data.List.NonEmpty as NE \
foo = NE.nub (NE.fromList [1, 2, 3]) --
import Hypothetical.Module \
foo = nub s
-}
import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn,rawIdea)
import Config.Type
import Data.Generics.Uniplate.DataOnly
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.List.Extra
import Data.Maybe
import Data.Semigroup
import Data.Tuple.Extra
import Control.Applicative
import Control.Monad
import Prelude
import GHC.Hs
import RdrName
import ApiAnnotation
import Module
import SrcLoc
import OccName
import Language.Haskell.GhclibParserEx.GHC.Hs
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import GHC.Util
-- FIXME: The settings should be partially applied, but that's hard to orchestrate right now
restrictHint :: [Setting] -> ModuHint
restrictHint settings scope m =
let anns = ghcAnnotations m
ps = pragmas anns
opts = flags ps
exts = languagePragmas ps in
checkPragmas modu opts exts rOthers ++
maybe [] (checkImports modu $ hsmodImports (unLoc (ghcModule m))) (Map.lookup RestrictModule rOthers) ++
checkFunctions scope modu (hsmodDecls (unLoc (ghcModule m))) rFunction
where
modu = modName (ghcModule m)
(rFunction, rOthers) = restrictions settings
---------------------------------------------------------------------
-- UTILITIES
data RestrictItem = RestrictItem
{riAs :: [String]
,riWithin :: [(String, String)]
,riBadIdents :: [String]
,riMessage :: Maybe String
}
instance Semigroup RestrictItem where
RestrictItem x1 x2 x3 x4 <> RestrictItem y1 y2 y3 y4 = RestrictItem (x1<>y1) (x2<>y2) (x3<>y3) (x4<>y4)
-- Contains a map from module (Nothing if the rule is unqualified) to (within, message), so that we can
-- distinguish functions with the same name.
-- For example, this allows us to have separate rules for "Data.Map.fromList" and "Data.Set.fromList".
-- Using newtype rather than type because we want to define (<>) as 'Map.unionWith (<>)'.
newtype RestrictFunction = RestrictFun (Map.Map (Maybe String) ([(String, String)], Maybe String))
instance Semigroup RestrictFunction where
RestrictFun m1 <> RestrictFun m2 = RestrictFun (Map.unionWith (<>) m1 m2)
type RestrictFunctions = (Bool, Map.Map String RestrictFunction)
type OtherRestrictItems = Map.Map RestrictType (Bool, Map.Map String RestrictItem)
restrictions :: [Setting] -> (RestrictFunctions, OtherRestrictItems)
restrictions settings = (rFunction, rOthers)
where
(map snd -> rfs, ros) = partition ((== RestrictFunction) . fst) [(restrictType x, x) | SettingRestrict x <- settings]
rFunction = (all restrictDefault rfs, Map.fromListWith (<>) [mkRf s r | r <- rfs, s <- restrictName r])
mkRf s Restrict{..} = (name, RestrictFun $ Map.singleton modu (restrictWithin, restrictMessage))
where
-- Parse module and name from s. module = Nothing if the rule is unqualified.
(modu, name) = first (fmap NonEmpty.init . NonEmpty.nonEmpty) (breakEnd (== '.') s)
rOthers = Map.map f $ Map.fromListWith (++) (map (second pure) ros)
f rs = (all restrictDefault rs
,Map.fromListWith (<>) [(s, RestrictItem restrictAs restrictWithin restrictBadIdents restrictMessage) | Restrict{..} <- rs, s <- restrictName])
ideaMessage :: Maybe String -> Idea -> Idea
ideaMessage (Just message) w = w{ideaNote=[Note message]}
ideaMessage Nothing w = w{ideaNote=[noteMayBreak]}
ideaNoTo :: Idea -> Idea
ideaNoTo w = w{ideaTo=Nothing}
noteMayBreak :: Note
noteMayBreak = Note "may break the code"
within :: String -> String -> [(String, String)] -> Bool
within modu func = any (\(a,b) -> (a == modu || a == "") && (b == func || b == ""))
---------------------------------------------------------------------
-- CHECKS
checkPragmas :: String
-> [(Located AnnotationComment, [String])]
-> [(Located AnnotationComment, [String])]
-> Map.Map RestrictType (Bool, Map.Map String RestrictItem)
-> [Idea]
checkPragmas modu flags exts mps =
f RestrictFlag "flags" flags ++ f RestrictExtension "extensions" exts
where
f tag name xs =
[(if null good then ideaNoTo else id) $ notes $ rawIdea Hint.Type.Warning ("Avoid restricted " ++ name) l c Nothing [] []
| Just (def, mp) <- [Map.lookup tag mps]
, (L l (AnnBlockComment c), les) <- xs
, let (good, bad) = partition (isGood def mp) les
, let note = maybe noteMayBreak Note . (=<<) riMessage . flip Map.lookup mp
, let notes w = w {ideaNote=note <$> bad}
, not $ null bad]
isGood def mp x = maybe def (within modu "" . riWithin) $ Map.lookup x mp
checkImports :: String -> [LImportDecl GhcPs] -> (Bool, Map.Map String RestrictItem) -> [Idea]
checkImports modu imp (def, mp) =
[ ideaMessage riMessage
$ if | not allowImport -> ideaNoTo $ warn "Avoid restricted module" i i []
| not allowIdent -> ideaNoTo $ warn "Avoid restricted identifiers" i i []
| not allowQual -> warn "Avoid restricted qualification" i (noLoc $ (unLoc i){ ideclAs=noLoc . mkModuleName <$> listToMaybe riAs} :: Located (ImportDecl GhcPs)) []
| otherwise -> error "checkImports: unexpected case"
| i@(L _ ImportDecl {..}) <- imp
, let RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def] [] Nothing) (moduleNameString (unLoc ideclName)) mp
, let allowImport = within modu "" riWithin
, let allowIdent = Set.disjoint
(Set.fromList riBadIdents)
(Set.fromList (maybe [] (\(b, lxs) -> if b then [] else concatMap (importListToIdents . unLoc) (unLoc lxs)) ideclHiding))
, let allowQual = maybe True (\x -> null riAs || moduleNameString (unLoc x) `elem` riAs) ideclAs
, not allowImport || not allowQual || not allowIdent
]
importListToIdents :: IE GhcPs -> [String]
importListToIdents =
catMaybes .
\case (IEVar _ n) -> [fromName n]
(IEThingAbs _ n) -> [fromName n]
(IEThingAll _ n) -> [fromName n]
(IEThingWith _ n _ ns _) -> fromName n : map fromName ns
_ -> []
where
fromName :: LIEWrappedName (IdP GhcPs) -> Maybe String
fromName wrapped = case unLoc wrapped of
IEName n -> fromId (unLoc n)
IEPattern n -> ("pattern " ++) <$> fromId (unLoc n)
IEType n -> ("type " ++) <$> fromId (unLoc n)
fromId :: IdP GhcPs -> Maybe String
fromId (Unqual n) = Just $ occNameString n
fromId (Qual _ n) = Just $ occNameString n
fromId (Orig _ n) = Just $ occNameString n
fromId (Exact _) = Nothing
checkFunctions :: Scope -> String -> [LHsDecl GhcPs] -> RestrictFunctions -> [Idea]
checkFunctions scope modu decls (def, mp) =
[ (ideaMessage message $ ideaNoTo $ warn "Avoid restricted function" x x []){ideaDecl = [dname]}
| d <- decls
, let dname = fromMaybe "" (declName d)
, x <- universeBi d :: [Located RdrName]
, let xMods = possModules scope x
, let (withins, message) = fromMaybe ([("","") | def], Nothing) (findFunction x xMods)
, not $ within modu dname withins
]
where
-- Returns Just iff there are rules for x, which are either unqualified, or qualified with a module that is
-- one of x's possible modules.
-- If there are multiple matching rules (e.g., there's both an unqualified version and a qualified version), their
-- withins and messages are concatenated with (<>).
findFunction :: Located RdrName -> [ModuleName] -> Maybe ([(String, String)], Maybe String)
findFunction (rdrNameStr -> x) (map moduleNameString -> possMods)
| Just (RestrictFun mp) <- Map.lookup x mp =
fmap sconcat . NonEmpty.nonEmpty . Map.elems $ Map.filterWithKey (const . maybe True (`elem` possMods)) mp
| otherwise = Nothing
hlint-3.1.6/src/Hint/Pragma.hs 0000644 0000000 0000000 00000014022 13674632146 014274 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-
Suggest better pragmas
OPTIONS_GHC -cpp => LANGUAGE CPP
OPTIONS_GHC -fglasgow-exts => LANGUAGE ... (in HSE)
OPTIONS_GHC -XFoo => LANGUAGE Foo
LANGUAGE A, A => LANGUAGE A
-- do not do LANGUAGE A, LANGUAGE B to combine
{-# OPTIONS_GHC -cpp #-} -- {-# LANGUAGE CPP #-}
{-# OPTIONS -cpp #-} -- {-# LANGUAGE CPP #-}
{-# OPTIONS_YHC -cpp #-}
{-# OPTIONS_GHC -XFoo #-} -- {-# LANGUAGE Foo #-}
{-# OPTIONS_GHC -fglasgow-exts #-} -- ??? @NoRefactor
{-# LANGUAGE RebindableSyntax, EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase #-}
{-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields #-}
{-# LANGUAGE RebindableSyntax #-}
{-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-} @NoRefactor -foo is not a valid flag
{-# OPTIONS_GHC -cpp -w #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -w #-}
{-# OPTIONS_GHC -cpp #-} \
{-# LANGUAGE CPP, Text #-} --
{-# LANGUAGE RebindableSyntax #-} \
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RebindableSyntax #-} \
{-# LANGUAGE EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase #-}
-}
module Hint.Pragma(pragmaHint) where
import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),toSS,rawIdea)
import Data.List.Extra
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Refact.Types
import qualified Refact.Types as R
import ApiAnnotation
import SrcLoc
import GHC.Util
import DynFlags
pragmaHint :: ModuHint
pragmaHint _ modu =
let ps = pragmas (ghcAnnotations modu)
opts = flags ps
lang = languagePragmas ps in
languageDupes lang ++ optToPragma opts lang
optToPragma :: [(Located AnnotationComment, [String])]
-> [(Located AnnotationComment, [String])]
-> [Idea]
optToPragma flags languagePragmas =
[pragmaIdea (OptionsToComment (fst <$> old2) ys rs) | Just old2 <- [NE.nonEmpty old]]
where
(old, new, ns, rs) =
unzip4 [(old, new, ns, r)
| old <- flags, Just (new, ns) <- [optToLanguage old ls]
, let r = mkRefact old new ns]
ls = concatMap snd languagePragmas
ns2 = nubOrd (concat ns) \\ ls
ys = [mkLanguagePragmas noSrcSpan ns2 | ns2 /= []] ++ catMaybes new
mkRefact :: (Located AnnotationComment, [String])
-> Maybe (Located AnnotationComment)
-> [String]
-> Refactoring R.SrcSpan
mkRefact old (maybe "" comment -> new) ns =
let ns' = map (\n -> comment (mkLanguagePragmas noSrcSpan [n])) ns
in ModifyComment (toSS (fst old)) (intercalate "\n" (filter (not . null) (ns' `snoc` new)))
data PragmaIdea = SingleComment (Located AnnotationComment) (Located AnnotationComment)
| MultiComment (Located AnnotationComment) (Located AnnotationComment) (Located AnnotationComment)
| OptionsToComment (NE.NonEmpty (Located AnnotationComment)) [Located AnnotationComment] [Refactoring R.SrcSpan]
pragmaIdea :: PragmaIdea -> Idea
pragmaIdea pidea =
case pidea of
SingleComment old new ->
mkFewer (getLoc old) (comment old) (Just $ comment new) []
[ModifyComment (toSS old) (comment new)]
MultiComment repl delete new ->
mkFewer (getLoc repl)
(f [repl, delete]) (Just $ comment new) []
[ ModifyComment (toSS repl) (comment new)
, ModifyComment (toSS delete) ""]
OptionsToComment old new r ->
mkLanguage (getLoc . NE.head $ old)
(f $ NE.toList old) (Just $ f new) []
r
where
f = unlines . map comment
mkFewer = rawIdea Hint.Type.Warning "Use fewer LANGUAGE pragmas"
mkLanguage = rawIdea Hint.Type.Warning "Use LANGUAGE pragmas"
languageDupes :: [(Located AnnotationComment, [String])] -> [Idea]
languageDupes ( (a@(L l _), les) : cs ) =
(if nubOrd les /= les
then [pragmaIdea (SingleComment a (mkLanguagePragmas l $ nubOrd les))]
else [pragmaIdea (MultiComment a b (mkLanguagePragmas l (nubOrd $ les ++ les'))) | ( b@(L _ _), les' ) <- cs, not $ disjoint les les']
) ++ languageDupes cs
languageDupes _ = []
-- Given a pragma, can you extract some language features out?
strToLanguage :: String -> Maybe [String]
strToLanguage "-cpp" = Just ["CPP"]
strToLanguage x | "-X" `isPrefixOf` x = Just [drop 2 x]
strToLanguage "-fglasgow-exts" = Just $ map show glasgowExtsFlags
strToLanguage _ = Nothing
-- In 'optToLanguage p langexts', 'p' is an 'OPTIONS_GHC' pragma,
-- 'langexts' a list of all language extensions in the module enabled
-- by 'LANGUAGE' pragmas.
--
-- If ALL of the flags in the pragma enable language extensions,
-- 'return Nothing'.
--
-- If some (or all) of the flags enable options that are not language
-- extensions, compute a new options pragma with only non-language
-- extension enabling flags. Return that together with a list of any
-- language extensions enabled by this pragma that are not otherwise
-- enabled by LANGUAGE pragmas in the module.
optToLanguage :: (Located AnnotationComment, [String])
-> [String]
-> Maybe (Maybe (Located AnnotationComment), [String])
optToLanguage (L loc _, flags) languagePragmas
| any isJust vs =
-- 'ls' is a list of language features enabled by this
-- OPTIONS_GHC pragma that are not enabled by LANGUAGE pragmas
-- in this module.
let ls = filter (not . (`elem` languagePragmas)) (concat $ catMaybes vs) in
Just (res, ls)
where
-- Try reinterpreting each flag as a list of language features
-- (e.g. via '-X'..., '-fglasgow-exts').
vs = map strToLanguage flags -- e.g. '[Nothing, Just ["ScopedTypeVariables"], Nothing, ...]'
-- Keep any flag that does not enable language extensions.
keep = concat $ zipWith (\v f -> [f | isNothing v]) vs flags
-- If there are flags to keep, 'res' is a new pragma setting just those flags.
res = if null keep then Nothing else Just (mkFlags loc keep)
optToLanguage _ _ = Nothing
hlint-3.1.6/src/Hint/Pattern.hs 0000644 0000000 0000000 00000025545 13671470061 014507 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, PatternGuards, TypeFamilies #-}
{-
Improve the structure of code
yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e
x `yes` y = if a then b else if c then d else e -- x `yes` y ; | a = b ; | c = d ; | otherwise = e
no x y = if a then b else c
-- foo b | c <- f b = c -- foo (f -> c) = c
-- foo x y b z | c:cs <- f g b = c -- foo x y (f g -> c:cs) z = c
foo b | c <- f b = c + b
foo b | c <- f b = c where f = here
foo b | c <- f b = c where foo = b
foo b | c <- f b = c \
| c <- f b = c
foo x = yes x x where yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e
foo x | otherwise = y -- foo x = y
foo x = x + x where -- @NoRefactor: refactoring for "Redundant where" is not implemented
foo x | a = b | True = d -- foo x | a = b ; | otherwise = d
foo (Bar _ _ _ _) = x -- Bar{}
foo (Bar _ x _ _) = x
foo (Bar _ _) = x
foo = case f v of _ -> x -- x
foo = case v of v -> x -- x
foo = case v of z -> z
foo = case v of _ | False -> x
foo x | x < -2 * 3 = 4 @NoRefactor: ghc-exactprint bug; -2 becomes 2.
foo = case v of !True -> x -- True
{-# LANGUAGE BangPatterns #-}; foo = case v of !True -> x -- True
{-# LANGUAGE BangPatterns #-}; foo = case v of !(Just x) -> x -- (Just x)
{-# LANGUAGE BangPatterns #-}; foo = case v of !(x : xs) -> x -- (x:xs)
{-# LANGUAGE BangPatterns #-}; foo = case v of !1 -> x -- 1
{-# LANGUAGE BangPatterns #-}; foo = case v of !x -> x
{-# LANGUAGE BangPatterns #-}; foo = case v of !(I# x) -> y -- (I# x)
foo = let ~x = 1 in y -- x
foo = let ~(x:xs) = y in z
{-# LANGUAGE BangPatterns #-}; foo = let !x = undefined in y
{-# LANGUAGE BangPatterns #-}; foo = let !(I# x) = 4 in x
{-# LANGUAGE BangPatterns #-}; foo = let !(Just x) = Nothing in 3
{-# LANGUAGE BangPatterns #-}; foo = 1 where f !False = 2 -- False
{-# LANGUAGE BangPatterns #-}; foo = 1 where !False = True
{-# LANGUAGE BangPatterns #-}; foo = 1 where g (Just !True) = Nothing -- True
{-# LANGUAGE BangPatterns #-}; foo = 1 where Just !True = Nothing
foo otherwise = 1 -- _ @NoRefactor
foo ~x = y -- x
{-# LANGUAGE Strict #-} foo ~x = y
{-# LANGUAGE BangPatterns #-}; foo !(x, y) = x -- (x, y)
{-# LANGUAGE BangPatterns #-}; foo ![x] = x -- [x]
foo !Bar { bar = x } = x -- Bar { bar = x }
{-# LANGUAGE BangPatterns #-}; l !(() :: ()) = x -- (() :: ())
foo x@_ = x -- x
foo x@Foo = x
otherwise = True
-}
module Hint.Pattern(patternHint) where
import Hint.Type(DeclHint,Idea,ghcAnnotations,ideaTo,toSS,toRefactSrcSpan,suggest,suggestRemove,warn)
import Data.Generics.Uniplate.DataOnly
import Data.Function
import Data.List.Extra
import Data.Tuple
import Data.Maybe
import Data.Either
import Refact.Types hiding (RType(Pattern, Match), SrcSpan)
import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan)
import GHC.Hs
import SrcLoc
import RdrName
import OccName
import Bag
import BasicTypes
import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
patternHint :: DeclHint
patternHint _scope modu x =
concatMap (uncurry hints . swap) (asPattern x) ++
-- PatBind (used in 'let' and 'where') contains lazy-by-default
-- patterns, everything else is strict.
concatMap (patHint strict False) [p | PatBind _ p _ _ <- universeBi x :: [HsBind GhcPs]] ++
concatMap (patHint strict True) (universeBi $ transformBi noPatBind x) ++
concatMap expHint (universeBi x)
where
exts = nubOrd $ concatMap snd (languagePragmas (pragmas (ghcAnnotations modu))) -- language extensions enabled at source
strict = "Strict" `elem` exts
noPatBind :: LHsBind GhcPs -> LHsBind GhcPs
noPatBind (L loc a@PatBind{}) = L loc a{pat_lhs=noLoc (WildPat noExtField)}
noPatBind x = x
{-
-- Do not suggest view patterns, they aren't something everyone likes sufficiently
hints gen (Pattern pats (GuardedRhss _ [GuardedRhs _ [Generator _ pat (App _ op (view -> Var_ p))] bod]) bind)
| Just i <- findIndex (=~= (toNamed p :: Pat_)) pats
, p `notElem` (vars bod ++ vars bind)
, vars op `disjoint` decsBind, pvars pats `disjoint` vars op, pvars pat `disjoint` pvars pats
= [gen "Use view patterns" $
Pattern (take i pats ++ [PParen an $ PViewPat an op pat] ++ drop (i+1) pats) (UnGuardedRhs an bod) bind]
where
decsBind = nub $ concatMap declBind $ childrenBi bind
-}
hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea]
hints gen (Pattern l rtype pat (GRHSs _ [L _ (GRHS _ [] bod)] bind))
| length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs noExtField guards bind)) [refactoring]]
where
rawGuards :: [(LHsExpr GhcPs, LHsExpr GhcPs)]
rawGuards = asGuards bod
mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs))
mkGuard a = GRHS noExtField [noLoc $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr]
guards :: [LGRHS GhcPs (LHsExpr GhcPs)]
guards = map (noLoc . uncurry mkGuard) rawGuards
(lhs, rhs) = unzip rawGuards
mkTemplate c ps =
-- Check if the expression has been injected or is natural.
zipWith checkLoc ps ['1' .. '9']
where
checkLoc p@(L l _) v = if l == noSrcSpan then Left p else Right (c ++ [v], toSS p)
patSubts =
case pat of
[p] -> [Left p] -- Substitution doesn't work properly for PatBinds.
-- This will probably produce unexpected results if the pattern contains any template variables.
ps -> mkTemplate "p100" ps
guardSubts = mkTemplate "g100" lhs
exprSubts = mkTemplate "e100" rhs
templateGuards = map noLoc (zipWith (mkGuard `on` toString) guardSubts exprSubts)
toString (Left e) = e
toString (Right (v, _)) = strToVar v
toString' (Left e) = e
toString' (Right (v, _)) = strToPat v
template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs noExtField templateGuards bind)) [])
f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)]
f = rights
refactoring = Replace rtype (toRefactSrcSpan l) (f patSubts ++ f guardSubts ++ f exprSubts) template
hints gen (Pattern l t pats o@(GRHSs _ [L _ (GRHS _ [test] bod)] bind))
| unsafePrettyPrint test `elem` ["otherwise", "True"]
= [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (GRHS noExtField [] bod)]}) [Delete Stmt (toSS test)]]
hints _ (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds
= [suggestRemove "Redundant where" whereSpan "where" [ {- TODO refactoring for redundant where -} ]]
where
f :: LHsLocalBinds GhcPs -> Bool
f (L _ (HsValBinds _ (ValBinds _ bag _))) = isEmptyBag bag
f (L _ (HsIPBinds _ (IPBinds _ l))) = null l
f _ = False
whereSpan = case l of
UnhelpfulSpan s -> UnhelpfulSpan s
RealSrcSpan s ->
let end = realSrcSpanEnd s
start = mkRealSrcLoc (srcSpanFile s) (srcLocLine end) (srcLocCol end - 5)
in RealSrcSpan (mkRealSrcSpan start end)
hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, L _ (GRHS _ [test] bod))) binds))
| unsafePrettyPrint test == "True"
= let otherwise_ = noLoc $ BodyStmt noExtField (strToVar "otherwise") noSyntaxExpr noSyntaxExpr in
[gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS noExtField [otherwise_] bod)]}) [Replace Expr (toSS test) [] "otherwise"]]
hints _ _ = []
asGuards :: LHsExpr GhcPs -> [(LHsExpr GhcPs, LHsExpr GhcPs)]
asGuards (L _ (HsPar _ x)) = asGuards x
asGuards (L _ (HsIf _ _ a b c)) = (a, b) : asGuards c
asGuards x = [(strToVar "otherwise", x)]
data Pattern = Pattern SrcSpan R.RType [LPat GhcPs] (GRHSs GhcPs (LHsExpr GhcPs))
-- Invariant: Number of patterns may not change
asPattern :: LHsDecl GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]
asPattern (L loc x) = concatMap decl (universeBi x)
where
decl :: HsBind GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]
decl o@(PatBind _ pat rhs _) = [(Pattern loc Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest msg (L loc o :: LHsBind GhcPs) (noLoc (PatBind noExtField pat rhs ([], [])) :: LHsBind GhcPs) rs)]
decl (FunBind _ _ (MG _ (L _ xs) _) _ _) = map match xs
decl _ = []
match :: LMatch GhcPs (LHsExpr GhcPs) -> (Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)
match o@(L loc (Match _ ctx pats grhss)) = (Pattern loc R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg o (noLoc (Match noExtField ctx pats grhss) :: LMatch GhcPs (LHsExpr GhcPs)) rs)
match _ = undefined -- {-# COMPLETE L #-}
-- First Bool is if 'Strict' is a language extension. Second Bool is
-- if this pattern in this context is going to be evaluated strictly.
patHint :: Bool -> Bool -> LPat GhcPs -> [Idea]
patHint _ _ o@(L _ (ConPatIn name (PrefixCon args)))
| length args >= 3 && all isPWildcard args =
let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (LPat GhcPs)
new = noLoc $ ConPatIn name (RecCon rec_fields) :: LPat GhcPs
in
[suggest "Use record patterns" o new [Replace R.Pattern (toSS o) [] (unsafePrettyPrint new)]]
patHint _ _ o@(L _ (VarPat _ (L _ name)))
| occNameString (rdrNameOcc name) == "otherwise" =
[warn "Used otherwise as a pattern" o (noLoc (WildPat noExtField) :: LPat GhcPs) []]
patHint lang strict o@(L _ (BangPat _ pat@(L _ x)))
| strict, f x = [warn "Redundant bang pattern" o (noLoc x :: LPat GhcPs) [r]]
where
f :: Pat GhcPs -> Bool
f (ParPat _ (L _ x)) = f x
f (AsPat _ _ (L _ x)) = f x
f LitPat {} = True
f NPat {} = True
f ConPatIn {} = True
f TuplePat {} = True
f ListPat {} = True
f (SigPat _ (L _ p) _) = f p
f _ = False
r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x"
patHint False _ o@(L _ (LazyPat _ pat@(L _ x)))
| f x = [warn "Redundant irrefutable pattern" o (noLoc x :: LPat GhcPs) [r]]
where
f :: Pat GhcPs -> Bool
f (ParPat _ (L _ x)) = f x
f (AsPat _ _ (L _ x)) = f x
f WildPat{} = True
f VarPat{} = True
f _ = False
r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x"
patHint _ _ o@(L _ (AsPat _ v (L _ (WildPat _)))) =
[warn "Redundant as-pattern" o v []]
patHint _ _ _ = []
expHint :: LHsExpr GhcPs -> [Idea]
-- Note the 'FromSource' in these equations (don't warn on generated match groups).
expHint o@(L _ (HsCase _ _ (MG _ (L _ [L _ (Match _ CaseAlt [L _ (WildPat _)] (GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)))) ]) FromSource ))) =
[suggest "Redundant case" o e [r]]
where
r = Replace Expr (toSS o) [("x", toSS e)] "x"
expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG _ (L _ [L _ (Match _ CaseAlt [L _ (VarPat _ (L _ y))] (GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)))) ]) FromSource )))
| occNameStr x == occNameStr y =
[suggest "Redundant case" o e [r]]
where
r = Replace Expr (toSS o) [("x", toSS e)] "x"
expHint _ = []
hlint-3.1.6/src/Hint/NewType.hs 0000644 0000000 0000000 00000014250 13656755416 014471 0 ustar 00 0000000 0000000 {-# LANGUAGE NamedFieldPuns #-}
{-
Suggest newtype instead of data for type declarations that have
only one field. Don't suggest newtype for existentially
quantified data types because it is not valid.
data Foo = Foo Int -- newtype Foo = Foo Int @NoRefactor: refactoring for "Use newtype" is not implemented
data Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo Int deriving (Show, Eq) @NoRefactor
data Foo = Foo { field :: Int } deriving Show -- newtype Foo = Foo { field :: Int } deriving Show @NoRefactor
data Foo a b = Foo a -- newtype Foo a b = Foo a @NoRefactor
data Foo = Foo { field1, field2 :: Int}
data S a = forall b . Show b => S b @NoRefactor: apply-refact 0.6 requires RankNTypes pragma
{-# LANGUAGE RankNTypes #-}; data S a = forall b . Show b => S b
{-# LANGUAGE RankNTypes #-}; data Foo = Foo (forall a. a) -- newtype Foo = Foo (forall a. a) @NoRefactor
data Color a = Red a | Green a | Blue a
data Pair a b = Pair a b
data Foo = Bar
data Foo a = Eq a => MkFoo a
data Foo a = () => Foo a -- newtype Foo a = Foo a @NoRefactor
data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int @NoRefactor
data A = A {b :: !C} -- newtype A = A {b :: C} @NoRefactor
data A = A Int# @NoRefactor
{-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn (# Ann, x #)
{-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn {getWithAnn :: (# Ann, x #)}
data A = A () -- newtype A = A () @NoRefactor
newtype Foo = Foo Int deriving (Show, Eq) --
newtype Foo = Foo { getFoo :: Int } deriving (Show, Eq) --
newtype Foo = Foo Int deriving stock Show
-}
module Hint.NewType (newtypeHint) where
import Hint.Type (Idea, DeclHint, Note(DecreasesLaziness), ideaNote, ignoreNoSuggestion, suggestN)
import Data.List (isSuffixOf)
import GHC.Hs.Decls
import GHC.Hs
import Outputable
import SrcLoc
newtypeHint :: DeclHint
newtypeHint _ _ x = newtypeHintDecl x ++ newTypeDerivingStrategiesHintDecl x
newtypeHintDecl :: LHsDecl GhcPs -> [Idea]
newtypeHintDecl old
| Just WarnNewtype{newDecl, insideType} <- singleSimpleField old
= [(suggestN "Use newtype instead of data" old newDecl)
{ideaNote = [DecreasesLaziness | warnBang insideType]}]
newtypeHintDecl _ = []
newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea]
newTypeDerivingStrategiesHintDecl decl@(L _ (TyClD _ (DataDecl _ _ _ _ dataDef))) =
[ignoreNoSuggestion "Use DerivingStrategies" decl | not $ isData dataDef, not $ hasAllStrategies dataDef]
newTypeDerivingStrategiesHintDecl _ = []
hasAllStrategies :: HsDataDefn GhcPs -> Bool
hasAllStrategies (HsDataDefn _ NewType _ _ _ _ (L _ xs)) = all hasStrategyClause xs
hasAllStrategies _ = False
isData :: HsDataDefn GhcPs -> Bool
isData (HsDataDefn _ NewType _ _ _ _ _) = False
isData (HsDataDefn _ DataType _ _ _ _ _) = True
isData _ = False
hasStrategyClause :: LHsDerivingClause GhcPs -> Bool
hasStrategyClause (L _ (HsDerivingClause _ (Just _) _)) = True
hasStrategyClause _ = False
data WarnNewtype = WarnNewtype
{ newDecl :: LHsDecl GhcPs
, insideType :: HsType GhcPs
}
-- | Given a declaration, returns the suggested \"newtype\"ized declaration following these guidelines:
-- * Types ending in a \"#\" are __ignored__, because they are usually unboxed primitives - @data X = X Int#@
-- * @ExistentialQuantification@ stuff is __ignored__ - @data X = forall t. X t@
-- * Constructors with (nonempty) constraints are __ignored__ - @data X a = (Eq a) => X a@
-- * Single field constructors get newtyped - @data X = X Int@ -> @newtype X = X Int@
-- * Single record field constructors get newtyped - @data X = X {getX :: Int}@ -> @newtype X = X {getX :: Int}@
-- * All other declarations are ignored.
singleSimpleField :: LHsDecl GhcPs -> Maybe WarnNewtype
singleSimpleField (L loc (TyClD ext decl@(DataDecl _ _ _ _ dataDef@(HsDataDefn _ DataType _ _ _ [L _ constructor] _))))
| Just inType <- simpleCons constructor =
Just WarnNewtype
{ newDecl = L loc $ TyClD ext decl {tcdDataDefn = dataDef
{ dd_ND = NewType
, dd_cons = map (\(L consloc x) -> L consloc $ dropConsBang x) $ dd_cons dataDef
}}
, insideType = inType
}
singleSimpleField _ = Nothing
-- | Checks whether its argument is a \"simple constructor\" (see criteria in 'singleSimpleFieldNew')
-- returning the type inside the constructor if it is. This is needed for strictness analysis.
simpleCons :: ConDecl GhcPs -> Maybe (HsType GhcPs)
simpleCons (ConDeclH98 _ _ _ [] context (PrefixCon [L _ inType]) _)
| emptyOrNoContext context
, not $ isUnboxedTuple inType
, not $ isHashy inType
= Just inType
simpleCons (ConDeclH98 _ _ _ [] context (RecCon (L _ [L _ (ConDeclField _ [_] (L _ inType) _)])) _)
| emptyOrNoContext context
, not $ isUnboxedTuple inType
, not $ isHashy inType
= Just inType
simpleCons _ = Nothing
isHashy :: HsType GhcPs -> Bool
isHashy (HsTyVar _ _ identifier) = "#" `isSuffixOf` showSDocUnsafe (ppr identifier)
isHashy _ = False
warnBang :: HsType GhcPs -> Bool
warnBang (HsBangTy _ (HsSrcBang _ _ SrcStrict) _) = False
warnBang _ = True
emptyOrNoContext :: Maybe (LHsContext GhcPs) -> Bool
emptyOrNoContext Nothing = True
emptyOrNoContext (Just (L _ [])) = True
emptyOrNoContext _ = False
-- | The \"Bang\" here refers to 'HsSrcBang', which notably also includes @UNPACK@ pragmas!
dropConsBang :: ConDecl GhcPs -> ConDecl GhcPs
dropConsBang decl@(ConDeclH98 _ _ _ _ _ (PrefixCon fields) _) =
decl {con_args = PrefixCon $ map getBangType fields}
dropConsBang decl@(ConDeclH98 _ _ _ _ _ (RecCon (L recloc conDeclFields)) _) =
decl {con_args = RecCon $ cL recloc $ removeUnpacksRecords conDeclFields}
where
removeUnpacksRecords :: [LConDeclField GhcPs] -> [LConDeclField GhcPs]
removeUnpacksRecords = map (\(L conDeclFieldLoc x) -> L conDeclFieldLoc $ removeConDeclFieldUnpacks x)
removeConDeclFieldUnpacks :: ConDeclField GhcPs -> ConDeclField GhcPs
removeConDeclFieldUnpacks conDeclField@(ConDeclField _ _ fieldType _) =
conDeclField {cd_fld_type = getBangType fieldType}
removeConDeclFieldUnpacks x = x
dropConsBang x = x
isUnboxedTuple :: HsType GhcPs -> Bool
isUnboxedTuple (HsTupleTy _ HsUnboxedTuple _) = True
isUnboxedTuple _ = False
hlint-3.1.6/src/Hint/Naming.hs 0000644 0000000 0000000 00000011466 13671470061 014300 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-
Suggest the use of camelCase
Only permit:
_*[A-Za-z]*_*#*'*
Apply this to things that would get exported by default only
Also allow prop_ as it's a standard QuickCheck idiom
Also allow case_ as it's a standard test-framework-th idiom
Also allow test_ as it's a standard tasty-th idiom
Also allow numbers separated by _
Also don't suggest anything mentioned elsewhere in the module
Don't suggest for FFI, since they match their C names
data Yes = Foo | Bar'Test
data Yes = Bar | Test_Bar -- data Yes = Bar | TestBar @NoRefactor
data No = a :::: b
data Yes = Foo {bar_cap :: Int}
data No = FOO | BarBAR | BarBBar
yes_foo = yes_foo + yes_foo -- yesFoo = ... @NoRefactor
yes_fooPattern Nothing = 0 -- yesFooPattern Nothing = ... @NoRefactor
no = 1 where yes_foo = 2
a -== b = 1
myTest = 1; my_test = 1
semiring'laws = 1
data Yes = FOO_A | Foo_B -- data Yes = FOO_A | FooB @NoRefactor
case_foo = 1
test_foo = 1
cast_foo = 1 -- castFoo = ... @NoRefactor
replicateM_ = 1
_foo__ = 1
section_1_1 = 1
runMutator# = 1 @NoRefactor
foreign import ccall hexml_node_child :: IO ()
-}
module Hint.Naming(namingHint) where
import Hint.Type (Idea,DeclHint,suggest,ghcModule)
import Data.Generics.Uniplate.DataOnly
import Data.List.Extra (nubOrd, isPrefixOf)
import Data.Data
import Data.Char
import Data.Maybe
import qualified Data.Set as Set
import BasicTypes
import FastString
import GHC.Hs.Decls
import GHC.Hs.Extension
import GHC.Hs
import OccName
import SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Hs.Decls
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import GHC.Util
namingHint :: DeclHint
namingHint _ modu = naming $ Set.fromList $ concatMap getNames $ hsmodDecls $ unLoc (ghcModule modu)
naming :: Set.Set String -> LHsDecl GhcPs -> [Idea]
naming seen originalDecl =
[ suggest "Use camelCase"
(shorten originalDecl)
(shorten replacedDecl)
[ -- https://github.com/mpickering/apply-refact/issues/39
]
| not $ null suggestedNames
]
where
suggestedNames =
[ (originalName, suggestedName)
| not $ isForD originalDecl
, originalName <- nubOrd $ getNames originalDecl
, Just suggestedName <- [suggestName originalName]
, not $ suggestedName `Set.member` seen
]
replacedDecl = replaceNames suggestedNames originalDecl
shorten :: LHsDecl GhcPs -> LHsDecl GhcPs
shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG _ (L locMatches matches) FromSource) _ _))) =
L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ map shortenMatch matches}})
shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ grhss@(GRHSs _ rhss _) _))) =
L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}})
shorten x = x
shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
shortenMatch (L locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) =
L locMatch match {m_grhss = grhss {grhssGRHSs = map shortenLGRHS rhss}}
shortenMatch x = x
shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) =
L locGRHS (GRHS ttg0 guards (cL locExpr dots))
where
dots :: HsExpr GhcPs
dots = HsLit noExtField (HsString (SourceText "...") (mkFastString "..."))
shortenLGRHS x = x
getNames :: LHsDecl GhcPs -> [String]
getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl)
getConstructorNames :: HsDecl GhcPs -> [String]
getConstructorNames (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ _ cons _))) =
concatMap (map unsafePrettyPrint . getConNames . unLoc) cons
getConstructorNames _ = []
isSym :: String -> Bool
isSym (x:_) = not $ isAlpha x || x `elem` "_'"
isSym _ = False
suggestName :: String -> Maybe String
suggestName original
| isSym original || good || not (any isLower original) || any isDigit original ||
any (`isPrefixOf` original) ["prop_","case_","unit_","test_","spec_","scprop_","hprop_"] = Nothing
| otherwise = Just $ f original
where
good = all isAlphaNum $ drp '_' $ drp '#' $ filter (/= '\'') $ reverse $ drp '_' original
drp x = dropWhile (== x)
f xs = us ++ g ys
where (us,ys) = span (== '_') xs
g x | x `elem` ["_","'","_'"] = x
g (a:x:xs) | a `elem` "_'" && isAlphaNum x = toUpper x : g xs
g (x:xs) | isAlphaNum x = x : g xs
| otherwise = g xs
g [] = []
replaceNames :: Data a => [(String, String)] -> a -> a
replaceNames rep = transformBi replace
where
replace :: OccName -> OccName
replace (unsafePrettyPrint -> name) = mkOccName srcDataName $ fromMaybe name $ lookup name rep
hlint-3.1.6/src/Hint/Monad.hs 0000644 0000000 0000000 00000030407 13671470061 014121 0 ustar 00 0000000 0000000 {-# LANGUAGE LambdaCase, ViewPatterns, PatternGuards, FlexibleContexts #-}
{-
Find and match:
mapM, foldM, forM, replicateM, sequence, zipWithM
not at the last line of a do statement, or to the left of >>
Use let x = y instead of x <- return y, unless x is contained
within y, or bound more than once in that do block.
yes = do mapM print a; return b -- mapM_ print a
yes = do _ <- mapM print a; return b -- mapM_ print a
no = mapM print a
no = do foo ; mapM print a
yes = do (bar+foo) --
no = do bar ; foo
yes = do bar; a <- foo; return a -- do bar; foo
no = do bar; a <- foo; return b
yes = do x <- bar; x -- do join bar
no = do x <- bar; x; x
yes = do x <- bar; return (f x) -- do f <$> bar
yes = do x <- bar; return $ f x -- do f <$> bar
yes = do x <- bar; pure $ f x -- do f <$> bar
yes = do x <- bar; return $ f (g x) -- do f . g <$> bar
yes = do x <- bar; return (f $ g x) -- do f . g <$> bar
yes = do x <- bar $ baz; return (f $ g x)
no = do x <- bar; return (f x x)
{-# LANGUAGE RecursiveDo #-}; no = mdo hook <- mkTrigger pat (act >> rmHook hook) ; return hook
yes = do x <- return y; foo x -- @Suggestion let x = y
yes = do x <- return $ y + z; foo x -- let x = y + z
no = do x <- return x; foo x
no = do x <- return y; x <- return y; foo x
yes = do forM files $ \x -> return (); return () -- forM_ files $ \x -> return ()
yes = do if a then forM x y else return (); return 12 -- forM_ x y
yes = do case a of {_ -> forM x y; x:xs -> foo xs}; return () -- forM_ x y
foldM_ f a xs = foldM f a xs >> return ()
folder f a xs = foldM f a xs >> return () -- foldM_ f a xs
folder f a xs = foldM f a xs >>= \_ -> return () -- foldM_ f a xs
yes = mapM async ds >>= mapM wait >> return () -- mapM async ds >>= mapM_ wait
main = "wait" ~> do f a $ sleep 10
{-# LANGUAGE BlockArguments #-}; main = print do 17 + 25
{-# LANGUAGE BlockArguments #-}; main = print do 17 --
main = f $ do g a $ sleep 10 --
main = do f a $ sleep 10 -- @Ignore
main = do foo x; return 3; bar z -- do foo x; bar z
main = void $ forM_ f xs -- forM_ f xs
main = void $ forM f xs -- void $ forM_ f xs
main = do _ <- forM_ f xs; bar -- forM_ f xs
main = do bar; forM_ f xs; return () -- do bar; forM_ f xs
main = do a; when b c; return () -- do a; when b c
bar = 1 * do {\x -> x+x} + y
issue978 = do \
print "x" \
if False then main else do \
return ()
-}
module Hint.Monad(monadHint) where
import Hint.Type(DeclHint,Idea(..),Severity(..),ideaNote,warn,ideaRemove,toSS,suggest,Note(Note))
import GHC.Hs
import SrcLoc
import BasicTypes
import TcEvidence
import RdrName
import OccName
import Bag
import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import GHC.Util
import Data.Generics.Uniplate.DataOnly
import Data.Tuple.Extra
import Data.Maybe
import Data.List.Extra
import Refact.Types hiding (Match)
import qualified Refact.Types as R
badFuncs :: [String]
badFuncs = ["mapM","foldM","forM","replicateM","sequence","zipWithM","traverse","for","sequenceA"]
unitFuncs :: [String]
unitFuncs = ["when","unless","void"]
monadHint :: DeclHint
monadHint _ _ d = concatMap (f Nothing Nothing) $ childrenBi d
where
decl = declName d
f parentDo parentExpr x =
monadExp decl parentDo parentExpr x ++
concat [f (if isHsDo x then Just x else parentDo) (Just (i, x)) c | (i, c) <- zipFrom 0 $ children x]
isHsDo (L _ HsDo{}) = True
isHsDo _ = False
-- | Call with the name of the declaration,
-- the nearest enclosing `do` expression
-- the nearest enclosing expression
-- the expression of interest
monadExp :: Maybe String -> Maybe (LHsExpr GhcPs) -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
monadExp decl parentDo parentExpr x =
case x of
(view -> App2 op x1 x2) | isTag ">>" op -> f x1
(view -> App2 op x1 (view -> LamConst1 _)) | isTag ">>=" op -> f x1
(L l (HsApp _ op x)) | isTag "void" op -> seenVoid (cL l . HsApp noExtField op) x
(L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (cL l . OpApp noExtField op dol) x
(L loc (HsDo _ ctx (L loc2 [L loc3 (BodyStmt _ y _ _ )]))) ->
let doOrMDo = case ctx of MDoExpr -> "mdo"; _ -> "do"
in [ ideaRemove Ignore ("Redundant " ++ doOrMDo) (doSpan doOrMDo loc) doOrMDo [Replace Expr (toSS x) [("y", toSS y)] "y"]
| not $ doAsBrackets parentExpr y
, not $ doAsAvoidingIndentation parentDo x
]
(L loc (HsDo _ DoExpr (L _ xs))) ->
monadSteps (cL loc . HsDo noExtField DoExpr . noLoc) xs ++
[suggest "Use let" from to [r] | (from, to, r) <- monadLet xs] ++
concat [f x | (L _ (BodyStmt _ x _ _)) <- dropEnd1 xs] ++
concat [f x | (L _ (BindStmt _ (LL _ WildPat{}) x _ _)) <- dropEnd1 xs]
_ -> []
where
f = monadNoResult (fromMaybe "" decl) id
seenVoid wrap x = monadNoResult (fromMaybe "" decl) wrap x ++ [warn "Redundant void" (wrap x) x [] | returnsUnit x]
doSpan doOrMDo = \case
UnhelpfulSpan s -> UnhelpfulSpan s
RealSrcSpan s ->
let start = realSrcSpanStart s
end = mkRealSrcLoc (srcSpanFile s) (srcLocLine start) (srcLocCol start + length doOrMDo)
in RealSrcSpan (mkRealSrcSpan start end)
-- Sometimes people write 'a * do a + b', to avoid brackets,
-- or using BlockArguments they can write 'a do a b',
-- or using indentation a * do {\b -> c} * d
-- Return True if they are using do as brackets
doAsBrackets :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool
doAsBrackets (Just (2, L _ (OpApp _ _ op _ ))) _ | isDol op = False -- not quite atomic, but close enough
doAsBrackets (Just (i, o)) x = needBracket i o x
doAsBrackets Nothing x = False
-- Sometimes people write do, to avoid identation, see
-- https://github.com/ndmitchell/hlint/issues/978
-- Return True if they are using do as avoiding identation
doAsAvoidingIndentation :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool
doAsAvoidingIndentation (Just (L _ (HsDo _ _ (L (RealSrcSpan a) _)))) (L _ (HsDo _ _ (L (RealSrcSpan b) _)))
= srcSpanStartCol a == srcSpanStartCol b
doAsAvoidingIndentation parent self = False
returnsUnit :: LHsExpr GhcPs -> Bool
returnsUnit (L _ (HsPar _ x)) = returnsUnit x
returnsUnit (L _ (HsApp _ x _)) = returnsUnit x
returnsUnit (L _ (OpApp _ x op _)) | isDol op = returnsUnit x
returnsUnit (L _ (HsVar _ (L _ x))) = occNameStr x `elem` map (++ "_") badFuncs ++ unitFuncs
returnsUnit _ = False
-- See through HsPar, and down HsIf/HsCase, return the name to use in
-- the hint, and the revised expression.
monadNoResult :: String -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
monadNoResult inside wrap (L l (HsPar _ x)) = monadNoResult inside (wrap . cL l . HsPar noExtField) x
monadNoResult inside wrap (L l (HsApp _ x y)) = monadNoResult inside (\x -> wrap $ cL l (HsApp noExtField x y)) x
monadNoResult inside wrap (L l (OpApp _ x tag@(L _ (HsVar _ (L _ op))) y))
| isDol tag = monadNoResult inside (\x -> wrap $ cL l (OpApp noExtField x tag y)) x
| occNameStr op == ">>=" = monadNoResult inside (wrap . cL l . OpApp noExtField x tag) y
monadNoResult inside wrap x
| x2 : _ <- filter (`isTag` x) badFuncs
, let x3 = x2 ++ "_"
= [warn ("Use " ++ x3) (wrap x) (wrap $ strToVar x3) [Replace Expr (toSS x) [] x3] | inside /= x3]
monadNoResult inside wrap (replaceBranches -> (bs, rewrap)) =
map (\x -> x{ideaNote=nubOrd $ Note "May require adding void to other branches" : ideaNote x}) $ concat
[monadNoResult inside id b | b <- bs]
monadStep :: ([ExprLStmt GhcPs] -> LHsExpr GhcPs)
-> [ExprLStmt GhcPs] -> [Idea]
-- Rewrite 'do return x; $2' as 'do $2'.
monadStep wrap os@(o@(L _ (BodyStmt _ (fromRet -> Just (ret, _)) _ _ )) : xs@(_:_))
= [warn ("Redundant " ++ ret) (wrap os) (wrap xs) [Delete Stmt (toSS o)]]
-- Rewrite 'do a <- $1; return a' as 'do $1'.
monadStep wrap o@[ g@(L _ (BindStmt _ (LL _ (VarPat _ (L _ p))) x _ _ ))
, q@(L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ v)))) _ _))]
| occNameStr p == occNameStr v
= [warn ("Redundant " ++ ret) (wrap o) (wrap [noLoc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr])
[Replace Stmt (toSS g) [("x", toSS x)] "x", Delete Stmt (toSS q)]]
-- Suggest to use join. Rewrite 'do x <- $1; x; $2' as 'do join $1; $2'.
monadStep wrap o@(g@(L _ (BindStmt _ (view -> PVar_ p) x _ _)):q@(L _ (BodyStmt _ (view -> Var_ v) _ _)):xs)
| p == v && v `notElem` varss xs
= let app = noLoc $ HsApp noExtField (strToVar "join") x
body = noLoc $ BodyStmt noExtField (rebracket1 app) noSyntaxExpr noSyntaxExpr
stmts = body : xs
in [warn "Use join" (wrap o) (wrap stmts) r]
where r = [Replace Stmt (toSS g) [("x", toSS x)] "join x", Delete Stmt (toSS q)]
-- Redundant variable capture. Rewrite 'do _ <- ; $1' as
-- 'do ; $1'.
monadStep wrap (o@(L loc (BindStmt _ p x _ _)) : rest)
| isPWildcard p, returnsUnit x
= let body = cL loc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr :: ExprLStmt GhcPs
in [warn "Redundant variable capture" o body []]
-- Redundant unit return : 'do ; return ()'.
monadStep
wrap o@[ L _ (BodyStmt _ x _ _)
, L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ unit)))) _ _)]
| returnsUnit x, occNameStr unit == "()"
= [warn ("Redundant " ++ ret) (wrap o) (wrap $ take 1 o) []]
-- Rewrite 'do x <- $1; return $ f $ g x' as 'f . g <$> x'
monadStep wrap
o@[g@(L _ (BindStmt _ (view -> PVar_ u) x _ _))
, q@(L _ (BodyStmt _ (fromApplies -> (ret:f:fs, view -> Var_ v)) _ _))]
| isReturn ret, notDol x, u == v, length fs < 3, all isSimple (f : fs), v `notElem` vars (f : fs)
=
[warn "Use <$>" (wrap o) (wrap [noLoc $ BodyStmt noExtField (noLoc $ OpApp noExtField (foldl' (\acc e -> noLoc $ OpApp noExtField acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr])
[Replace Stmt (toSS g) (("x", toSS x):zip vs (toSS <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSS q)]]
where
isSimple (fromApps -> xs) = all isAtom (x : xs)
vs = ('f':) . show <$> [0..]
notDol :: LHsExpr GhcPs -> Bool
notDol (L _ (OpApp _ _ op _)) = not $ isDol op
notDol _ = True
monadStep _ _ = []
-- Suggest removing a return
monadSteps :: ([ExprLStmt GhcPs] -> LHsExpr GhcPs) -> [ExprLStmt GhcPs] -> [Idea]
monadSteps wrap (x : xs) = monadStep wrap (x : xs) ++ monadSteps (wrap . (x :)) xs
monadSteps _ _ = []
-- | Rewrite 'do ...; x <- return y; ...' as 'do ...; let x = y; ...'.
monadLet :: [ExprLStmt GhcPs] -> [(ExprLStmt GhcPs, ExprLStmt GhcPs, Refactoring R.SrcSpan)]
monadLet xs = mapMaybe mkLet xs
where
vs = concatMap pvars [p | (L _ (BindStmt _ p _ _ _)) <- xs]
mkLet :: ExprLStmt GhcPs -> Maybe (ExprLStmt GhcPs, ExprLStmt GhcPs, Refactoring R.SrcSpan)
mkLet x@(L _ (BindStmt _ v@(view -> PVar_ p) (fromRet -> Just (_, y)) _ _ ))
| p `notElem` vars y, p `notElem` delete p vs
= Just (x, template p y, refact)
where
refact = Replace Stmt (toSS x) [("lhs", toSS v), ("rhs", toSS y)]
(unsafePrettyPrint $ template "lhs" (strToVar "rhs"))
mkLet _ = Nothing
template :: String -> LHsExpr GhcPs -> ExprLStmt GhcPs
template lhs rhs =
let p = noLoc $ mkRdrUnqual (mkVarOcc lhs)
grhs = noLoc (GRHS noExtField [] rhs)
grhss = GRHSs noExtField [grhs] (noLoc (EmptyLocalBinds noExtField))
match = noLoc $ Match noExtField (FunRhs p Prefix NoSrcStrict) [] grhss
fb = noLoc $ FunBind noExtField p (MG noExtField (noLoc [match]) Generated) WpHole []
binds = unitBag fb
valBinds = ValBinds noExtField binds []
localBinds = noLoc $ HsValBinds noExtField valBinds
in noLoc $ LetStmt noExtField localBinds
fromApplies :: LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs)
fromApplies (L _ (HsApp _ f x)) = first (f:) $ fromApplies (fromParen x)
fromApplies (L _ (OpApp _ f (isDol -> True) x)) = first (f:) $ fromApplies x
fromApplies x = ([], x)
fromRet :: LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs)
fromRet (L _ (HsPar _ x)) = fromRet x
fromRet (L _ (OpApp _ x (L _ (HsVar _ (L _ y))) z)) | occNameStr y == "$" = fromRet $ noLoc (HsApp noExtField x z)
fromRet (L _ (HsApp _ x y)) | isReturn x = Just (unsafePrettyPrint x, y)
fromRet _ = Nothing
hlint-3.1.6/src/Hint/Match.hs 0000644 0000000 0000000 00000026762 13674736420 014137 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts #-}
{-
The matching does a fairly simple unification between the two terms, treating
any single letter variable on the left as a free variable. After the matching
we substitute, transform and check the side conditions. We also "see through"
both ($) and (.) functions on the right.
TRANSFORM PATTERNS
_noParen_ - don't bracket this particular item
SIDE CONDITIONS
(&&), (||), not - boolean connectives
isAtom x - does x never need brackets
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
noTypeCheck, noQuickCheck - no semantics, a hint for testing only
($) AND (.)
We see through ($)/(.) by expanding it if nothing else matches.
We also see through (.) by translating rules that have (.) equivalents
to separate rules. For example:
concat (map f x) ==> concatMap f x
-- we spot both these rules can eta reduce with respect to x
concat . map f ==> concatMap f
-- we use the associativity of (.) to add
concat . map f . x ==> concatMap f . x
-- currently 36 of 169 rules have (.) equivalents
We see through (.) if the RHS is dull using id, e.g.
not (not x) ==> x
not . not ==> id
not . not . x ==> x
-}
module Hint.Match(readMatch) where
import Hint.Type (ModuleEx,Idea,idea,ideaNote,toSS)
import Util
import Timing
import qualified Data.Set as Set
import qualified Refact.Types as R
import Control.Monad
import Data.Tuple.Extra
import Data.Maybe
import Config.Type
import Data.Generics.Uniplate.DataOnly
import Bag
import GHC.Hs
import SrcLoc
import BasicTypes
import RdrName
import OccName
import Data.Data
import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
readMatch :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]
readMatch settings = findIdeas (concatMap readRule settings)
readRule :: HintRule -> [HintRule]
readRule m@HintRule{ hintRuleLHS=(stripLocs . unextendInstances -> hintRuleLHS)
, hintRuleRHS=(stripLocs . unextendInstances -> hintRuleRHS)
, hintRuleSide=((stripLocs . unextendInstances <$>) -> hintRuleSide)
} =
(:) m{ hintRuleLHS=extendInstances hintRuleLHS
, hintRuleRHS=extendInstances hintRuleRHS
, hintRuleSide=extendInstances <$> hintRuleSide } $ do
(l, v1) <- dotVersion hintRuleLHS
(r, v2) <- dotVersion hintRuleRHS
guard $ v1 == v2 && not (null l) && (length l > 1 || length r > 1) && Set.notMember v1 (Set.map occNameString (freeVars $ maybeToList hintRuleSide ++ l ++ r))
if not (null r) then
[ m{ hintRuleLHS=extendInstances (dotApps l), hintRuleRHS=extendInstances (dotApps r), hintRuleSide=extendInstances <$> hintRuleSide }
, m{ hintRuleLHS=extendInstances (dotApps (l ++ [strToVar v1])), hintRuleRHS=extendInstances (dotApps (r ++ [strToVar v1])), hintRuleSide=extendInstances <$> hintRuleSide } ]
else if length l > 1 then
[ m{ hintRuleLHS=extendInstances (dotApps l), hintRuleRHS=extendInstances (strToVar "id"), hintRuleSide=extendInstances <$> hintRuleSide }
, m{ hintRuleLHS=extendInstances (dotApps (l++[strToVar v1])), hintRuleRHS=extendInstances (strToVar v1), hintRuleSide=extendInstances <$> hintRuleSide}]
else []
-- Find a dot version of this rule, return the sequence of app
-- prefixes, and the var.
dotVersion :: LHsExpr GhcPs -> [([LHsExpr GhcPs], String)]
dotVersion (view -> Var_ v) | isUnifyVar v = [([], v)]
dotVersion (L _ (HsApp _ ls rs)) = first (ls :) <$> dotVersion (fromParen rs)
dotVersion (L l (OpApp _ x op y)) =
-- In a GHC parse tree, raw sections aren't valid application terms.
-- To be suitable as application terms, they must be enclosed in
-- parentheses.
-- If a == b then
-- x is 'a', op is '==' and y is 'b' and,
let lSec = addParen (cL l (SectionL noExtField x op)) -- (a == )
rSec = addParen (cL l (SectionR noExtField op y)) -- ( == b)
in (first (lSec :) <$> dotVersion y) ++ (first (rSec :) <$> dotVersion x) -- [([(a ==)], b), ([(b == )], a])].
dotVersion _ = []
---------------------------------------------------------------------
-- PERFORM THE MATCHING
findIdeas :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]
findIdeas matches s _ decl = timed "Hint" "Match apply" $ forceList
[ (idea (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}
| (name, expr) <- findDecls decl
, (parent,x) <- universeParentExp expr
, m <- matches, Just (y, tpl, notes, subst) <- [matchIdea s name m parent x]
, let r = R.Replace R.Expr (toSS x) subst (unsafePrettyPrint tpl)
]
-- | A list of root expressions, with their associated names
findDecls :: LHsDecl GhcPs -> [(String, LHsExpr GhcPs)]
findDecls x@(L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =
[(fromMaybe "" $ bindName xs, x) | xs <- bagToList cid_binds, x <- childrenBi xs]
findDecls (L _ RuleD{}) = [] -- Often rules contain things that HLint would rewrite.
findDecls x = map (fromMaybe "" $ declName x,) $ childrenBi x
matchIdea :: Scope
-> String
-> HintRule
-> Maybe (Int, LHsExpr GhcPs)
-> LHsExpr GhcPs
-> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, [Note], [(String, R.SrcSpan)])
matchIdea sb declName HintRule{..} parent x = do
let lhs = unextendInstances hintRuleLHS
rhs = unextendInstances hintRuleRHS
sa = hintRuleScope
nm a b = scopeMatch (sa, a) (sb, b)
(u, extra) <- unifyExp nm True lhs x
u <- validSubst astEq u
-- Need to check free vars before unqualification, but after subst
-- (with 'e') need to unqualify before substitution (with 'res').
let rhs' | Just fun <- extra = rebracket1 $ noLoc (HsApp noExtField fun rhs)
| otherwise = rhs
(e, tpl) = substitute u rhs'
noParens = [varToStr $ fromParen x | L _ (HsApp _ (varToStr -> "_noParen_") x) <- universe tpl]
u <- pure (removeParens noParens u)
let res = addBracketTy (addBracket parent $ performSpecial $ fst $ substitute u $ unqualify sa sb rhs')
guard $ (freeVars e Set.\\ Set.filter (not . isUnifyVar . occNameString) (freeVars rhs')) `Set.isSubsetOf` freeVars x
-- Check no unexpected new free variables.
-- Check it isn't going to get broken by QuasiQuotes as per #483. If
-- we have lambdas we might be moving, and QuasiQuotes, we might
-- inadvertantly break free vars because quasi quotes don't show
-- what free vars they make use of.
guard $ not (any isLambda $ universe lhs) || not (any isQuasiQuote $ universe x)
guard $ checkSide (unextendInstances <$> hintRuleSide) $ ("original", x) : ("result", res) : fromSubst u
guard $ checkDefine declName parent rhs
(u, tpl) <- pure $ if any ((== noSrcSpan) . getLoc . snd) (fromSubst u) then (mempty, res) else (u, tpl)
tpl <- pure $ unqualify sa sb (performSpecial tpl)
pure (res, tpl, hintRuleNotes, [(s, toSS pos) | (s, pos) <- fromSubst u, getLoc pos /= noSrcSpan])
---------------------------------------------------------------------
-- SIDE CONDITIONS
checkSide :: Maybe (LHsExpr GhcPs) -> [(String, LHsExpr GhcPs)] -> Bool
checkSide x bind = maybe True bool x
where
bool :: LHsExpr GhcPs -> Bool
bool (L _ (OpApp _ x op y))
| varToStr op == "&&" = bool x && bool y
| varToStr op == "||" = bool x || bool y
| varToStr op == "==" = expr (fromParen1 x) `astEq` expr (fromParen1 y)
bool (L _ (HsApp _ x y)) | varToStr x == "not" = not $ bool y
bool (L _ (HsPar _ x)) = bool x
bool (L _ (HsApp _ cond (sub -> y)))
| 'i' : 's' : typ <- varToStr cond = isType typ y
bool (L _ (HsApp _ (L _ (HsApp _ cond (sub -> x))) (sub -> y)))
| varToStr cond == "notIn" = and [extendInstances (stripLocs x) `notElem` map (extendInstances . stripLocs) (universe y) | x <- list x, y <- list y]
| varToStr cond == "notEq" = not (x `astEq` y)
bool x | varToStr x == "noTypeCheck" = True
bool x | varToStr x == "noQuickCheck" = True
bool x = error $ "Hint.Match.checkSide, unknown side condition: " ++ unsafePrettyPrint x
expr :: LHsExpr GhcPs -> LHsExpr GhcPs
expr (L _ (HsApp _ (varToStr -> "subst") x)) = sub $ fromParen1 x
expr x = x
isType "Compare" x = True -- Just a hint for proof stuff
isType "Atom" x = isAtom x
isType "WHNF" x = isWHNF x
isType "Wildcard" x = any isFieldPun (universeBi x) || any hasFieldsDotDot (universeBi x)
isType "Nat" (asInt -> Just x) | x >= 0 = True
isType "Pos" (asInt -> Just x) | x > 0 = True
isType "Neg" (asInt -> Just x) | x < 0 = True
isType "NegZero" (asInt -> Just x) | x <= 0 = True
isType "LitInt" (L _ (HsLit _ HsInt{})) = True
isType "LitInt" (L _ (HsOverLit _ (OverLit _ HsIntegral{} _))) = True
isType "LitString" (L _ (HsLit _ HsString{})) = True
isType "Var" (L _ HsVar{}) = True
isType "App" (L _ HsApp{}) = True
isType "InfixApp" (L _ x@OpApp{}) = True
isType "Paren" (L _ x@HsPar{}) = True
isType "Tuple" (L _ ExplicitTuple{}) = True
isType typ (L _ x) =
let top = showConstr (toConstr x) in
typ == top
asInt :: LHsExpr GhcPs -> Maybe Integer
asInt (L _ (HsPar _ x)) = asInt x
asInt (L _ (NegApp _ x _)) = negate <$> asInt x
asInt (L _ (HsLit _ (HsInt _ (IL _ neg x)) )) = Just $ if neg then -x else x
asInt (L _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ neg x)) _))) = Just $ if neg then -x else x
asInt _ = Nothing
list :: LHsExpr GhcPs -> [LHsExpr GhcPs]
list (L _ (ExplicitList _ _ xs)) = xs
list x = [x]
sub :: LHsExpr GhcPs -> LHsExpr GhcPs
sub = transform f
where f (view -> Var_ x) | Just y <- lookup x bind = y
f x = x
-- Does the result look very much like the declaration?
checkDefine :: String -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool
checkDefine declName Nothing y =
let funOrOp expr = case expr of
L _ (HsApp _ fun _) -> funOrOp fun
L _ (OpApp _ _ op _) -> funOrOp op
other -> other
in declName /= varToStr (transformBi unqual $ funOrOp y)
checkDefine _ _ _ = True
---------------------------------------------------------------------
-- TRANSFORMATION
-- If it has '_noParen_', remove the brackets (if exist).
performSpecial :: LHsExpr GhcPs -> LHsExpr GhcPs
performSpecial = transform fNoParen
where
fNoParen :: LHsExpr GhcPs -> LHsExpr GhcPs
fNoParen (L _ (HsApp _ e x)) | varToStr e == "_noParen_" = fromParen x
fNoParen x = x
-- Contract : 'Data.List.foo' => 'foo' if 'Data.List' is loaded.
unqualify :: Scope -> Scope -> LHsExpr GhcPs -> LHsExpr GhcPs
unqualify from to = transformBi f
where
f :: Located RdrName -> Located RdrName
f x@(L _ (Unqual s)) | isUnifyVar (occNameString s) = x
f x = scopeMove (from, x) to
addBracket :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
addBracket (Just (i, p)) c | needBracketOld i p c = noLoc $ HsPar noExtField c
addBracket _ x = x
-- Type substitution e.g. 'Foo Int' for 'a' in 'Proxy a' can lead to a
-- need to bracket type applications in This doesn't come up in HSE
-- because the pretty printer inserts them.
addBracketTy :: LHsExpr GhcPs -> LHsExpr GhcPs
addBracketTy= transformBi f
where
f :: LHsType GhcPs -> LHsType GhcPs
f (L _ (HsAppTy _ t x@(L _ HsAppTy{}))) =
noLoc (HsAppTy noExtField t (noLoc (HsParTy noExtField x)))
f x = x
hlint-3.1.6/src/Hint/ListRec.hs 0000644 0000000 0000000 00000021050 13671470061 014422 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-
map f [] = []
map f (x:xs) = f x : map f xs
foldr f z [] = z
foldr f z (x:xs) = f x (foldr f z xs)
foldl f z [] = z
foldl f z (x:xs) = foldl f (f z x) xs
-}
{-
f (x:xs) = negate x + f xs ; f [] = 0 -- f xs = foldr ((+) . negate) 0 xs
f (x:xs) = x + 1 : f xs ; f [] = [] -- f xs = map (+ 1) xs
f z (x:xs) = f (z*x) xs ; f z [] = z -- f z xs = foldl (*) z xs
f a (x:xs) b = x + a + b : f a xs b ; f a [] b = [] -- f a xs b = map (\ x -> x + a + b) xs
f [] a = return a ; f (x:xs) a = a + x >>= \fax -> f xs fax -- f xs a = foldM (+) a xs
f (x:xs) a = a + x >>= \fax -> f xs fax ; f [] a = pure a -- f xs a = foldM (+) a xs
foos [] x = x; foos (y:ys) x = foo y $ foos ys x -- foos ys x = foldr foo x ys
f [] y = y; f (x:xs) y = f xs $ g x y -- f xs y = foldl (flip g) y xs
f [] y = y; f (x : xs) y = let z = g x y in f xs z -- f xs y = foldl (flip g) y xs
f [] y = y; f (x:xs) y = f xs (f xs z)
fun [] = []; fun (x:xs) = f x xs ++ fun xs
-}
module Hint.ListRec(listRecHint) where
import Hint.Type (DeclHint, Severity(Suggestion, Warning), idea, toSS)
import Data.Generics.Uniplate.DataOnly
import Data.List.Extra
import Data.Maybe
import Data.Either.Extra
import Control.Monad
import Refact.Types hiding (RType(Match))
import SrcLoc
import GHC.Hs.Extension
import GHC.Hs.Pat
import GHC.Hs.Types
import TysWiredIn
import RdrName
import GHC.Hs.Binds
import GHC.Hs.Expr
import GHC.Hs.Decls
import BasicTypes
import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
listRecHint :: DeclHint
listRecHint _ _ = concatMap f . universe
where
f o = maybeToList $ do
let x = o
(x, addCase) <- findCase x
(use,severity,x) <- matchListRec x
let y = addCase x
guard $ recursiveStr `notElem` varss y
-- Maybe we can do better here maintaining source
-- formatting?
pure $ idea severity ("Use " ++ use) o y [Replace Decl (toSS o) [] (unsafePrettyPrint y)]
recursiveStr :: String
recursiveStr = "_recursive_"
recursive = strToVar recursiveStr
data ListCase =
ListCase
[String] -- recursion parameters
(LHsExpr GhcPs) -- nil case
(String, String, LHsExpr GhcPs) -- cons case
-- For cons-case delete any recursive calls with 'xs' in them. Any
-- recursive calls are marked "_recursive_".
data BList = BNil | BCons String String
deriving (Eq, Ord, Show)
data Branch =
Branch
String -- function name
[String] -- parameters
Int -- list position
BList (LHsExpr GhcPs) -- list type/body
---------------------------------------------------------------------
-- MATCH THE RECURSION
matchListRec :: ListCase -> Maybe (String, Severity, LHsExpr GhcPs)
matchListRec o@(ListCase vs nil (x, xs, cons))
-- Suggest 'map'?
| [] <- vs, varToStr nil == "[]", (L _ (OpApp _ lhs c rhs)) <- cons, varToStr c == ":"
, astEq (fromParen rhs) recursive, xs `notElem` vars lhs
= Just $ (,,) "map" Hint.Type.Warning $
appsBracket [ strToVar "map", niceLambda [x] lhs, strToVar xs]
-- Suggest 'foldr'?
| [] <- vs, App2 op lhs rhs <- view cons
, xs `notElem` (vars op ++ vars lhs) -- the meaning of xs changes, see #793
, astEq (fromParen rhs) recursive
= Just $ (,,) "foldr" Suggestion $
appsBracket [ strToVar "foldr", niceLambda [x] $ appsBracket [op,lhs], nil, strToVar xs]
-- Suggest 'foldl'?
| [v] <- vs, view nil == Var_ v, (L _ (HsApp _ r lhs)) <- cons
, astEq (fromParen r) recursive
, xs `notElem` vars lhs
= Just $ (,,) "foldl" Suggestion $
appsBracket [ strToVar "foldl", niceLambda [v,x] lhs, strToVar v, strToVar xs]
-- Suggest 'foldM'?
| [v] <- vs, (L _ (HsApp _ ret res)) <- nil, isReturn ret, varToStr res == "()" || view res == Var_ v
, [L _ (BindStmt _ (view -> PVar_ b1) e _ _), L _ (BodyStmt _ (fromParen -> (L _ (HsApp _ r (view -> Var_ b2)))) _ _)] <- asDo cons
, b1 == b2, astEq r recursive, xs `notElem` vars e
, name <- "foldM" ++ ['_' | varToStr res == "()"]
= Just $ (,,) name Suggestion $
appsBracket [strToVar name, niceLambda [v,x] e, strToVar v, strToVar xs]
-- Nope, I got nothing ¯\_(ツ)_/¯.
| otherwise = Nothing
-- Very limited attempt to convert >>= to do, only useful for
-- 'foldM' / 'foldM_'.
asDo :: LHsExpr GhcPs -> [LStmt GhcPs (LHsExpr GhcPs)]
asDo (view ->
App2 bind lhs
(L _ (HsLam _ MG {
mg_origin=FromSource
, mg_alts=L _ [
L _ Match { m_ctxt=LambdaExpr
, m_pats=[v@(L _ VarPat{})]
, m_grhss=GRHSs _
[L _ (GRHS _ [] rhs)]
(L _ (EmptyLocalBinds _))}]}))
) =
[ noLoc $ BindStmt noExtField v lhs noSyntaxExpr noSyntaxExpr
, noLoc $ BodyStmt noExtField rhs noSyntaxExpr noSyntaxExpr ]
asDo (L _ (HsDo _ DoExpr (L _ stmts))) = stmts
asDo x = [noLoc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr]
---------------------------------------------------------------------
-- FIND THE CASE ANALYSIS
findCase :: LHsDecl GhcPs -> Maybe (ListCase, LHsExpr GhcPs -> LHsDecl GhcPs)
findCase x = do
-- Match a function binding with two alternatives.
(L _ (ValD _ FunBind {fun_matches=
MG{mg_origin=FromSource, mg_alts=
(L _
[ x1@(L _ Match{..}) -- Match fields.
, x2]), ..} -- Match group fields.
, ..} -- Fun. bind fields.
)) <- pure x
Branch name1 ps1 p1 c1 b1 <- findBranch x1
Branch name2 ps2 p2 c2 b2 <- findBranch x2
guard (name1 == name2 && ps1 == ps2 && p1 == p2)
[(BNil, b1), (BCons x xs, b2)] <- pure $ sortOn fst [(c1, b1), (c2, b2)]
b2 <- transformAppsM (delCons name1 p1 xs) b2
(ps, b2) <- pure $ eliminateArgs ps1 b2
let ps12 = let (a, b) = splitAt p1 ps1 in map strToPat (a ++ xs : b) -- Function arguments.
emptyLocalBinds = noLoc $ EmptyLocalBinds noExtField -- Empty where clause.
gRHS e = noLoc $ GRHS noExtField [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.
gRHSSs e = GRHSs noExtField [gRHS e] emptyLocalBinds -- Guarded rhs set.
match e = Match{m_ext=noExtField,m_pats=ps12, m_grhss=gRHSSs e, ..} -- Match.
matchGroup e = MG{mg_alts=noLoc [noLoc $ match e], mg_origin=Generated, ..} -- Match group.
funBind e = FunBind {fun_matches=matchGroup e, ..} :: HsBindLR GhcPs GhcPs -- Fun bind.
pure (ListCase ps b1 (x, xs, b2), noLoc . ValD noExtField . funBind)
delCons :: String -> Int -> String -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
delCons func pos var (fromApps -> (view -> Var_ x) : xs) | func == x = do
(pre, (view -> Var_ v) : post) <- pure $ splitAt pos xs
guard $ v == var
pure $ apps $ recursive : pre ++ post
delCons _ _ _ x = pure x
eliminateArgs :: [String] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs)
eliminateArgs ps cons = (remove ps, transform f cons)
where
args = [zs | z : zs <- map fromApps $ universeApps cons, astEq z recursive]
elim = [all (\xs -> length xs > i && view (xs !! i) == Var_ p) args | (i, p) <- zipFrom 0 ps] ++ repeat False
remove = concat . zipWith (\b x -> [x | not b]) elim
f (fromApps -> x : xs) | astEq x recursive = apps $ x : remove xs
f x = x
---------------------------------------------------------------------
-- FIND A BRANCH
findBranch :: LMatch GhcPs (LHsExpr GhcPs) -> Maybe Branch
findBranch (L _ x) = do
Match { m_ctxt = FunRhs {mc_fun=(L _ name)}
, m_pats = ps
, m_grhss =
GRHSs {grhssGRHSs=[L l (GRHS _ [] body)]
, grhssLocalBinds=L _ (EmptyLocalBinds _)
}
} <- pure x
(a, b, c) <- findPat ps
pure $ Branch (occNameStr name) a b c $ simplifyExp body
findPat :: [LPat GhcPs] -> Maybe ([String], Int, BList)
findPat ps = do
ps <- mapM readPat ps
[i] <- pure $ findIndices isRight ps
let (left, [right]) = partitionEithers ps
pure (left, i, right)
readPat :: LPat GhcPs -> Maybe (Either String BList)
readPat (view -> PVar_ x) = Just $ Left x
readPat (L _ (ParPat _ (L _ (ConPatIn (L _ n) (InfixCon (view -> PVar_ x) (view -> PVar_ xs))))))
| n == consDataCon_RDR = Just $ Right $ BCons x xs
readPat (L _ (ConPatIn (L _ n) (PrefixCon [])))
| n == nameRdrName nilDataConName = Just $ Right BNil
readPat _ = Nothing
hlint-3.1.6/src/Hint/List.hs 0000644 0000000 0000000 00000025344 13671470061 014002 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-}
{-
Find and match:
yes = 1:2:[] -- [1,2]
yes = ['h','e','l','l','o']
yes (1:2:[]) = 1 -- [1,2]
yes ['h','e'] = 1
-- [a]++b -> a : b, but only if not in a chain of ++'s
yes = [x] ++ xs -- x : xs
no = "x" ++ xs
no = [x] ++ xs ++ ys
no = xs ++ [x] ++ ys
yes = [if a then b else c] ++ xs -- (if a then b else c) : xs
yes = [1] : [2] : [3] : [4] : [5] : [] -- [[1], [2], [3], [4], [5]]
yes = if x == e then l2 ++ xs else [x] ++ check_elem xs -- x : check_elem xs
data Yes = Yes (Maybe [Char]) -- Maybe String
yes = y :: [Char] -> a -- String -> a
instance C [Char]
foo = [a b] ++ xs -- a b : xs
foo = [myexpr | True, a] -- [myexpr | a]
foo = [myexpr | False] -- []
foo = map f [x + 1 | x <- [1..10]] -- [f (x + 1) | x <- [1..10]]
foo = [x + 1 | x <- [1..10], feature] -- [x + 1 | feature, x <- [1..10]]
foo = [x + 1 | x <- [1..10], even x]
foo = [x + 1 | x <- [1..10], even x, dont_reoder_guards]
foo = [x + 1 | x <- [1..10], let y = even x, y]
foo = [x + 1 | x <- [1..10], let q = even 1, q] -- [x + 1 | let q = even 1, q, x <- [1..10]]
foo = [fooValue | Foo{..} <- y, fooField]
issue619 = [pkgJobs | Pkg{pkgGpd, pkgJobs} <- pkgs, not $ null $ C.condTestSuites pkgGpd]
{-# LANGUAGE MonadComprehensions #-}\
foo = [x | False, x <- [1 .. 10]] -- []
foo = [_ | x <- _, let _ = A{x}]
issue1039 = foo (map f [1 | _ <- []]) -- [f 1 | _ <- []]
-}
module Hint.List(listHint) where
import Control.Applicative
import Data.Generics.Uniplate.DataOnly
import Data.List.Extra
import Data.Maybe
import Prelude
import Hint.Type(DeclHint,Idea,suggest,ignore,toRefactSrcSpan,toSS)
import Refact.Types hiding (SrcSpan)
import qualified Refact.Types as R
import GHC.Hs
import SrcLoc
import BasicTypes
import RdrName
import Name
import FastString
import TysWiredIn
import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Hs.Types
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
listHint :: DeclHint
listHint _ _ = listDecl
listDecl :: LHsDecl GhcPs -> [Idea]
listDecl x =
concatMap (listExp False) (childrenBi x) ++
stringType x ++
concatMap listPat (childrenBi x) ++
concatMap listComp (universeBi x)
-- Refer to https://github.com/ndmitchell/hlint/issues/775 for the
-- structure of 'listComp'.
listComp :: LHsExpr GhcPs -> [Idea]
listComp o@(L _ (HsDo _ ListComp (L _ stmts))) =
listCompCheckGuards o ListComp stmts
listComp o@(L _ (HsDo _ MonadComp (L _ stmts))) =
listCompCheckGuards o MonadComp stmts
listComp (L _ HsPar{}) = [] -- App2 "sees through" paren, which causes duplicate hints with universeBi
listComp o@(view -> App2 mp f (L _ (HsDo _ ListComp (L _ stmts)))) =
listCompCheckMap o mp f ListComp stmts
listComp o@(view -> App2 mp f (L _ (HsDo _ MonadComp (L _ stmts)))) =
listCompCheckMap o mp f MonadComp stmts
listComp _ = []
listCompCheckGuards :: LHsExpr GhcPs -> HsStmtContext Name -> [ExprLStmt GhcPs] -> [Idea]
listCompCheckGuards o ctx stmts =
let revs = reverse stmts
e@(L _ LastStmt{}) = head revs -- In a ListComp, this is always last.
xs = reverse (tail revs) in
list_comp_aux e xs
where
list_comp_aux e xs
| "False" `elem` cons = [suggest "Short-circuited list comprehension" o o' (suggestExpr o o')]
| "True" `elem` cons = [suggest "Redundant True guards" o o2 (suggestExpr o o2)]
| not (astListEq xs ys) = [suggest "Move guards forward" o o3 (suggestExpr o o3)]
| otherwise = []
where
ys = moveGuardsForward xs
o' = noLoc $ ExplicitList noExtField Nothing []
o2 = noLoc $ HsDo noExtField ctx (noLoc (filter ((/= Just "True") . qualCon) xs ++ [e]))
o3 = noLoc $ HsDo noExtField ctx (noLoc $ ys ++ [e])
cons = mapMaybe qualCon xs
qualCon :: ExprLStmt GhcPs -> Maybe String
qualCon (L _ (BodyStmt _ (L _ (HsVar _ (L _ x))) _ _)) = Just (occNameStr x)
qualCon _ = Nothing
listCompCheckMap ::
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsStmtContext Name -> [ExprLStmt GhcPs] -> [Idea]
listCompCheckMap o mp f ctx stmts | varToStr mp == "map" =
[suggest "Move map inside list comprehension" o o2 (suggestExpr o o2)]
where
revs = reverse stmts
L _ (LastStmt _ body b s) = head revs -- In a ListComp, this is always last.
last = noLoc $ LastStmt noExtField (noLoc $ HsApp noExtField (paren f) (paren body)) b s
o2 =noLoc $ HsDo noExtField ctx (noLoc $ reverse (tail revs) ++ [last])
listCompCheckMap _ _ _ _ _ = []
suggestExpr :: LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring R.SrcSpan]
suggestExpr o o2 = [Replace Expr (toSS o) [] (unsafePrettyPrint o2)]
moveGuardsForward :: [ExprLStmt GhcPs] -> [ExprLStmt GhcPs]
moveGuardsForward = reverse . f [] . reverse
where
f guards (x@(L _ (BindStmt _ p _ _ _)) : xs) = reverse stop ++ x : f move xs
where (move, stop) =
span (if any hasPFieldsDotDot (universeBi x)
|| any isPFieldWildcard (universeBi x)
then const False
else \x ->
let pvs = pvars p in
-- See this code from 'RdrHsSyn.hs' (8.10.1):
-- plus_RDR, pun_RDR :: RdrName
-- plus_RDR = mkUnqual varName (fsLit "+") -- Hack
-- pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
-- Todo (SF, 2020-03-28): Try to make this better somehow.
pvs `disjoint` varss x && "pun-right-hand-side" `notElem` pvs
) guards
f guards (x@(L _ BodyStmt{}):xs) = f (x:guards) xs
f guards (x@(L _ LetStmt{}):xs) = f (x:guards) xs
f guards xs = reverse guards ++ xs
listExp :: Bool -> LHsExpr GhcPs -> [Idea]
listExp b (fromParen -> x) =
if null res then concatMap (listExp $ isAppend x) $ children x else [head res]
where
res = [suggest name x x2 [r]
| (name, f) <- checks
, Just (x2, subts, temp) <- [f b x]
, let r = Replace Expr (toSS x) subts temp ]
listPat :: LPat GhcPs -> [Idea]
listPat x = if null res then concatMap listPat $ children x else [head res]
where res = [suggest name x x2 [r]
| (name, f) <- pchecks
, Just (x2, subts, temp) <- [f x]
, let r = Replace Pattern (toSS x) subts temp ]
isAppend :: View a App2 => a -> Bool
isAppend (view -> App2 op _ _) = varToStr op == "++"
isAppend _ = False
checks ::[(String, Bool -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String))]
checks = let (*) = (,) in drop1 -- see #174
[ "Use string literal" * useString
, "Use list literal" * useList
, "Use :" * useCons
]
pchecks :: [(String, LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String))]
pchecks = let (*) = (,) in drop1 -- see #174
[ "Use string literal pattern" * usePString
, "Use list literal pattern" * usePList
]
usePString :: LPat GhcPs -> Maybe (LPat GhcPs, [a], String)
usePString (L _ (ListPat _ xs)) | not $ null xs, Just s <- mapM fromPChar xs =
let literal = noLoc $ LitPat noExtField (HsString NoSourceText (fsLit (show s)))
in Just (literal, [], unsafePrettyPrint literal)
usePString _ = Nothing
usePList :: LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String)
usePList =
fmap ( (\(e, s) ->
(noLoc (ListPat noExtField e)
, map (fmap toRefactSrcSpan . fst) s
, unsafePrettyPrint (noLoc $ ListPat noExtField (map snd s) :: LPat GhcPs))
)
. unzip
)
. f True ['a'..'z']
where
f first _ x | patToStr x == "[]" = if first then Nothing else Just []
f first (ident:cs) (view -> PApp_ ":" [a, b]) = ((a, g ident a) :) <$> f False cs b
f first _ _ = Nothing
g :: Char -> LPat GhcPs -> ((String, SrcSpan), LPat GhcPs)
g c (getLoc -> loc) = (([c], loc), noLoc $ VarPat noExtField (noLoc $ mkVarUnqual (fsLit [c])))
useString :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [a], String)
useString b (L _ (ExplicitList _ _ xs)) | not $ null xs, Just s <- mapM fromChar xs =
let literal = noLoc (HsLit noExtField (HsString NoSourceText (fsLit (show s))))
in Just (literal, [], unsafePrettyPrint literal)
useString _ _ = Nothing
useList :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String)
useList b =
fmap ( (\(e, s) ->
(noLoc (ExplicitList noExtField Nothing e)
, map (fmap toSS) s
, unsafePrettyPrint (noLoc $ ExplicitList noExtField Nothing (map snd s) :: LHsExpr GhcPs))
)
. unzip
)
. f True ['a'..'z']
where
f first _ x | varToStr x == "[]" = if first then Nothing else Just []
f first (ident:cs) (view -> App2 c a b) | varToStr c == ":" =
((a, g ident a) :) <$> f False cs b
f first _ _ = Nothing
g :: Char -> LHsExpr GhcPs -> (String, LHsExpr GhcPs)
g c p = ([c], L (getLoc p) (unLoc $ strToVar [c]))
useCons :: View a App2 => Bool -> a -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String)
useCons False (view -> App2 op x y) | varToStr op == "++"
, Just (newX, tplX, spanX) <- f x
, not $ isAppend y =
Just (gen newX y
, [("x", spanX), ("xs", toSS y)]
, unsafePrettyPrint $ gen tplX (strToVar "xs")
)
where
f :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, R.SrcSpan)
f (L _ (ExplicitList _ _ [x]))
| isAtom x || isApp x = Just (x, strToVar "x", toSS x)
| otherwise = Just (addParen x, addParen (strToVar "x"), toSS x)
f _ = Nothing
gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
gen x = noLoc . OpApp noExtField x (noLoc (HsVar noExtField (noLoc consDataCon_RDR)))
useCons _ _ = Nothing
typeListChar :: LHsType GhcPs
typeListChar =
noLoc $ HsListTy noExtField
(noLoc (HsTyVar noExtField NotPromoted (noLoc (mkVarUnqual (fsLit "Char")))))
typeString :: LHsType GhcPs
typeString =
noLoc $ HsTyVar noExtField NotPromoted (noLoc (mkVarUnqual (fsLit "String")))
stringType :: LHsDecl GhcPs -> [Idea]
stringType (L _ x) = case x of
InstD _ ClsInstD{
cid_inst=
ClsInstDecl{cid_binds=x, cid_tyfam_insts=y, cid_datafam_insts=z}} ->
f x ++ f y ++ f z -- Pretty much everthing but the instance type.
_ -> f x
where
f x = concatMap g $ childrenBi x
g :: LHsType GhcPs -> [Idea]
g e@(fromTyParen -> x) = [ignore "Use String" x (transform f x)
rs | not . null $ rs]
where f x = if astEq x typeListChar then typeString else x
rs = [Replace Type (toSS t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar]
hlint-3.1.6/src/Hint/Lambda.hs 0000644 0000000 0000000 00000034044 13671470061 014244 0 ustar 00 0000000 0000000 {-# LANGUAGE LambdaCase, PatternGuards, ViewPatterns #-}
{-
Concept:
Remove all the lambdas you can be inserting only sections
Never create a right section with +-# as the operator (they are misparsed)
Rules:
fun a = \x -> y -- promote lambdas, provided no where's outside the lambda
fun x = y x -- eta reduce, x /= mr and foo /= symbol
\x -> y x ==> y -- eta reduce
((#) x) ==> (x #) -- rotate operators
(flip op x) ==> (`op` x) -- rotate operators
\x y -> x + y ==> (+) -- insert operator
\x y -> op y x ==> flip op
\x -> x + y ==> (+ y) -- insert section,
\x -> op x y ==> (`op` y) -- insert section
\x -> y + x ==> (y +) -- insert section
\x -> \y -> ... ==> \x y -- lambda compression
\x -> (x +) ==> (+) -- operator reduction
f a = \x -> x + x -- f a x = x + x
f a = \a -> a + a -- f _ a = a + a
a = \x -> x + x -- a x = x + x
f (Just a) = \a -> a + a -- f (Just _) a = a + a
f (Foo a b c) = \c -> c + c -- f (Foo a b _) c = c + c
f a = \x -> x + x where _ = test
f (test -> a) = \x -> x + x
f = \x -> x + x -- f x = x + x
fun x y z = f x y z -- fun = f @NoRefactor: refactoring for eta reduce is not implemented
fun x y z = f x x y z -- fun x = f x x @NoRefactor
fun x y z = f g z -- fun x y = f g @NoRefactor
fun x = f . g $ x -- fun = f . g @NoRefactor
f = foo (\y -> g x . h $ y) -- g x . h
f = foo (\y -> g x . h $ y) -- @Message Avoid lambda
f = foo ((*) x) -- (x *) @NoRefactor
f = (*) x
f = foo (flip op x) -- (`op` x) @NoRefactor
f = foo (flip op x) -- @Message Use section @NoRefactor
foo x = bar (\ d -> search d table) -- (`search` table)
foo x = bar (\ d -> search d table) -- @Message Avoid lambda using `infix`
f = flip op x
f = foo (flip (*) x) -- (* x) @NoRefactor
f = foo (flip (-) x)
f = foo (\x y -> fun x y) -- @Warning fun
f = foo (\x y z -> fun x y z) -- @Warning fun
f = foo (\z -> f x $ z) -- f x
f = foo (\x y -> x + y) -- (+)
f = foo (\x -> x * y) -- @Suggestion (* y)
f = foo (\x -> x # y)
f = foo (\x -> \y -> x x y y) -- \x y -> x x y y
f = foo (\x -> \x -> foo x x) -- \_ x -> foo x x
f = foo (\(foo -> x) -> \y -> x x y y)
f = foo (\(x:xs) -> \x -> foo x x) -- \(_:xs) x -> foo x x @NoRefactor
f = foo (\x -> \y -> \z -> x x y y z z) -- \x y z -> x x y y z z
x ! y = fromJust $ lookup x y
f = foo (\i -> writeIdea (getClass i) i)
f = bar (flip Foo.bar x) -- (`Foo.bar` x) @NoRefactor
f = a b (\x -> c x d) -- (`c` d)
yes = \x -> a x where -- a
yes = \x y -> op y x where -- flip op
f = \y -> nub $ reverse y where -- nub . reverse
f = \z -> foo $ bar $ baz z where -- foo . bar . baz
f = \z -> foo $ bar x $ baz z where -- foo . bar x . baz
f = \z -> foo $ z $ baz z where
f = \x -> bar map (filter x) where -- bar map . filter
f = bar &+& \x -> f (g x)
foo = [\column -> set column [treeViewColumnTitle := printf "%s (match %d)" name (length candidnates)]]
foo = [\x -> x]
foo = [\m x -> insert x x m]
foo a b c = bar (flux ++ quux) c where flux = a -- foo a b = bar (flux ++ quux) @NoRefactor
foo a b c = bar (flux ++ quux) c where flux = c
yes = foo (\x -> Just x) -- @Warning Just
foo = bar (\x -> (x `f`)) -- f
foo = bar (\x -> shakeRoot "src" x)
baz = bar (\x -> (x +)) -- (+) @NoRefactor
xs `withArgsFrom` args = f args
foo = bar (\x -> case x of Y z -> z) -- \(Y z) -> z @NoRefactor
yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b @NoRefactor
yes = blah (\ x -> case x of A -> a; B -> b) -- @Note may require `{-# LANGUAGE LambdaCase #-}` adding to the top of the file @NoRefactor
no = blah (\ x -> case x of A -> a x; B -> b x)
yes = blah (\ x -> (y, x)) -- (y,) @NoRefactor
yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q) @NoRefactor
yes = blah (\ x -> (y, x, y, u, v)) -- (y, , y, u, v) @NoRefactor
yes = blah (\ x -> (y, x, z+q)) -- @Note may require `{-# LANGUAGE TupleSections #-}` adding to the top of the file @NoRefactor
yes = blah (\ x -> (y, x, z+x))
tmp = map (\ x -> runST $ action x)
yes = map (\f -> dataDir f) dataFiles -- (dataDir )
{-# LANGUAGE TypeApplications #-}; noBug545 = coerce ((<>) @[a])
{-# LANGUAGE QuasiQuotes #-}; authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name
{-# LANGUAGE QuasiQuotes #-}; authOAuth2 = foo (\name -> authOAuth2Widget [whamlet|Login via #{name}|] name)
f = {- generates a hint using hlint.yaml only -} map (flip (,) "a") "123"
f = {- generates a hint using hlint.yaml only -} map ((,) "a") "123"
f = map (\s -> MkFoo s 0 s) ["a","b","c"]
-}
module Hint.Lambda(lambdaHint) where
import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote)
import Util
import Data.List.Extra
import Data.Set (Set)
import qualified Data.Set as Set
import Refact.Types hiding (RType(Match))
import Data.Generics.Uniplate.DataOnly (universe, universeBi, transformBi)
import BasicTypes
import GHC.Hs
import OccName
import RdrName
import SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr (isTypeApp, isOpApp, isLambda, isQuasiQuote, isVar, isDol, strToVar)
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import GHC.Util.Brackets (isAtom)
import GHC.Util.FreeVars (free, allVars, freeVars, pvars, vars, varss)
import GHC.Util.HsExpr (allowLeftSection, allowRightSection, niceLambdaR, lambda)
import GHC.Util.View
lambdaHint :: DeclHint
lambdaHint _ _ x
= concatMap (uncurry lambdaExp) (universeParentBi x)
++ concatMap lambdaDecl (universe x)
lambdaDecl :: LHsDecl GhcPs -> [Idea]
lambdaDecl
o@(L _ (ValD _
origBind@FunBind {fun_id = funName@(L loc1 _), fun_matches =
MG {mg_alts =
L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _) pats (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}))
| L _ (EmptyLocalBinds noExtField) <- bind
, isLambda $ fromParen origBody
, null (universeBi pats :: [HsExpr GhcPs])
= [warn "Redundant lambda" o (gen pats origBody) [Replace Decl (toSS o) subts template]]
| length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind
= [warn "Eta reduce" (reform pats origBody) (reform pats2 bod2)
[ -- Disabled, see apply-refact #3
]
]
where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform ps b = L loc $ ValD noExtField $
origBind
{fun_matches = MG noExtField (noLoc [noLoc $ Match noExtField ctxt ps $ GRHSs noExtField [noLoc $ GRHS noExtField [] b] $ noLoc $ EmptyLocalBinds noExtField]) Generated}
loc = combineSrcSpans loc1 loc2
gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
gen ps = uncurry reform . fromLambda . lambda ps
(finalpats, body) = fromLambda . lambda pats $ origBody
(pats2, bod2) = etaReduce pats origBody
(origPats, subtsVars) = mkOrigPats (Just (rdrNameStr funName)) finalpats
subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) subtsVars (map toSS finalpats)
template = unsafePrettyPrint (reform origPats varBody)
lambdaDecl _ = []
etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce (unsnoc -> Just (ps, view -> PVar_ p)) (L _ (HsApp _ x (view -> Var_ y)))
| p == y
, y `notElem` vars x
, not $ any isQuasiQuote $ universe x
= etaReduce ps x
etaReduce ps (L loc (OpApp _ x (isDol -> True) y)) = etaReduce ps (L loc (HsApp noExtField x y))
etaReduce ps x = (ps, x)
--Section refactoring is not currently implemented.
lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
lambdaExp _ o@(L _ (HsPar _ (L _ (HsApp _ oper@(L _ (HsVar _ (L _ (rdrNameOcc -> f)))) y))))
| isSymOcc f -- is this an operator?
, isAtom y
, allowLeftSection $ occNameString f
, not $ isTypeApp y =
[suggestN "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField y oper]
lambdaExp _ o@(L _ (HsPar _ (view -> App2 (view -> Var_ "flip") origf@(view -> Var_ f) y)))
| allowRightSection f, not $ "(" `isPrefixOf` f
= [suggestN "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionR noExtField origf y]
lambdaExp p o@(L _ HsLam{})
| not $ any isOpApp p
, (res, refact) <- niceLambdaR [] o
, not $ isLambda res
, not $ any isQuasiQuote $ universe res
, not $ "runST" `Set.member` Set.map occNameString (freeVars o)
, let name = "Avoid lambda" ++ (if countRightSections res > countRightSections o then " using `infix`" else "")
-- If the lambda's parent is an HsPar, and the result is also an HsPar, the span should include the parentheses.
, let from = case (p, res) of
(Just p@(L _ (HsPar _ (L _ HsLam{}))), L _ HsPar{}) -> p
_ -> o
= [(if isVar res then warn else suggest) name from res (refact $ toSS from)]
where
countRightSections :: LHsExpr GhcPs -> Int
countRightSections x = length [() | L _ (SectionR _ (view -> Var_ _) _) <- universe x]
lambdaExp p o@(SimpleLambda origPats origBody)
| isLambda (fromParen origBody)
, null (universeBi origPats :: [HsExpr GhcPs]) -- TODO: I think this checks for view patterns only, so maybe be more explicit about that?
, maybe True (not . isLambda) p =
[suggest "Collapse lambdas" o (lambda pats body) [Replace Expr (toSS o) subts template]]
where
(pats, body) = fromLambda o
(oPats, subtsVars) = mkOrigPats Nothing pats
subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) subtsVars (map toSS pats)
template = unsafePrettyPrint (lambda oPats varBody)
-- match a lambda with a variable pattern, with no guards and no where clauses
lambdaExp _ o@(SimpleLambda [view -> PVar_ x] (L _ expr)) =
case expr of
-- suggest TupleSections instead of lambdas
ExplicitTuple _ args boxity
-- is there exactly one argument that is exactly x?
| ([_x], ys) <- partition ((==Just x) . tupArgVar) args
-- the other arguments must not have a nested x somewhere in them
, Set.notMember x $ Set.map occNameString $ freeVars ys
-> [(suggestN "Use tuple-section" o $ noLoc $ ExplicitTuple noExtField (map removeX args) boxity)
{ideaNote = [RequiresExtension "TupleSections"]}]
-- suggest @LambdaCase@/directly matching in a lambda instead of doing @\x -> case x of ...@
HsCase _ (view -> Var_ x') matchGroup
-- is the case being done on the variable from our original lambda?
| x == x'
-- x must not be used in some other way inside the matches
, Set.notMember x $ Set.map occNameString $ free $ allVars matchGroup
-> case matchGroup of
-- is there a single match? - suggest match inside the lambda
--
-- we need to
-- * add brackets to the match, because matches in lambdas require them
-- * mark match as being in a lambda context so that it's printed properly
oldMG@(MG _ (L _ [L _ oldmatch]) _) ->
[suggestN "Use lambda" o $ noLoc $ HsLam noExtField oldMG
{ mg_alts = noLoc
[noLoc oldmatch
{ m_pats = map mkParPat $ m_pats oldmatch
, m_ctxt = LambdaExpr
}
] }
]
-- otherwise we should use @LambdaCase@
MG _ (L _ xs) _ ->
[(suggestN "Use lambda-case" o $ noLoc $ HsLamCase noExtField matchGroup)
{ideaNote=[RequiresExtension "LambdaCase"]}]
_ -> []
_ -> []
where
-- | Filter out tuple arguments, converting the @x@ (matched in the lambda) variable argument
-- to a missing argument, so that we get the proper section.
removeX :: LHsTupArg GhcPs -> LHsTupArg GhcPs
removeX arg@(L _ (Present _ (view -> Var_ x')))
| x == x' = noLoc $ Missing noExtField
removeX y = y
-- | Extract the name of an argument of a tuple if it's present and a variable.
tupArgVar :: LHsTupArg GhcPs -> Maybe String
tupArgVar (L _ (Present _ (view -> Var_ x))) = Just x
tupArgVar _ = Nothing
lambdaExp _ _ = []
varBody :: LHsExpr GhcPs
varBody = strToVar "body"
-- | Squash lambdas and replace any repeated pattern variable with @_@
fromLambda :: LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
fromLambda (SimpleLambda ps1 (fromLambda . fromParen -> (ps2,x))) = (transformBi (f $ pvars ps2) ps1 ++ ps2, x)
where f :: [String] -> Pat GhcPs -> Pat GhcPs
f bad (VarPat _ (rdrNameStr -> x))
| x `elem` bad = WildPat noExtField
f bad x = x
fromLambda x = ([], x)
-- | For each pattern, if it does not contain wildcards, replace it with a variable pattern.
--
-- The second component of the result is a list of substitution variables, which is ['a'..'z'],
-- excluding variables that occur in the function name or patterns with wildcards. For example, given
-- 'f (Foo a b _) = ...', 'f', 'a' and 'b' are removed.
mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [Char])
mkOrigPats funName pats = (zipWith munge subtsVars pats', subtsVars)
where
(Set.unions -> used, pats') = unzip (map f pats)
-- Remove variables that occur in the function name or patterns with wildcards
subtsVars = filter (\c -> c `Set.notMember` used && Just [c] /= funName) ['a'..'z']
-- Returns (chars in the pattern if the pattern contains wildcards, (whether the pattern contains wildcards, the pattern))
f :: LPat GhcPs -> (Set Char, (Bool, LPat GhcPs))
f p
| any isWildPat (universe p) =
let used = Set.fromList [c | (L _ (VarPat _ (rdrNameStr -> [c]))) <- universe p]
in (used, (True, p))
| otherwise = (mempty, (False, p))
isWildPat :: LPat GhcPs -> Bool
isWildPat = \case (L _ (WildPat _)) -> True; _ -> False
-- Replace the pattern with a variable pattern if the pattern doesn't contain wildcards.
munge :: Char -> (Bool, LPat GhcPs) -> LPat GhcPs
munge _ (True, p) = p
munge ident (False, L ploc _) = L ploc (VarPat noExtField (L ploc $ mkRdrUnqual $ mkVarOcc [ident]))
hlint-3.1.6/src/Hint/Import.hs 0000644 0000000 0000000 00000012162 13671470061 014333 0 ustar 00 0000000 0000000 {-# LANGUAGE LambdaCase, PatternGuards, RecordWildCards #-}
{-
Reduce the number of import declarations.
Two import declarations can be combined if:
(note, A[] is A with whatever import list, or none)
import A[]; import A[] = import A[]
import A(B); import A(C) = import A(B,C)
import A; import A(C) = import A
import A; import A hiding (C) = import A
import A[]; import A[] as Y = import A[] as Y
import A; import A -- import A
import A; import A; import A -- import A
import A(Foo) ; import A -- import A
import A ;import A(Foo) -- import A
import A(Bar(..)); import {-# SOURCE #-} A
import A; import B
import A(B) ; import A(C) -- import A(B,C)
import A; import A hiding (C) -- import A
import A; import A as Y -- import A as Y
import A; import qualified A as Y
import A as B; import A as C
import A as A -- import A
import qualified A as A -- import qualified A
import A; import B; import A -- import A
import qualified A; import A
import B; import A; import A -- import A
import A hiding(Foo); import A hiding(Bar)
import A (foo) \
import A (bar) \
import A (baz) -- import A ( foo, bar, baz )
-}
module Hint.Import(importHint) where
import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest,toSS,rawIdea)
import Refact.Types hiding (ModuleName)
import qualified Refact.Types as R
import Data.Tuple.Extra
import Data.List.Extra
import Data.Generics.Uniplate.DataOnly
import Data.Maybe
import Control.Applicative
import Prelude
import FastString
import BasicTypes
import GHC.Hs
import SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
importHint :: ModuHint
importHint _ ModuleEx {ghcModule=L _ HsModule{hsmodImports=ms}} =
-- Ideas for combining multiple imports.
concatMap (reduceImports . snd) (
groupSort [((n, pkg), i) | i <- ms
, not $ ideclSource (unLoc i)
, let i' = unLoc i
, let n = unLoc $ ideclName i'
, let pkg = unpackFS . sl_fs <$> ideclPkgQual i']) ++
-- Ideas for removing redundant 'as' clauses.
concatMap stripRedundantAlias ms
reduceImports :: [LImportDecl GhcPs] -> [Idea]
reduceImports [] = []
reduceImports ms@(m:_) =
[rawIdea Hint.Type.Warning "Use fewer imports" (getLoc m) (f ms) (Just $ f x) [] rs
| Just (x, rs) <- [simplify ms]]
where f = unlines . map unsafePrettyPrint
simplify :: [LImportDecl GhcPs]
-> Maybe ([LImportDecl GhcPs], [Refactoring R.SrcSpan])
simplify [] = Nothing
simplify (x : xs) = case simplifyHead x xs of
Nothing -> first (x:) <$> simplify xs
Just (xs, rs) ->
let deletions = filter (\case Delete{} -> True; _ -> False) rs
in Just $ maybe (xs, rs) (second (++ deletions)) $ simplify xs
simplifyHead :: LImportDecl GhcPs
-> [LImportDecl GhcPs]
-> Maybe ([LImportDecl GhcPs], [Refactoring R.SrcSpan])
simplifyHead x (y : ys) = case combine x y of
Nothing -> first (y:) <$> simplifyHead x ys
Just (xy, rs) -> Just (xy : ys, rs)
simplifyHead x [] = Nothing
combine :: LImportDecl GhcPs
-> LImportDecl GhcPs
-> Maybe (LImportDecl GhcPs, [Refactoring R.SrcSpan])
combine x@(L loc x') y@(L _ y')
-- Both (un/)qualified, common 'as', same names : Delete the second.
| qual, as, specs = Just (x, [Delete Import (toSS y)])
-- Both (un/)qualified, common 'as', different names : Merge the
-- second into the first and delete it.
| qual, as
, Just (False, xs) <- ideclHiding x'
, Just (False, ys) <- ideclHiding y' =
let newImp = L loc x'{ideclHiding = Just (False, noLoc (unLoc xs ++ unLoc ys))}
in Just (newImp, [Replace Import (toSS x) [] (unsafePrettyPrint (unLoc newImp))
, Delete Import (toSS y)])
-- Both (un/qualified), common 'as', one has names the other doesn't
-- : Delete the one with names.
| qual, as, isNothing (ideclHiding x') || isNothing (ideclHiding y') =
let (newImp, toDelete) = if isNothing (ideclHiding x') then (x, y) else (y, x)
in Just (newImp, [Delete Import (toSS toDelete)])
-- Both unqualified, same names, one (and only one) has an 'as'
-- clause : Delete the one without an 'as'.
| ideclQualified x' == NotQualified, qual, specs, length ass == 1 =
let (newImp, toDelete) = if isJust (ideclAs x') then (x, y) else (y, x)
in Just (newImp, [Delete Import (toSS toDelete)])
-- No hints.
| otherwise = Nothing
where
eqMaybe:: Eq a => Maybe (Located a) -> Maybe (Located a) -> Bool
eqMaybe (Just x) (Just y) = x `eqLocated` y
eqMaybe Nothing Nothing = True
eqMaybe _ _ = False
qual = ideclQualified x' == ideclQualified y'
as = ideclAs x' `eqMaybe` ideclAs y'
ass = mapMaybe ideclAs [x', y']
specs = transformBi (const noSrcSpan) (ideclHiding x') ==
transformBi (const noSrcSpan) (ideclHiding y')
stripRedundantAlias :: LImportDecl GhcPs -> [Idea]
stripRedundantAlias x@(L loc i@ImportDecl {..})
-- Suggest 'import M as M' be just 'import M'.
| Just (unLoc ideclName) == fmap unLoc ideclAs =
[suggest "Redundant as" x (cL loc i{ideclAs=Nothing} :: LImportDecl GhcPs) [RemoveAsKeyword (toSS x)]]
stripRedundantAlias _ = []
hlint-3.1.6/src/Hint/Extensions.hs 0000644 0000000 0000000 00000045010 13671470061 015216 0 ustar 00 0000000 0000000 {-# LANGUAGE LambdaCase, NamedFieldPuns #-}
{-
Suggest removal of unnecessary extensions
i.e. They have {-# LANGUAGE RecursiveDo #-} but no mdo keywords
{-# LANGUAGE Arrows #-} \
f = id --
{-# LANGUAGE RebindableSyntax #-} \
f = id
{-# LANGUAGE RebindableSyntax, ParallelListComp, ImplicitParams #-} \
f = [(a,c) | a <- b | c <- d] -- {-# LANGUAGE RebindableSyntax, ParallelListComp #-}
{-# LANGUAGE EmptyDataDecls #-} \
data Foo
{-# LANGUAGE TemplateHaskell #-} \
$(deriveNewtypes typeInfo)
{-# LANGUAGE TemplateHaskell #-} \
main = foo ''Bar
{-# LANGUAGE PatternGuards #-} \
test = case x of _ | y <- z -> w
{-# LANGUAGE TemplateHaskell,EmptyDataDecls #-} \
$(fmap return $ dataD (return []) (mkName "Void") [] [] [])
{-# LANGUAGE RecursiveDo #-} \
main = mdo x <- y; return y
{-# LANGUAGE RecursiveDo #-} \
main = do {rec {x <- return 1}; print x}
{-# LANGUAGE ImplicitParams, BangPatterns #-} \
sort :: (?cmp :: a -> a -> Bool) => [a] -> [a] \
sort !f = undefined
{-# LANGUAGE KindSignatures #-} \
data Set (cxt :: * -> *) a = Set [a]
{-# LANGUAGE BangPatterns #-} \
foo x = let !y = x in y
{-# LANGUAGE BangPatterns #-} \
data Foo = Foo !Int --
{-# LANGUAGE TypeOperators #-} \
data (<+>) a b = Foo a b
{-# LANGUAGE TypeOperators #-} \
data Foo a b = a :+ b --
{-# LANGUAGE TypeOperators #-} \
type (<+>) a b = Foo a b
{-# LANGUAGE TypeOperators #-} \
type Foo a b = a :+ b
{-# LANGUAGE TypeOperators, TypeFamilies #-} \
type family Foo a b :: Type where Foo a b = a :+ b
{-# LANGUAGE TypeOperators, TypeFamilies #-} \
type family Foo a b :: Type where Foo a b = (<+>) a b -- {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators, TypeFamilies #-} \
class Foo a where data (<+>) a
{-# LANGUAGE TypeOperators, TypeFamilies #-} \
class Foo a where foo :: a -> Int <+> Bool
{-# LANGUAGE TypeOperators #-} \
class (<+>) a where
{-# LANGUAGE TypeOperators #-} \
foo :: Int -> Double <+> Bool \
foo x = y
{-# LANGUAGE TypeOperators #-} \
foo :: Int -> (<+>) Double Bool \
foo x = y --
{-# LANGUAGE TypeOperators #-} \
(<+>) :: Int -> Int -> Int \
x <+> y = x + y --
{-# LANGUAGE RecordWildCards #-} \
record field = Record{..}
{-# LANGUAGE RecordWildCards #-} \
record = 1 -- @Note may require `{-# LANGUAGE DisambiguateRecordFields #-}` adding to the top of the file
{-# LANGUAGE RecordWildCards #-} \
{-# LANGUAGE DisambiguateRecordFields #-} \
record = 1 -- @NoNote
{-# LANGUAGE UnboxedTuples #-} \
record = 1 --
{-# LANGUAGE TemplateHaskell #-} \
foo
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \
record = 1 --
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \
newtype Foo = Foo Int deriving Data -- {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \
data Foo = Foo Int deriving Data -- {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \
newtype Foo = Foo Int deriving Class -- {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \
data Foo = Foo Int deriving Class --
{-# LANGUAGE DeriveFunctor #-} \
data Foo = Foo Int deriving Functor
{-# LANGUAGE DeriveFunctor #-} \
newtype Foo = Foo Int deriving Functor
{-# LANGUAGE GeneralizedNewtypeDeriving #-} \
newtype Foo = Foo Int deriving Functor
{-# LANGUAGE GeneralizedNewtypeDeriving #-} \
newtype Foo = Foo Int deriving Data --
{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, StandaloneDeriving #-} \
deriving instance Functor Bar
{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, StandaloneDeriving #-} \
deriving instance Show Bar -- {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} \
newtype Micro = Micro Int deriving Generic -- {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} \
instance Class Int where {newtype MyIO a = MyIO a deriving NewClass}
{-# LANGUAGE UnboxedTuples #-} \
f :: Int -> (# Int, Int #)
{-# LANGUAGE UnboxedTuples #-} \
f :: x -> (x, x); f x = (x, x) --
{-# LANGUAGE UnboxedTuples #-} \
f x = case x of (# a, b #) -> a
{-# LANGUAGE GeneralizedNewtypeDeriving,UnboxedTuples #-} \
newtype T m a = T (m a) deriving (PrimMonad)
{-# LANGUAGE InstanceSigs #-} \
instance Eq a => Eq (T a) where \
(==) :: T a -> T a -> Bool \
(==) (T x) (T y) = x==y
{-# LANGUAGE InstanceSigs #-} \
instance Eq a => Eq (T a) where \
(==) (T x) (T y) = x==y --
{-# LANGUAGE DefaultSignatures #-} \
class Val a where; val :: a --
{-# LANGUAGE DefaultSignatures #-} \
class Val a where; val :: a; default val :: Int
{-# LANGUAGE TypeApplications #-} \
foo = id --
{-# LANGUAGE TypeApplications #-} \
foo = id @Int
{-# LANGUAGE LambdaCase #-} \
foo = id --
{-# LANGUAGE LambdaCase #-} \
foo = \case () -> ()
{-# LANGUAGE NumDecimals #-} \
foo = 12.3e2
{-# LANGUAGE NumDecimals #-} \
foo = id --
{-# LANGUAGE NumDecimals #-} \
foo = 12.345e2 --
{-# LANGUAGE TupleSections #-} \
main = map (,1,2) xs
{-# LANGUAGE TupleSections #-} \
main = id --
{-# LANGUAGE OverloadedStrings #-} \
main = "test"
{-# LANGUAGE OverloadedStrings #-} \
main = id --
{-# LANGUAGE OverloadedLists #-} \
main = [1]
{-# LANGUAGE OverloadedLists #-} \
main [1] = True
{-# LANGUAGE OverloadedLists #-} \
main = id --
{-# LANGUAGE OverloadedLabels #-} \
main = #foo
{-# LANGUAGE OverloadedLabels #-} \
main = id --
{-# LANGUAGE DeriveAnyClass #-} \
main = id --
{-# LANGUAGE DeriveAnyClass #-} \
data Foo = Foo deriving Bob
{-# LANGUAGE DeriveAnyClass #-} \
data Foo a = Foo a deriving (Eq,Data,Functor) --
{-# LANGUAGE MagicHash #-} \
foo# = id
{-# LANGUAGE MagicHash #-} \
main = "foo"#
{-# LANGUAGE MagicHash #-} \
main = 5#
{-# LANGUAGE MagicHash #-} \
main = 'a'#
{-# LANGUAGE MagicHash #-} \
main = 5.6#
{-# LANGUAGE MagicHash #-} \
foo = id --
{-# LANGUAGE GeneralizedNewtypeDeriving #-} \
newtype X = X Int deriving newtype Show
{-# LANGUAGE EmptyCase #-} \
main = case () of {}
{-# LANGUAGE EmptyCase #-} \
main = case () of x -> x --
{-# LANGUAGE EmptyCase #-} \
main = case () of x -> x --
{-# LANGUAGE PolyKinds, KindSignatures #-} -- {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE PolyKinds, KindSignatures #-} \
data Set (cxt :: * -> *) a = Set [a] -- @Note Extension KindSignatures is implied by PolyKinds
{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} \
main = putStrLn [f|{T.intercalate "blah" []}|]
{-# LANGUAGE NamedFieldPuns #-} \
foo = x{bar}
{-# LANGUAGE PatternSynonyms #-} \
module Foo (pattern Bar) where x = 42
{-# LANGUAGE PatternSynonyms #-} \
import Foo (pattern Bar); x = 42
{-# LANGUAGE PatternSynonyms #-} \
pattern Foo s <- Bar s _ where Foo s = Bar s s
{-# LANGUAGE PatternSynonyms #-} \
x = 42 --
{-# LANGUAGE MultiWayIf #-} \
x = if | b1 -> v1 | b2 -> v2 | otherwise -> v3
{-# LANGUAGE MultiWayIf #-} \
x = if b1 then v1 else if b2 then v2 else v3 --
static = 42
{-# LANGUAGE NamedFieldPuns #-} \
foo Foo{x} = x
{-# LANGUAGE NamedFieldPuns #-} \
foo = Foo{x}
{-# LANGUAGE NamedFieldPuns #-} \
foo = bar{x}
{-# LANGUAGE NamedFieldPuns #-} --
{-# LANGUAGE NumericUnderscores #-} \
lessThanPi = (< 3.141_592_653_589_793)
{-# LANGUAGE NumericUnderscores #-} \
oneMillion = 0xf4__240
{-# LANGUAGE NumericUnderscores #-} \
avogadro = 6.022140857e+23 --
{-# LANGUAGE StaticPointers #-} \
static = 42 --
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE Trustworthy, NamedFieldPuns #-} -- {-# LANGUAGE Trustworthy #-}
{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE NoStarIsType, ExplicitNamespaces #-} \
import GHC.TypeLits(KnownNat, type (+), type (*))
{-# LANGUAGE LambdaCase, MultiWayIf, NoRebindableSyntax #-} \
foo = \case True -> 3 -- {-# LANGUAGE LambdaCase, NoRebindableSyntax #-}
-}
module Hint.Extensions(extensionsHint) where
import Hint.Type(ModuHint, rawIdea,Severity(Warning),Note(..),toSS,ghcAnnotations,ghcModule)
import Extension
import Data.Generics.Uniplate.DataOnly
import Control.Monad.Extra
import Data.Maybe
import Data.List.Extra
import Data.Data
import Refact.Types
import qualified Data.Set as Set
import qualified Data.Map as Map
import SrcLoc
import GHC.Hs
import BasicTypes
import Class
import RdrName
import ForeignCall
import GHC.Util
import GHC.LanguageExtensions.Type
import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Hs.Types
import Language.Haskell.GhclibParserEx.GHC.Hs.Decls
import Language.Haskell.GhclibParserEx.GHC.Hs.Binds
import Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp
import Language.Haskell.GhclibParserEx.GHC.Driver.Session
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
extensionsHint :: ModuHint
extensionsHint _ x =
[ rawIdea Hint.Type.Warning "Unused LANGUAGE pragma"
sl
(comment (mkLanguagePragmas sl exts))
(Just newPragma)
( [RequiresExtension (show gone) | (_, Just x) <- before \\ after, gone <- Map.findWithDefault [] x disappear] ++
[ Note $ "Extension " ++ show x ++ " is " ++ reason x
| (_, Just x) <- explainedRemovals])
[ModifyComment (toSS (mkLanguagePragmas sl exts)) newPragma]
| (L sl _, exts) <- languagePragmas $ pragmas (ghcAnnotations x)
, let before = [(x, readExtension x) | x <- exts]
, let after = filter (maybe True (`Set.member` keep) . snd) before
, before /= after
, let explainedRemovals
| null after && not (any (`Map.member` implied) $ mapMaybe snd before) = []
| otherwise = before \\ after
, let newPragma =
if null after then "" else comment (mkLanguagePragmas sl $ map fst after)
]
where
usedTH :: Bool
usedTH = used TemplateHaskell (ghcModule x) || used QuasiQuotes (ghcModule x)
-- If TH or QuasiQuotes is on, can use all other extensions
-- programmatically.
-- All the extensions defined to be used.
extensions :: Set.Set Extension
extensions = Set.fromList $ mapMaybe readExtension $
concatMap snd $ languagePragmas (pragmas (ghcAnnotations x))
-- Those extensions we detect to be useful.
useful :: Set.Set Extension
useful = if usedTH then extensions else Set.filter (`usedExt` ghcModule x) extensions
-- Those extensions which are useful, but implied by other useful
-- extensions.
implied :: Map.Map Extension Extension
implied = Map.fromList
[ (e, a)
| e <- Set.toList useful
, a:_ <- [filter (`Set.member` useful) $ extensionImpliedEnabledBy e]
]
-- Those we should keep.
keep :: Set.Set Extension
keep = useful `Set.difference` Map.keysSet implied
-- The meaning of (a,b) is a used to imply b, but has gone, so
-- suggest enabling b.
disappear :: Map.Map Extension [Extension]
disappear =
Map.fromListWith (++) $
nubOrdOn snd -- Only keep one instance for each of a.
[ (e, [a])
| e <- Set.toList $ extensions `Set.difference` keep
, a <- fst $ extensionImplies e
, a `Set.notMember` useful
, usedTH || usedExt a (ghcModule x)
]
reason :: Extension -> String
reason x =
case Map.lookup x implied of
Just a -> "implied by " ++ show a
Nothing -> "not used"
deriveHaskell = ["Eq","Ord","Enum","Ix","Bounded","Read","Show"]
deriveGenerics = ["Data","Typeable","Generic","Generic1","Lift"]
deriveCategory = ["Functor","Foldable","Traversable"]
-- | Classes that can't require newtype deriving
noDeriveNewtype =
delete "Enum" deriveHaskell ++ -- Enum can't always be derived on a newtype
deriveGenerics -- Generics stuff can't newtype derive since it has the ctor in it
-- | Classes that can appear as stock, and can't appear as anyclass
deriveStock :: [String]
deriveStock = deriveHaskell ++ deriveGenerics ++ deriveCategory
usedExt :: Extension -> Located (HsModule GhcPs) -> Bool
usedExt NumDecimals = hasS isWholeFrac
-- Only whole number fractions are permitted by NumDecimals
-- extension. Anything not-whole raises an error.
usedExt DeriveLift = hasDerive ["Lift"]
usedExt DeriveAnyClass = not . null . derivesAnyclass . derives
usedExt x = used x
used :: Extension -> Located (HsModule GhcPs) -> Bool
used RecursiveDo = hasS isMDo ||^ hasS isRecStmt
used ParallelListComp = hasS isParComp
used FunctionalDependencies = hasT (un :: FunDep (Located RdrName))
used ImplicitParams = hasT (un :: HsIPName)
used TypeApplications = hasS isTypeApp
used EmptyDataDecls = hasS f
where
f :: HsDataDefn GhcPs -> Bool
f (HsDataDefn _ _ _ _ _ [] _) = True
f _ = False
used EmptyCase = hasS f
where
f :: HsExpr GhcPs -> Bool
f (HsCase _ _ (MG _ (L _ []) _)) = True
f (HsLamCase _ (MG _ (L _ []) _)) = True
f _ = False
used KindSignatures = hasT (un :: HsKind GhcPs)
used BangPatterns = hasS isPBangPat ||^ hasS isStrictMatch
used TemplateHaskell = hasT2' (un :: (HsBracket GhcPs, HsSplice GhcPs)) ||^ hasS f ||^ hasS isSpliceDecl
where
f :: HsBracket GhcPs -> Bool
f VarBr{} = True
f TypBr{} = True
f _ = False
used ForeignFunctionInterface = hasT (un :: CCallConv)
used PatternGuards = hasS f
where
f :: GRHS GhcPs (LHsExpr GhcPs) -> Bool
f (GRHS _ xs _) = g xs
f _ = False -- Extension constructor
g :: [GuardLStmt GhcPs] -> Bool
g [] = False
g [L _ BodyStmt{}] = False
g _ = True
used StandaloneDeriving = hasS isDerivD
used TypeOperators = hasS tyOpInSig ||^ hasS tyOpInDecl
where
tyOpInSig :: HsType GhcPs -> Bool
tyOpInSig = \case
HsOpTy{} -> True; _ -> False
tyOpInDecl :: HsDecl GhcPs -> Bool
tyOpInDecl = \case
(TyClD _ (FamDecl _ FamilyDecl{fdLName})) -> isOp fdLName
(TyClD _ SynDecl{tcdLName}) -> isOp tcdLName
(TyClD _ DataDecl{tcdLName}) -> isOp tcdLName
(TyClD _ ClassDecl{tcdLName, tcdATs}) -> any isOp (tcdLName : [fdLName famDecl | L _ famDecl <- tcdATs])
_ -> False
isOp (L _ name) = isSymbolRdrName name
used RecordWildCards = hasS hasFieldsDotDot ||^ hasS hasPFieldsDotDot
used RecordPuns = hasS isPFieldPun ||^ hasS isFieldPun ||^ hasS isFieldPunUpdate
used UnboxedTuples = hasS isUnboxedTuple ||^ hasS (== Unboxed) ||^ hasS isDeriving
where
-- detect if there are deriving declarations or data ... deriving stuff
-- by looking for the deriving strategy both contain (even if its Nothing)
-- see https://github.com/ndmitchell/hlint/issues/833 for why we care
isDeriving :: Maybe (LDerivStrategy GhcPs) -> Bool
isDeriving _ = True
used PackageImports = hasS f
where
f :: ImportDecl GhcPs -> Bool
f ImportDecl{ideclPkgQual=Just _} = True
f _ = False
used QuasiQuotes = hasS isQuasiQuote ||^ hasS isTyQuasiQuote
used ViewPatterns = hasS isPViewPat
used InstanceSigs = hasS f
where
f :: HsDecl GhcPs -> Bool
f (InstD _ decl) = hasT (un :: Sig GhcPs) decl
f _ = False
used DefaultSignatures = hasS isClsDefSig
used DeriveDataTypeable = hasDerive ["Data","Typeable"]
used DeriveFunctor = hasDerive ["Functor"]
used DeriveFoldable = hasDerive ["Foldable"]
used DeriveTraversable = hasDerive ["Traversable","Foldable","Functor"]
used DeriveGeneric = hasDerive ["Generic","Generic1"]
used GeneralizedNewtypeDeriving = not . null . derivesNewtype' . derives
used MultiWayIf = hasS isMultiIf
used NumericUnderscores = hasS f
where
f :: OverLitVal -> Bool
f (HsIntegral (IL (SourceText t) _ _)) = '_' `elem` t
f (HsFractional (FL (SourceText t) _ _)) = '_' `elem` t
f _ = False
used LambdaCase = hasS isLCase
used TupleSections = hasS isTupleSection
used OverloadedStrings = hasS isString
used OverloadedLists = hasS isListExpr ||^ hasS isListPat
where
isListExpr :: HsExpr GhcPs -> Bool
isListExpr ExplicitList{} = True
isListExpr ArithSeq{} = True
isListExpr _ = False
isListPat :: Pat GhcPs -> Bool
isListPat ListPat{} = True
isListPat _ = False
used OverloadedLabels = hasS isLabel
where
isLabel :: HsExpr GhcPs -> Bool
isLabel HsOverLabel{} = True
isLabel _ = False
used Arrows = hasS isProc
used TransformListComp = hasS isTransStmt
used MagicHash = hasS f ||^ hasS isPrimLiteral
where
f :: RdrName -> Bool
f s = "#" `isSuffixOf` occNameStr s
used PatternSynonyms = hasS isPatSynBind ||^ hasS isPatSynIE
used _= const True
hasDerive :: [String] -> Located (HsModule GhcPs) -> Bool
hasDerive want = any (`elem` want) . derivesStock' . derives
-- Derivations can be implemented using any one of 3 strategies, so for each derivation
-- add it to all the strategies that might plausibly implement it
data Derives = Derives
{derivesStock' :: [String]
,derivesAnyclass :: [String]
,derivesNewtype' :: [String]
}
instance Semigroup Derives where
Derives x1 x2 x3 <> Derives y1 y2 y3 =
Derives (x1 ++ y1) (x2 ++ y2) (x3 ++ y3)
instance Monoid Derives where
mempty = Derives [] [] []
mappend = (<>)
addDerives :: Maybe NewOrData -> Maybe (DerivStrategy GhcPs) -> [String] -> Derives
addDerives _ (Just s) xs = case s of
StockStrategy -> mempty{derivesStock' = xs}
AnyclassStrategy -> mempty{derivesAnyclass = xs}
NewtypeStrategy -> mempty{derivesNewtype' = xs}
ViaStrategy{} -> mempty
addDerives nt _ xs = mempty
{derivesStock' = stock
,derivesAnyclass = other
,derivesNewtype' = if maybe True isNewType nt then filter (`notElem` noDeriveNewtype) xs else []}
where (stock, other) = partition (`elem` deriveStock) xs
derives :: Located (HsModule GhcPs) -> Derives
derives (L _ m) = mconcat $ map decl (childrenBi m) ++ map idecl (childrenBi m)
where
idecl :: Located (DataFamInstDecl GhcPs) -> Derives
idecl (L _ (DataFamInstDecl (HsIB _ FamEqn {feqn_rhs=HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}}))) = g dn ds
idecl _ = mempty
decl :: LHsDecl GhcPs -> Derives
decl (L _ (TyClD _ (DataDecl _ _ _ _ HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}))) = g dn ds -- Data declaration.
decl (L _ (DerivD _ (DerivDecl _ (HsWC _ sig) strategy _))) = addDerives Nothing (fmap unLoc strategy) [derivedToStr sig] -- A deriving declaration.
decl _ = mempty
g :: NewOrData -> [LHsDerivingClause GhcPs] -> Derives
g dn ds = mconcat [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | L _ (HsDerivingClause _ strategy (L _ tys)) <- ds]
derivedToStr :: LHsSigType GhcPs -> String
derivedToStr (HsIB _ t) = ih t
where
ih :: LHsType GhcPs -> String
ih (L _ (HsQualTy _ _ a)) = ih a
ih (L _ (HsParTy _ a)) = ih a
ih (L _ (HsAppTy _ a _)) = ih a
ih (L _ (HsTyVar _ _ a)) = unsafePrettyPrint $ unqual a
ih (L _ a) = unsafePrettyPrint a -- I don't anticipate this case is called.
derivedToStr _ = "" -- new ctor
un = undefined
hasT t x = not $ null (universeBi x `asTypeOf` [t])
hasT2' ~(t1,t2) = hasT t1 ||^ hasT t2
hasS :: (Data x, Data a) => (a -> Bool) -> x -> Bool
hasS test = any test . universeBi
hlint-3.1.6/src/Hint/Export.hs 0000644 0000000 0000000 00000003352 13656755416 014360 0 ustar 00 0000000 0000000 {-
Suggest using better export declarations
main = 1
module Foo where foo = 1 -- module Foo(module Foo) where @NoRefactor
module Foo(foo) where foo = 1
module Foo(module Foo) where foo = 1 -- @Ignore module Foo(...) where @NoRefactor
module Foo(module Foo, foo) where foo = 1 -- module Foo(..., foo) where @NoRefactor
-}
{-# LANGUAGE TypeFamilies #-}
module Hint.Export(exportHint) where
import Hint.Type(ModuHint, ModuleEx(..),ideaNote,ignore,Note(..))
import GHC.Hs
import Module
import SrcLoc
import OccName
import RdrName
exportHint :: ModuHint
exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) _)
| Nothing <- exports =
let r = o{ hsmodExports = Just (noLoc [noLoc (IEModuleContents noExtField name)] )} in
[(ignore "Use module export list" (L s o) (noLoc r) []){ideaNote = [Note "an explicit list is usually better"]}]
| Just (L _ xs) <- exports
, mods <- [x | x <- xs, isMod x]
, modName <- moduleNameString (unLoc name)
, names <- [ moduleNameString (unLoc n) | (L _ (IEModuleContents _ n)) <- mods]
, exports' <- [x | x <- xs, not (matchesModName modName x)]
, modName `elem` names =
let dots = mkRdrUnqual (mkVarOcc " ... ")
r = o{ hsmodExports = Just (noLoc (noLoc (IEVar noExtField (noLoc (IEName (noLoc dots)))) : exports') )}
in
[ignore "Use explicit module export list" (L s o) (noLoc r) []]
where
o = m{hsmodImports=[], hsmodDecls=[], hsmodDeprecMessage=Nothing, hsmodHaddockModHeader=Nothing }
isMod (L _ (IEModuleContents _ _)) = True
isMod _ = False
matchesModName m (L _ (IEModuleContents _ (L _ n))) = moduleNameString n == m
matchesModName _ _ = False
exportHint _ _ = []
hlint-3.1.6/src/Hint/Duplicate.hs 0000644 0000000 0000000 00000010703 13674632146 015001 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-
Find bindings within a let, and lists of statements
If you have n the same, error out
foo = a where {a = 1; b = 2; c = 3} \
bar = a where {a = 1; b = 2; c = 3} -- ??? @NoRefactor
main = do a; a; a; a
main = do a; a; a; a; a; a -- ??? @NoRefactor: refactoring not supported for duplication hints.
main = do a; a; a; a; a; a; a -- ??? @NoRefactor
main = do (do b; a; a; a); do (do c; a; a; a) -- ??? @NoRefactor
main = do a; a; a; b; a; a; a -- ??? @NoRefactor
main = do a; a; a; b; a; a
{-# ANN main "HLint: ignore Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ??? @NoRefactor
{-# HLINT ignore main "Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ??? @NoRefactor
{- HLINT ignore main "Reduce duplication" -}; main = do a; a; a; a; a; a -- @Ignore ??? @NoRefactor
-}
module Hint.Duplicate(duplicateHint) where
import Hint.Type (CrossHint, ModuleEx(..), Idea(..),rawIdeaN,Severity(Suggestion,Warning))
import Data.Data
import Data.Generics.Uniplate.DataOnly
import Data.Default
import Data.Maybe
import Data.Tuple.Extra
import Data.List hiding (find)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import SrcLoc
import GHC.Hs
import Outputable
import Bag
import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Hs
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
duplicateHint :: CrossHint
duplicateHint ms =
-- Do expressions.
dupes [ (m, d, y)
| (m, d, x) <- ds
, HsDo _ _ (L _ y) :: HsExpr GhcPs <- universeBi x
] ++
-- Bindings in a 'let' expression or a 'where' clause.
dupes [ (m, d, y)
| (m, d, x) <- ds
, HsValBinds _ (ValBinds _ b _ ) :: HsLocalBinds GhcPs <- universeBi x
, let y = bagToList b
]
where
ds = [(modName m, fromMaybe "" (declName d), unLoc d)
| ModuleEx m _ <- map snd ms
, d <- hsmodDecls (unLoc m)]
dupes :: (Outputable e, Data e) => [(String, String, [Located e])] -> [Idea]
dupes ys =
[(rawIdeaN
(if length xs >= 5 then Hint.Type.Warning else Suggestion)
"Reduce duplication" p1
(unlines $ map unsafePrettyPrint xs)
(Just $ "Combine with " ++ showSrcSpan p2)
[]
){ideaModule = [m1, m2], ideaDecl = [d1, d2]}
| ((m1, d1, SrcSpanD p1), (m2, d2, SrcSpanD p2), xs) <- duplicateOrdered 3 $ map f ys]
where
f (m, d, xs) =
[((m, d, SrcSpanD (getLoc x)), extendInstances (stripLocs x)) | x <- xs]
---------------------------------------------------------------------
-- DUPLICATE FINDING
-- | The position to return if we match at this point, and the map of where to go next
-- If two runs have the same vals, always use the first pos you find
data Dupe pos val = Dupe pos (Map.Map val (Dupe pos val))
find :: Ord val => [val] -> Dupe pos val -> (pos, Int)
find (v:vs) (Dupe p mp) | Just d <- Map.lookup v mp = second (+1) $ find vs d
find _ (Dupe p mp) = (p, 0)
add :: Ord val => pos -> [val] -> Dupe pos val -> Dupe pos val
add pos [] d = d
add pos (v:vs) (Dupe p mp) = Dupe p $ Map.insertWith f v (add pos vs $ Dupe pos Map.empty) mp
where f new = add pos vs
duplicateOrdered :: forall pos val.
(Ord pos, Default pos, Ord val) => Int -> [[(pos,val)]] -> [(pos,pos,[val])]
duplicateOrdered threshold xs = concat $ concat $ snd $ mapAccumL f (Dupe def Map.empty) xs
where
f :: Dupe pos val -> [(pos, val)] -> (Dupe pos val, [[(pos, pos, [val])]])
f d xs = second overlaps $ mapAccumL (g pos) d $ onlyAtLeast threshold $ tails xs
where pos = Map.fromList $ zip (map fst xs) [0..]
g :: Map.Map pos Int -> Dupe pos val -> NE.NonEmpty (pos, val) -> (Dupe pos val, [(pos, pos, [val])])
g pos d xs = (d2, res)
where
res = [(p,pme,take mx vs) | i >= threshold
,let mx = maybe i (\x -> min i $ (pos Map.! pme) - x) $ Map.lookup p pos
,mx >= threshold]
vs = NE.toList $ snd <$> xs
(p,i) = find vs d
pme = fst $ NE.head xs
d2 = add pme vs d
onlyAtLeast n = mapMaybe $ \l -> case l of
x:xs | length l >= n -> Just (x NE.:| xs)
_ -> Nothing
overlaps (x@((_,_,n):_):xs) = x : overlaps (drop (length n - 1) xs)
overlaps (x:xs) = x : overlaps xs
overlaps [] = []
hlint-3.1.6/src/Hint/Comment.hs 0000644 0000000 0000000 00000003074 13656755416 014502 0 ustar 00 0000000 0000000
{-
{- MISSING HASH #-} -- {-# MISSING HASH #-}
{- INLINE X -}
{- INLINE Y -} -- {-# INLINE Y #-}
{- INLINE[~k] f -} -- {-# INLINE[~k] f #-}
{- NOINLINE Y -} -- {-# NOINLINE Y #-}
{- UNKNOWN Y -}
INLINE X
-}
module Hint.Comment(commentHint) where
import Hint.Type
import Data.Char
import Data.List.Extra
import Refact.Types(Refactoring(ModifyComment))
import SrcLoc
import ApiAnnotation
import GHC.Util
directives :: [String]
directives = words $
"LANGUAGE OPTIONS_GHC INCLUDE WARNING DEPRECATED MINIMAL INLINE NOINLINE INLINABLE " ++
"CONLIKE LINE SPECIALIZE SPECIALISE UNPACK NOUNPACK SOURCE"
commentHint :: ModuHint
commentHint _ m = concatMap chk (ghcComments m)
where
chk :: Located AnnotationComment -> [Idea]
chk comm
| isMultiline, "#" `isSuffixOf` s && not ("#" `isPrefixOf` s) = [grab "Fix pragma markup" comm $ '#':s]
| isMultiline, name `elem` directives = [grab "Use pragma syntax" comm $ "# " ++ trim s ++ " #"]
where
isMultiline = isCommentMultiline comm
s = commentText comm
name = takeWhile (\x -> isAlphaNum x || x == '_') $ trimStart s
chk _ = []
grab :: String -> Located AnnotationComment -> String -> Idea
grab msg o@(L pos _) s2 =
let s1 = commentText o in
rawIdea Suggestion msg pos (f s1) (Just $ f s2) [] refact
where f s = if isCommentMultiline o then "{-" ++ s ++ "-}" else "--" ++ s
refact = [ModifyComment (toRefactSrcSpan pos) (f s2)]
hlint-3.1.6/src/Hint/Bracket.hs 0000644 0000000 0000000 00000025103 13671470061 014433 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-
Raise an error if you are bracketing an atom, or are enclosed by a
list bracket.
-- expression bracket reduction
yes = (f x) x -- @Suggestion f x x
no = f (x x)
yes = (foo) -- foo
yes = (foo bar) -- @Suggestion foo bar
yes = foo (bar) -- @Warning bar
yes = foo ((x x)) -- @Suggestion (x x)
yes = (f x) ||| y -- @Suggestion f x ||| y
yes = if (f x) then y else z -- @Suggestion if f x then y else z
yes = if x then (f y) else z -- @Suggestion if x then f y else z
yes = (a foo) :: Int -- @Suggestion a foo :: Int
yes = [(foo bar)] -- @Suggestion [foo bar]
yes = foo ((x y), z) -- @Suggestion (x y, z)
yes = C { f = (e h) } -- @Suggestion C {f = e h}
yes = \ x -> (x && x) -- @Suggestion \x -> x && x
no = \(x -> y) -> z
yes = (`foo` (bar baz)) -- @Suggestion (`foo` bar baz)
yes = f ((x)) -- @Warning x
main = do f; (print x) -- @Suggestion do f print x
yes = f (x) y -- @Warning x
no = f (+x) y
no = f ($x) y
no = ($x)
yes = (($x))
no = ($1)
yes = (($1)) -- @Warning ($1)
no = (+5)
yes = ((+5)) -- @Warning (+5)
issue909 = case 0 of { _ | n <- (0 :: Int) -> n }
issue909 = foo (\((x :: z) -> y) -> 9 + x * 7)
issue909 = foo (\((x : z) -> y) -> 9 + x * 7) -- \(x : z -> y) -> 9 + x * 7
issue909 = let ((x:: y) -> z) = q in q
issue909 = do {((x :: y) -> z) <- e; return 1}
issue970 = (f x +) (g x) -- f x + (g x) @NoRefactor
issue969 = (Just \x -> x || x) *> Just True
-- type bracket reduction
foo :: (Int -> Int) -> Int
foo :: (Maybe Int) -> a -- @Suggestion Maybe Int -> a
instance Named (DeclHead S)
data Foo = Foo {foo :: (Maybe Foo)} -- @Suggestion foo :: Maybe Foo
-- pattern bracket reduction
foo (x:xs) = 1
foo (True) = 1 -- @Warning True
foo ((True)) = 1 -- @Warning True
foo (A{}) = True -- A{}
f x = case x of (Nothing) -> 1; _ -> 2 -- Nothing
-- dollar reduction tests
no = groupFsts . sortFst $ mr
yes = split "to" $ names -- split "to" names
yes = white $ keysymbol -- white keysymbol
yes = operator foo $ operator -- operator foo operator
no = operator foo $ operator bar
yes = return $ Record{a=b}
no = f $ [1,2..5] -- f [1,2..5] @NoRefactor: apply-refact bug; see apply-refact #51
-- $/bracket rotation tests
yes = (b $ c d) ++ e -- b (c d) ++ e
yes = (a b $ c d) ++ e -- a b (c d) ++ e
no = (f . g $ a) ++ e
no = quickCheck ((\h -> cySucc h == succ h) :: Hygiene -> Bool)
foo = (case x of y -> z; q -> w) :: Int
-- backup fixity resolution
main = do a += b . c; return $ a . b
-- <$> bracket tests
yes = (foo . bar x) <$> baz q -- foo . bar x <$> baz q
no = foo . bar x <$> baz q
-- annotations
main = 1; {-# ANN module ("HLint: ignore Use camelCase" :: String) #-}
main = 1; {-# ANN module (1 + (2)) #-} -- 2
-- special case from esqueleto, see #224
main = operate <$> (select $ from $ \user -> return $ user ^. UserEmail)
-- unknown fixity, see #426
bad x = x . (x +? x . x)
-- special case people don't like to warn on
special = foo $ f{x=1}
special = foo $ Rec{x=1}
special = foo (f{x=1})
loadCradleOnlyonce = skipManyTill anyMessage (message @PublishDiagnosticsNotification)
-}
module Hint.Bracket(bracketHint) where
import Hint.Type(DeclHint,Idea(..),rawIdea,warn,suggest,Severity(..),toRefactSrcSpan,toSS)
import Data.Data
import Data.List.Extra
import Data.Generics.Uniplate.DataOnly
import Refact.Types
import GHC.Hs
import Outputable
import SrcLoc
import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
bracketHint :: DeclHint
bracketHint _ _ x =
concatMap (\x -> bracket prettyExpr isPartialAtom True x ++ dollar x) (childrenBi (descendBi annotations x) :: [LHsExpr GhcPs]) ++
concatMap (bracket unsafePrettyPrint (const False) False) (childrenBi x :: [LHsType GhcPs]) ++
concatMap (bracket unsafePrettyPrint (const False) False) (childrenBi x :: [LPat GhcPs]) ++
concatMap fieldDecl (childrenBi x)
where
-- Brackets the roots of annotations are fine, so we strip them.
annotations :: AnnDecl GhcPs -> AnnDecl GhcPs
annotations= descendBi $ \x -> case (x :: LHsExpr GhcPs) of
L l (HsPar _ x) -> x
x -> x
-- If we find ourselves in the context of a section and we want to
-- issue a warning that a child therein has unneccessary brackets,
-- we'd rather report 'Found : (`Foo` (Bar Baz))' rather than 'Found :
-- `Foo` (Bar Baz)'. If left to 'unsafePrettyPrint' we'd get the
-- latter (in contrast to the HSE pretty printer). This patches things
-- up.
prettyExpr :: LHsExpr GhcPs -> String
prettyExpr s@(L _ SectionL{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs)
prettyExpr s@(L _ SectionR{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs)
prettyExpr x = unsafePrettyPrint x
-- Dirty, should add to Brackets type class I think
tyConToRtype :: String -> RType
tyConToRtype "Exp" = Expr
tyConToRtype "Type" = Type
tyConToRtype "HsType" = Type
tyConToRtype "Pat" = Pattern
tyConToRtype _ = Expr
findType :: (Data a) => a -> RType
findType = tyConToRtype . dataTypeName . dataTypeOf
-- 'Just _' if at least one set of parens were removed. 'Nothing' if
-- zero parens were removed.
remParens' :: Brackets a => a -> Maybe a
remParens' = fmap go . remParen
where
go e = maybe e go (remParen e)
isPartialAtom :: LHsExpr GhcPs -> Bool
-- Might be '$x', which was really '$ x', but TH enabled misparsed it.
isPartialAtom (L _ (HsSpliceE _ (HsTypedSplice _ HasDollar _ _) )) = True
isPartialAtom (L _ (HsSpliceE _ (HsUntypedSplice _ HasDollar _ _) )) = True
isPartialAtom x = isRecConstr x || isRecUpdate x
bracket :: forall a . (Data a, Data (SrcSpanLess a), HasSrcSpan a, Outputable a, Brackets a) => (a -> String) -> (a -> Bool) -> Bool -> a -> [Idea]
bracket pretty isPartialAtom root = f Nothing
where
msg = "Redundant bracket"
-- 'f' is a (generic) function over types in 'Brackets
-- (expressions, patterns and types). Arguments are, 'f (Maybe
-- (index, parent, gen)) child'.
f :: (HasSrcSpan a, Data a, Outputable a, Brackets a) => Maybe (Int, a , a -> a) -> a -> [Idea]
-- No context. Removing parentheses from 'x' succeeds?
f Nothing o@(remParens' -> Just x)
-- If at the root, or 'x' is an atom, 'x' parens are redundant.
| root || isAtom x
, not $ isPartialAtom x =
(if isAtom x then bracketError else bracketWarning) msg o x : g x
-- In some context, removing parentheses from 'x' succeeds and 'x'
-- is atomic?
f Just{} o@(remParens' -> Just x)
| isAtom x
, not $ isPartialAtom x =
bracketError msg o x : g x
-- In some context, removing parentheses from 'x' succeeds. Does
-- 'x' actually need bracketing in this context?
f (Just (i, o, gen)) v@(remParens' -> Just x)
| not $ needBracket i o x, not $ isPartialAtom x =
rawIdea Suggestion msg (getLoc v) (pretty o) (Just (pretty (gen x))) [] [r] : g x
where
typ = findType (unLoc v)
r = Replace typ (toSS v) [("x", toSS x)] "x"
-- Regardless of the context, there are no parentheses to remove
-- from 'x'.
f _ x = g x
g :: (HasSrcSpan a, Data a, Outputable a, Brackets a) => a -> [Idea]
-- Enumerate over all the immediate children of 'o' looking for
-- redundant parentheses in each.
g o = concat [f (Just (i, o, gen)) x | (i, (x, gen)) <- zipFrom 0 $ holes o]
bracketWarning :: (HasSrcSpan a, HasSrcSpan b, Data (SrcSpanLess b), Outputable a, Outputable b) => String -> a -> b -> Idea
bracketWarning msg o x =
suggest msg o x [Replace (findType (unLoc x)) (toSS o) [("x", toSS x)] "x"]
bracketError :: (HasSrcSpan a, HasSrcSpan b, Data (SrcSpanLess b), Outputable a, Outputable b ) => String -> a -> b -> Idea
bracketError msg o x =
warn msg o x [Replace (findType (unLoc x)) (toSS o) [("x", toSS x)] "x"]
fieldDecl :: LConDeclField GhcPs -> [Idea]
fieldDecl o@(L loc f@ConDeclField{cd_fld_type=v@(L l (HsParTy _ c))}) =
let r = L loc (f{cd_fld_type=c}) :: LConDeclField GhcPs in
[rawIdea Suggestion "Redundant bracket" l
(showSDocUnsafe $ ppr_fld o) -- Note this custom printer!
(Just (showSDocUnsafe $ ppr_fld r))
[]
[Replace Type (toSS v) [("x", toSS c)] "x"]]
where
-- If we call 'unsafePrettyPrint' on a field decl, we won't like
-- the output (e.g. "[foo, bar] :: T"). Here we use a custom
-- printer to work around (snarfed from
-- https://hackage.haskell.org/package/ghc-lib-parser-8.8.1/docs/src/HsTypes.html#pprConDeclFields).
ppr_fld (L _ ConDeclField { cd_fld_names = ns, cd_fld_type = ty, cd_fld_doc = doc })
= ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
ppr_fld (L _ (XConDeclField x)) = ppr x
ppr_names [n] = ppr n
ppr_names ns = sep (punctuate comma (map ppr ns))
fieldDecl _ = []
-- This function relies heavily on fixities having been applied to the
-- raw parse tree.
dollar :: LHsExpr GhcPs -> [Idea]
dollar = concatMap f . universe
where
f x = [ (suggest "Redundant $" x y [r]){ideaSpan = getLoc d} | o@(L _ (OpApp _ a d b)) <- [x], isDol d
, let y = noLoc (HsApp noExtField a b) :: LHsExpr GhcPs
, not $ needBracket 0 y a
, not $ needBracket 1 y b
, not $ isPartialAtom b
, let r = Replace Expr (toSS x) [("a", toSS a), ("b", toSS b)] "a b"]
++
[ suggest "Move brackets to avoid $" x (t y) [r]
|(t, e@(L _ (HsPar _ (L _ (OpApp _ a1 op1 a2))))) <- splitInfix x
, isDol op1
, isVar a1 || isApp a1 || isPar a1, not $ isAtom a2
, varToStr a1 /= "select" -- special case for esqueleto, see #224
, let y = noLoc $ HsApp noExtField a1 (noLoc (HsPar noExtField a2))
, let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ]
++ -- Special case of (v1 . v2) <$> v3
[ (suggest "Redundant bracket" x y [r]){ideaSpan = locPar}
| L _ (OpApp _ (L locPar (HsPar _ o1@(L locNoPar (OpApp _ v1 (isDot -> True) v2)))) o2 v3) <- [x], varToStr o2 == "<$>"
, let y = noLoc (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs
, let r = Replace Expr (toRefactSrcSpan locPar) [("a", toRefactSrcSpan locNoPar)] "a"]
++
[ suggest "Redundant section" x y []
| L _ (HsApp _ (L _ (HsPar _ (L _ (SectionL _ a b)))) c) <- [x]
-- , error $ show (unsafePrettyPrint a, gshow b, unsafePrettyPrint c)
, let y = noLoc $ OpApp noExtField a b c :: LHsExpr GhcPs]
splitInfix :: LHsExpr GhcPs -> [(LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)]
splitInfix (L l (OpApp _ lhs op rhs)) =
[(L l . OpApp noExtField lhs op, rhs), (\lhs -> L l (OpApp noExtField lhs op rhs), lhs)]
splitInfix _ = []
hlint-3.1.6/src/Hint/All.hs 0000644 0000000 0000000 00000005060 13661521317 013570 0 ustar 00 0000000 0000000
module Hint.All(
Hint(..), ModuHint,
resolveHints, hintRules, builtinHints
) where
import Data.Monoid
import Config.Type
import Data.Either
import Data.List.Extra
import Hint.Type
import Timing
import Util
import Prelude
import Hint.Match
import Hint.List
import Hint.ListRec
import Hint.Monad
import Hint.Lambda
import Hint.Bracket
import Hint.Naming
import Hint.Pattern
import Hint.Import
import Hint.Export
import Hint.Pragma
import Hint.Restrict
import Hint.Extensions
import Hint.Duplicate
import Hint.Comment
import Hint.Unsafe
import Hint.NewType
import Hint.Smell
-- | A list of the builtin hints wired into HLint.
-- This list is likely to grow over time.
data HintBuiltin =
HintList | HintListRec | HintMonad | HintLambda |
HintBracket | HintNaming | HintPattern | HintImport | HintExport |
HintPragma | HintExtensions | HintUnsafe | HintDuplicate | HintRestrict |
HintComment | HintNewType | HintSmell
deriving (Show,Eq,Ord,Bounded,Enum)
builtin :: HintBuiltin -> Hint
builtin x = case x of
-- Ghc.
HintLambda -> decl lambdaHint
HintImport -> modu importHint
HintExport -> modu exportHint
HintComment -> modu commentHint
HintPragma -> modu pragmaHint
HintDuplicate -> mods duplicateHint
HintRestrict -> mempty{hintModule=restrictHint}
HintList -> decl listHint
HintNewType -> decl newtypeHint
HintUnsafe -> decl unsafeHint
HintListRec -> decl listRecHint
HintNaming -> decl namingHint
HintBracket -> decl bracketHint
HintSmell -> mempty{hintDecl=smellHint,hintModule=smellModuleHint}
HintPattern -> decl patternHint
HintMonad -> decl monadHint
HintExtensions -> modu extensionsHint
where
wrap = timed "Hint" (drop 4 $ show x) . forceList
decl f = mempty{hintDecl=const $ \a b c -> wrap $ f a b c}
modu f = mempty{hintModule=const $ \a b -> wrap $ f a b}
mods f = mempty{hintModules=const $ \a -> wrap $ f a}
-- | A list of builtin hints, currently including entries such as @\"List\"@ and @\"Bracket\"@.
builtinHints :: [(String, Hint)]
builtinHints = [(drop 4 $ show h, builtin h) | h <- enumerate]
-- | Transform a list of 'HintBuiltin' or 'HintRule' into a 'Hint'.
resolveHints :: [Either HintBuiltin HintRule] -> Hint
resolveHints xs =
mconcat $ mempty{hintDecl=const $ readMatch rights} : map builtin (nubOrd lefts)
where (lefts,rights) = partitionEithers xs
-- | Transform a list of 'HintRule' into a 'Hint'.
hintRules :: [HintRule] -> Hint
hintRules = resolveHints . map Right
hlint-3.1.6/src/GHC/ 0000755 0000000 0000000 00000000000 13674744765 012244 5 ustar 00 0000000 0000000 hlint-3.1.6/src/GHC/Util.hs 0000644 0000000 0000000 00000005312 13671470061 013474 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.Util (
module GHC.Util.View
, module GHC.Util.FreeVars
, module GHC.Util.ApiAnnotation
, module GHC.Util.HsDecl
, module GHC.Util.HsExpr
, module GHC.Util.SrcLoc
, module GHC.Util.DynFlags
, module GHC.Util.Scope
, module GHC.Util.Unify
, parsePragmasIntoDynFlags
, fileToModule
, pattern SrcSpan, srcSpanFilename, srcSpanStartLine', srcSpanStartColumn, srcSpanEndLine', srcSpanEndColumn
, pattern SrcLoc, srcFilename, srcLine, srcColumn
, showSrcSpan,
) where
import GHC.Util.View
import GHC.Util.FreeVars
import GHC.Util.ApiAnnotation
import GHC.Util.HsExpr
import GHC.Util.HsDecl
import GHC.Util.SrcLoc
import GHC.Util.DynFlags
import GHC.Util.Scope
import GHC.Util.Unify
import Language.Haskell.GhclibParserEx.GHC.Parser (parseFile)
import Language.Haskell.GhclibParserEx.GHC.Driver.Session (parsePragmasIntoDynFlags)
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import GHC.Hs
import Lexer
import SrcLoc
import DynFlags
import FastString
import System.FilePath
import Language.Preprocessor.Unlit
fileToModule :: FilePath -> String -> DynFlags -> ParseResult (Located (HsModule GhcPs))
fileToModule filename str flags =
parseFile filename flags
(if takeExtension filename /= ".lhs" then str else unlit filename str)
{-# COMPLETE SrcSpan #-}
-- | The \"Line'\" thing is because there is already e.g. 'SrcLoc.srcSpanStartLine'
pattern SrcSpan :: String -> Int -> Int -> Int -> Int -> SrcSpan
pattern SrcSpan
{ srcSpanFilename
, srcSpanStartLine'
, srcSpanStartColumn
, srcSpanEndLine'
, srcSpanEndColumn
}
<-
(toOldeSpan ->
( srcSpanFilename
, srcSpanStartLine'
, srcSpanStartColumn
, srcSpanEndLine'
, srcSpanEndColumn
))
toOldeSpan :: SrcSpan -> (String, Int, Int, Int, Int)
toOldeSpan (RealSrcSpan span) =
( unpackFS $ srcSpanFile span
, srcSpanStartLine span
, srcSpanStartCol span
, srcSpanEndLine span
, srcSpanEndCol span
)
-- TODO: the bad locations are all (-1) right now
-- is this fine? it should be, since noLoc from HSE previously also used (-1) as an invalid location
toOldeSpan (UnhelpfulSpan str) =
( unpackFS str
, -1
, -1
, -1
, -1
)
{-# COMPLETE SrcLoc #-}
pattern SrcLoc :: String -> Int -> Int -> SrcLoc
pattern SrcLoc
{ srcFilename
, srcLine
, srcColumn
}
<-
(toOldeLoc ->
( srcFilename
, srcLine
, srcColumn
))
toOldeLoc :: SrcLoc -> (String, Int, Int)
toOldeLoc (RealSrcLoc loc) =
( unpackFS $ srcLocFile loc
, srcLocLine loc
, srcLocCol loc
)
toOldeLoc (UnhelpfulLoc str) =
( unpackFS str
, -1
, -1
)
showSrcSpan :: SrcSpan -> String
showSrcSpan = unsafePrettyPrint
hlint-3.1.6/src/GHC/All.hs 0000644 0000000 0000000 00000021366 13671470061 013276 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.All(
CppFlags(..), ParseFlags(..), defaultParseFlags,
parseFlagsAddFixities, parseFlagsSetLanguage,
ParseError(..), ModuleEx(..),
parseModuleEx, createModuleEx, ghcComments,
parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,
) where
import Util
import Data.Char
import Data.List.Extra
import Timing
import Language.Preprocessor.Cpphs
import qualified Data.Map as Map
import System.IO.Extra
import Fixity
import Extension
import FastString
import GHC.Hs
import SrcLoc
import ErrUtils
import Outputable
import Lexer hiding (context)
import GHC.LanguageExtensions.Type
import ApiAnnotation
import DynFlags hiding (extensions)
import Bag
import Language.Haskell.GhclibParserEx.GHC.Parser
import Language.Haskell.GhclibParserEx.Fixity
import GHC.Util
-- | What C pre processor should be used.
data CppFlags
= NoCpp -- ^ No pre processing is done.
| CppSimple -- ^ Lines prefixed with @#@ are stripped.
| Cpphs CpphsOptions -- ^ The @cpphs@ library is used.
-- | Created with 'defaultParseFlags', used by 'parseModuleEx'.
data ParseFlags = ParseFlags
{cppFlags :: CppFlags -- ^ How the file is preprocessed (defaults to 'NoCpp').
,baseLanguage :: Maybe Language -- ^ Base language (e.g. Haskell98, Haskell2010), defaults to 'Nothing'.
,enabledExtensions :: [Extension] -- ^ List of extensions enabled for parsing, defaults to many non-conflicting extensions.
,disabledExtensions :: [Extension] -- ^ List of extensions disabled for parsing, usually empty.
,fixities :: [FixityInfo] -- ^ List of fixities to be aware of, defaults to those defined in @base@.
}
-- | Default value for 'ParseFlags'.
defaultParseFlags :: ParseFlags
defaultParseFlags = ParseFlags NoCpp Nothing defaultExtensions [] defaultFixities
-- | Given some fixities, add them to the existing fixities in 'ParseFlags'.
parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags
parseFlagsAddFixities fx x = x{fixities = fx ++ fixities x}
parseFlagsSetLanguage :: (Maybe Language, ([Extension], [Extension])) -> ParseFlags -> ParseFlags
parseFlagsSetLanguage (l, (es, ds)) x = x{baseLanguage = l, enabledExtensions = es, disabledExtensions = ds}
runCpp :: CppFlags -> FilePath -> String -> IO String
runCpp NoCpp _ x = pure x
runCpp CppSimple _ x = pure $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x]
runCpp (Cpphs o) file x = dropLine <$> runCpphs o file x
where
-- LINE pragmas always inserted when locations=True
dropLine (line1 -> (a,b)) | "{-# LINE " `isPrefixOf` a = b
dropLine x = x
---------------------------------------------------------------------
-- PARSING
-- | A parse error.
data ParseError = ParseError
{ parseErrorLocation :: SrcSpan -- ^ Location of the error.
, parseErrorMessage :: String -- ^ Message about the cause of the error.
, parseErrorContents :: String -- ^ Snippet of several lines (typically 5) including a @>@ character pointing at the faulty line.
}
-- | Result of 'parseModuleEx', representing a parsed module.
data ModuleEx = ModuleEx {
ghcModule :: Located (HsModule GhcPs)
, ghcAnnotations :: ApiAnns
}
-- | Extract a list of all of a parsed module's comments.
ghcComments :: ModuleEx -> [Located AnnotationComment]
ghcComments m = concat (Map.elems $ snd (ghcAnnotations m))
-- | The error handler invoked when GHC parsing has failed.
ghcFailOpParseModuleEx :: String
-> FilePath
-> String
-> (SrcSpan, ErrUtils.MsgDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx ppstr file str (loc, err) = do
let pe = case loc of
RealSrcSpan r -> context (srcSpanStartLine r) ppstr
_ -> ""
msg = Outputable.showSDoc baseDynFlags err
pure $ Left $ ParseError loc msg pe
-- GHC extensions to enable/disable given HSE parse flags.
ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags{enabledExtensions=es, disabledExtensions=ds}= (es, ds)
-- GHC fixities given HSE parse flags.
ghcFixitiesFromParseFlags :: ParseFlags -> [(String, Fixity)]
ghcFixitiesFromParseFlags = map toFixity . fixities
-- These next two functions get called frorm 'Config/Yaml.hs' for user
-- defined hint rules.
parseModeToFlags :: ParseFlags -> DynFlags
parseModeToFlags parseMode =
flip lang_set (baseLanguage parseMode) $ foldl' xopt_unset (foldl' xopt_set baseDynFlags enable) disable
where
(enable, disable) = ghcExtensionsFromParseFlags parseMode
parseExpGhcWithMode :: ParseFlags -> String -> ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode parseMode s =
let fixities = ghcFixitiesFromParseFlags parseMode
in case parseExpression s $ parseModeToFlags parseMode of
POk pst a -> POk pst $ applyFixities fixities a
f@PFailed{} -> f
parseImportDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LImportDecl GhcPs)
parseImportDeclGhcWithMode parseMode s =
parseImport s $ parseModeToFlags parseMode
parseDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LHsDecl GhcPs)
parseDeclGhcWithMode parseMode s =
let fixities = ghcFixitiesFromParseFlags parseMode
in case parseDeclaration s $ parseModeToFlags parseMode of
POk pst a -> POk pst $ applyFixities fixities a
f@PFailed{} -> f
-- | Create a 'ModuleEx' from GHC annotations and module tree. It
-- is assumed the incoming parse module has not been adjusted to
-- account for operator fixities (it uses the HLint default fixities).
createModuleEx :: ApiAnns -> Located (HsModule GhcPs) -> ModuleEx
createModuleEx anns ast =
ModuleEx (applyFixities (fixitiesFromModule ast ++ map toFixity defaultFixities) ast) anns
-- | 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.
--
-- Note that certain programs, e.g. @main = do@ successfully parse with GHC, but then
-- fail with an error in the renamer. These programs will return a successful parse.
parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx flags file str = timedIO "Parse" file $ do
str <- case str of
Just x -> pure x
Nothing | file == "-" -> getContentsUTF8
| otherwise -> readFileUTF8' file
str <- pure $ dropPrefix "\65279" str -- remove the BOM if it exists, see #130
ppstr <- runCpp (cppFlags flags) file str
let enableDisableExts = ghcExtensionsFromParseFlags flags
dynFlags <- parsePragmasIntoDynFlags baseDynFlags enableDisableExts file ppstr
case dynFlags of
Right ghcFlags -> do
ghcFlags <- pure $ lang_set ghcFlags $ baseLanguage flags
case fileToModule file ppstr ghcFlags of
POk s a -> do
let errs = bagToList . snd $ getMessages s ghcFlags
if not $ null errs then
handleParseFailure ghcFlags ppstr file str errs
else do
let anns =
( Map.fromListWith (++) $ annotations s
, Map.fromList ((noSrcSpan, comment_q s) : annotations_comments s)
)
let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags
pure $ Right (ModuleEx (applyFixities fixes a) anns)
PFailed s ->
handleParseFailure ghcFlags ppstr file str $ bagToList . snd $ getMessages s ghcFlags
Left msg -> do
-- Parsing GHC flags from dynamic pragmas in the source
-- has failed. When this happens, it's reported by
-- exception. It's impossible or at least fiddly getting a
-- location so we skip that for now. Synthesize a parse
-- error.
let loc = mkSrcLoc (mkFastString file) (1 :: Int) (1 :: Int)
pure $ Left (ParseError (mkSrcSpan loc loc) msg ppstr)
where
handleParseFailure ghcFlags ppstr file str errs =
let errMsg = head errs
loc = errMsgSpan errMsg
doc = formatErrDoc ghcFlags (errMsgDoc errMsg)
in ghcFailOpParseModuleEx ppstr file str (loc, doc)
-- | Given a line number, and some source code, put bird ticks around the appropriate bit.
context :: Int -> String -> String
context lineNo src =
unlines $ dropWhileEnd (all isSpace) $ dropWhile (all isSpace) $
zipWith (++) ticks $ take 5 $ drop (lineNo - 3) $ lines src ++ ["","","","",""]
where ticks = drop (3 - lineNo) [" "," ","> "," "," "]
hlint-3.1.6/src/GHC/Util/ 0000755 0000000 0000000 00000000000 13674744765 013161 5 ustar 00 0000000 0000000 hlint-3.1.6/src/GHC/Util/View.hs 0000644 0000000 0000000 00000004070 13661521317 014406 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, PatternSynonyms #-}
module GHC.Util.View (
fromParen
, View(..)
, Var_(Var_), PVar_(PVar_), PApp_(PApp_), App2(App2),LamConst1(LamConst1)
, pattern SimpleLambda
) where
import GHC.Hs
import SrcLoc
import BasicTypes
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
fromParen :: LHsExpr GhcPs -> LHsExpr GhcPs
fromParen (L _ (HsPar _ x)) = fromParen x
fromParen x = x
fromPParen :: LPat GhcPs -> LPat GhcPs
fromPParen (L _ (ParPat _ x)) = fromPParen x
fromPParen x = x
class View a b where
view :: a -> b
data Var_ = NoVar_ | Var_ String deriving Eq
data PVar_ = NoPVar_ | PVar_ String
data PApp_ = NoPApp_ | PApp_ String [LPat GhcPs]
data App2 = NoApp2 | App2 (LHsExpr GhcPs) (LHsExpr GhcPs) (LHsExpr GhcPs)
data LamConst1 = NoLamConst1 | LamConst1 (LHsExpr GhcPs)
instance View (LHsExpr GhcPs) LamConst1 where
view (fromParen -> (L _ (HsLam _ (MG _ (L _ [L _ (Match _ LambdaExpr [L _ WildPat {}]
(GRHSs _ [L _ (GRHS _ [] x)] (L _ (EmptyLocalBinds _))))]) FromSource)))) = LamConst1 x
view _ = NoLamConst1
instance View (LHsExpr GhcPs) Var_ where
view (fromParen -> (L _ (HsVar _ (rdrNameStr -> x)))) = Var_ x
view _ = NoVar_
instance View (LHsExpr GhcPs) App2 where
view (fromParen -> L _ (OpApp _ lhs op rhs)) = App2 op lhs rhs
view (fromParen -> L _ (HsApp _ (L _ (HsApp _ f x)) y)) = App2 f x y
view _ = NoApp2
instance View (Located (Pat GhcPs)) PVar_ where
view (fromPParen -> L _ (VarPat _ (L _ x))) = PVar_ $ occNameStr x
view _ = NoPVar_
instance View (Located (Pat GhcPs)) PApp_ where
view (fromPParen -> L _ (ConPatIn (L _ x) (PrefixCon args))) =
PApp_ (occNameStr x) args
view (fromPParen -> L _ (ConPatIn (L _ x) (InfixCon lhs rhs))) =
PApp_ (occNameStr x) [lhs, rhs]
view _ = NoPApp_
-- A lambda with no guards and no where clauses
pattern SimpleLambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
pattern SimpleLambda vs body <- L _ (HsLam _ (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] (L _ (EmptyLocalBinds _))))]) _))
hlint-3.1.6/src/GHC/Util/Unify.hs 0000644 0000000 0000000 00000025675 13674736166 014622 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables, TupleSections #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
module GHC.Util.Unify(
Subst, fromSubst,
validSubst, removeParens, substitute,
unifyExp
) where
import Control.Applicative
import Control.Monad
import Data.Generics.Uniplate.DataOnly
import Data.Char
import Data.Data
import Data.List.Extra
import Util
import GHC.Hs
import SrcLoc
import Outputable hiding ((<>))
import RdrName
import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import GHC.Util.HsExpr
import GHC.Util.View
import FastString
isUnifyVar :: String -> Bool
isUnifyVar [x] = x == '?' || isAlpha x
isUnifyVar [] = False
isUnifyVar xs = all (== '?') xs
---------------------------------------------------------------------
-- SUBSTITUTION DATA TYPE
-- A list of substitutions. A key may be duplicated, you need to call
-- 'check' to ensure the substitution is valid.
newtype Subst a = Subst [(String, a)]
deriving (Semigroup, Monoid, Functor)
-- Unpack the substitution.
fromSubst :: Subst a -> [(String, a)]
fromSubst (Subst xs) = xs
instance Outputable a => Show (Subst a) where
show (Subst xs) = unlines [a ++ " = " ++ unsafePrettyPrint b | (a,b) <- xs]
-- Check the unification is valid and simplify it.
validSubst :: (a -> a -> Bool) -> Subst a -> Maybe (Subst a)
validSubst eq = fmap Subst . mapM f . groupSort . fromSubst
where f (x, y : ys) | all (eq y) ys = Just (x, y)
f _ = Nothing
-- Remove unnecessary brackets from a Subst. The first argument is a list of unification variables
-- for which brackets should be removed from their substitutions.
removeParens :: [String] -> Subst (LHsExpr GhcPs) -> Subst (LHsExpr GhcPs)
removeParens noParens (Subst xs) = Subst $
map (\(x, y) -> if x `elem` noParens then (x, fromParen y) else (x, y)) xs
-- Peform a substition.
-- Returns (suggested replacement, refactor template), both with brackets added
-- as needed.
-- Example: (traverse foo (bar baz), traverse f (x))
substitute :: Subst (LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs)
substitute (Subst bind) = transformBracketOld exp . transformBi pat . transformBi typ
where
exp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
-- Variables.
exp (L _ (HsVar _ x)) = lookup (rdrNameStr x) bind
-- Operator applications.
exp (L loc (OpApp _ lhs (L _ (HsVar _ x)) rhs))
| Just y <- lookup (rdrNameStr x) bind = Just (cL loc (OpApp noExtField lhs y rhs))
-- Left sections.
exp (L loc (SectionL _ exp (L _ (HsVar _ x))))
| Just y <- lookup (rdrNameStr x) bind = Just (cL loc (SectionL noExtField exp y))
-- Right sections.
exp (L loc (SectionR _ (L _ (HsVar _ x)) exp))
| Just y <- lookup (rdrNameStr x) bind = Just (cL loc (SectionR noExtField y exp))
exp _ = Nothing
pat :: LPat GhcPs -> LPat GhcPs
-- Pattern variables.
pat (L _ (VarPat _ x))
| Just y@(L _ HsVar{}) <- lookup (rdrNameStr x) bind = strToPat $ varToStr y
pat x = x :: LPat GhcPs
typ :: LHsType GhcPs -> LHsType GhcPs
-- Type variables.
typ (L _ (HsTyVar _ _ x))
| Just (L _ (HsAppType _ _ (HsWC _ y))) <- lookup (rdrNameStr x) bind = y
typ x = x :: LHsType GhcPs
---------------------------------------------------------------------
-- UNIFICATION
type NameMatch = Located RdrName -> Located RdrName -> Bool
-- | Unification, obeys the property that if @unify a b = s@, then
-- @substitute s a = b@.
unify' :: Data a => NameMatch -> Bool -> a -> a -> Maybe (Subst (LHsExpr GhcPs))
unify' nm root x y
| Just (x, y) <- cast (x, y) = unifyExp' nm root x y
| Just (x, y) <- cast (x, y) = unifyPat' nm x y
| Just (x, y) <- cast (x, y) = unifyType' nm x y
| Just (x, y) <- cast (x, y) = if (x :: FastString) == y then Just mempty else Nothing
| Just (x :: SrcSpan) <- cast x = Just mempty
| otherwise = unifyDef' nm x y
unifyDef' :: Data a => NameMatch -> a -> a -> Maybe (Subst (LHsExpr GhcPs))
unifyDef' nm x y = fmap mconcat . sequence =<< gzip (unify' nm False) x y
unifyComposed' :: NameMatch
-> LHsExpr GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyComposed' nm x1 y11 dot y12 =
((, Just y11) <$> unifyExp' nm False x1 y12)
<|> case y12 of
(L _ (OpApp _ y121 dot' y122)) | isDot dot' ->
unifyComposed' nm x1 (noLoc (OpApp noExtField y11 dot y121)) dot' y122
_ -> Nothing
-- unifyExp handles the cases where both x and y are HsApp, or y is OpApp. Otherwise,
-- delegate to unifyExp'. These are the cases where we potentially need to call
-- unifyComposed' to handle left composition.
--
-- y is allowed to partially match x (the lhs of the hint), if y is a function application where
-- the function is a composition of functions. In this case the second component of the result is
-- the unmatched part of y, which will be attached to the rhs of the hint after substitution.
--
-- Example:
-- x = head (drop n x)
-- y = foo . bar . baz . head $ drop 2 xs
-- result = (Subst [(n, 2), (x, xs)], Just (foo . bar . baz))
unifyExp :: NameMatch -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-- Match wildcard operators.
unifyExp nm root (L _ (OpApp _ lhs1 (L _ (HsVar _ (rdrNameStr -> v))) rhs1))
(L _ (OpApp _ lhs2 (L _ (HsVar _ (rdrNameStr -> op2))) rhs2))
| isUnifyVar v =
(, Nothing) . (Subst [(v, strToVar op2)] <>) <$>
liftA2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2)
-- Options: match directly, and expand through '.'
unifyExp nm root x@(L _ (HsApp _ x1 x2)) (L _ (HsApp _ y1 y2)) =
((, Nothing) <$> liftA2 (<>) (unifyExp' nm False x1 y1) (unifyExp' nm False x2 y2)) <|> unifyComposed
where
-- Unify a function application where the function is a composition of functions.
unifyComposed
| (L _ (OpApp _ y11 dot y12)) <- fromParen y1, isDot dot =
if not root then
-- Attempt #1: rewrite '(fun1 . fun2) arg' as 'fun1 (fun2 arg)', and unify it with 'x'.
-- The guard ensures that you don't get duplicate matches because the matching engine
-- auto-generates hints in dot-form.
(, Nothing) <$> unifyExp' nm root x (noLoc (HsApp noExtField y11 (noLoc (HsApp noExtField y12 y2))))
else do
-- Attempt #2: rewrite '(fun1 . fun2 ... funn) arg' as 'fun1 $ (fun2 ... funn) arg',
-- 'fun1 . fun2 $ (fun3 ... funn) arg', 'fun1 . fun2 . fun3 $ (fun4 ... funn) arg',
-- and so on, unify the rhs of '$' with 'x', and store the lhs of '$' into 'extra'.
-- You can only add to extra if you are at the root (otherwise 'extra' has nowhere to go).
rhs <- unifyExp' nm False x2 y2
(lhs, extra) <- unifyComposed' nm x1 y11 dot y12
pure (lhs <> rhs, extra)
| otherwise = Nothing
-- Options: match directly, then expand through '$', then desugar infix.
unifyExp nm root x (L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2))
| (L _ (OpApp _ lhs1 op1@(L _ (HsVar _ op1')) rhs1)) <- x =
guard (nm op1' op2') >> (, Nothing) <$> liftA2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2)
| isDol op2 = unifyExp nm root x $ noLoc (HsApp noExtField lhs2 rhs2)
| otherwise = unifyExp nm root x $ noLoc (HsApp noExtField (noLoc (HsApp noExtField op2 (addPar lhs2))) (addPar rhs2))
where
-- add parens around when desugaring the expression, if necessary
addPar :: LHsExpr GhcPs -> LHsExpr GhcPs
addPar x = if isAtom x then x else addParen x
unifyExp nm root x y = (, Nothing) <$> unifyExp' nm root x y
-- | If we "throw away" the extra than we have no where to put it, and the substitution is wrong
noExtra :: Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)) -> Maybe (Subst (LHsExpr GhcPs))
noExtra (Just (x, Nothing)) = Just x
noExtra _ = Nothing
-- App/InfixApp are analysed specially for performance reasons. If
-- 'root = True', this is the outside of the expr. Do not expand out a
-- dot at the root, since otherwise you get two matches because of
-- 'readRule' (Bug #570).
unifyExp' :: NameMatch -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst (LHsExpr GhcPs))
-- Brackets are not added when expanding '$' in user code, so tolerate
-- them in the match even if they aren't in the user code.
unifyExp' nm root x y | not root, isPar x, not $ isPar y = unifyExp' nm root (fromParen x) y
-- Don't subsitute for type apps, since no one writes rules imagining
-- they exist.
unifyExp' nm root (L _ (HsVar _ (rdrNameStr -> v))) y | isUnifyVar v, not $ isTypeApp y = Just $ Subst [(v, y)]
unifyExp' nm root (L _ (HsVar _ x)) (L _ (HsVar _ y)) | nm x y = Just mempty
unifyExp' nm root x@(L _ (OpApp _ lhs1 (L _ (HsVar _ (rdrNameStr -> v))) rhs1))
y@(L _ (OpApp _ lhs2 (L _ (HsVar _ op2)) rhs2)) =
noExtra $ unifyExp nm root x y
unifyExp' nm root (L _ (SectionL _ exp1 (L _ (HsVar _ (rdrNameStr -> v)))))
(L _ (SectionL _ exp2 (L _ (HsVar _ (rdrNameStr -> op2)))))
| isUnifyVar v = (Subst [(v, strToVar op2)] <>) <$> unifyExp' nm False exp1 exp2
unifyExp' nm root (L _ (SectionR _ (L _ (HsVar _ (rdrNameStr -> v))) exp1))
(L _ (SectionR _ (L _ (HsVar _ (rdrNameStr -> op2))) exp2))
| isUnifyVar v = (Subst [(v, strToVar op2)] <>) <$> unifyExp' nm False exp1 exp2
unifyExp' nm root x@(L _ (HsApp _ x1 x2)) y@(L _ (HsApp _ y1 y2)) =
noExtra $ unifyExp nm root x y
unifyExp' nm root x y@(L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2)) =
noExtra $ unifyExp nm root x y
unifyExp' nm root x y | isOther x, isOther y = unifyDef' nm x y
where
-- Types that are not already handled in unify.
{-# INLINE isOther #-}
isOther :: LHsExpr GhcPs -> Bool
isOther (L _ HsVar{}) = False
isOther (L _ HsApp{}) = False
isOther (L _ OpApp{}) = False
isOther _ = True
unifyExp' _ _ _ _ = Nothing
unifyPat' :: NameMatch -> LPat GhcPs -> LPat GhcPs -> Maybe (Subst (LHsExpr GhcPs))
unifyPat' nm (L _ (VarPat _ x)) (L _ (VarPat _ y)) =
Just $ Subst [(rdrNameStr x, strToVar(rdrNameStr y))]
unifyPat' nm (L _ (VarPat _ x)) (L _ (WildPat _)) =
let s = rdrNameStr x in Just $ Subst [(s, strToVar("_" ++ s))]
unifyPat' nm (L _ (ConPatIn x _)) (L _ (ConPatIn y _)) | rdrNameStr x /= rdrNameStr y =
Nothing
unifyPat' nm x y =
unifyDef' nm x y
unifyType' :: NameMatch -> LHsType GhcPs -> LHsType GhcPs -> Maybe (Subst (LHsExpr GhcPs))
unifyType' nm (L loc (HsTyVar _ _ x)) y =
let wc = HsWC noExtField y :: LHsWcType (NoGhcTc GhcPs)
unused = strToVar "__unused__" :: LHsExpr GhcPs
appType = cL loc (HsAppType noExtField unused wc) :: LHsExpr GhcPs
in Just $ Subst [(rdrNameStr x, appType)]
unifyType' nm x y = unifyDef' nm x y
hlint-3.1.6/src/GHC/Util/SrcLoc.hs 0000644 0000000 0000000 00000001113 13671470061 014654 0 ustar 00 0000000 0000000 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
module GHC.Util.SrcLoc (
stripLocs
, SrcSpanD(..)
) where
import SrcLoc
import Outputable
import Data.Default
import Data.Data
import Data.Generics.Uniplate.DataOnly
-- 'stripLocs x' is 'x' with all contained source locs replaced by
-- 'noSrcSpan'.
stripLocs :: (Data from, HasSrcSpan from) => from -> from
stripLocs = transformBi (const noSrcSpan)
-- 'Duplicates.hs' requires 'SrcSpan' be in 'Default'.
newtype SrcSpanD = SrcSpanD SrcSpan
deriving (Outputable, Eq, Ord)
instance Default SrcSpanD where def = SrcSpanD noSrcSpan
hlint-3.1.6/src/GHC/Util/Scope.hs 0000644 0000000 0000000 00000010736 13671470061 014553 0 ustar 00 0000000 0000000
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module GHC.Util.Scope (
Scope
,scopeCreate,scopeMatch,scopeMove,possModules
) where
import GHC.Hs
import SrcLoc
import BasicTypes
import Module
import FastString
import RdrName
import OccName
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Data.List.Extra
import Data.Maybe
-- A scope is a list of import declarations.
newtype Scope = Scope [LImportDecl GhcPs]
deriving (Monoid, Semigroup)
instance Show Scope where
show (Scope x) = unsafePrettyPrint x
-- Create a 'Scope from a module's import declarations.
scopeCreate :: HsModule GhcPs -> Scope
scopeCreate xs = Scope $ [prelude | not $ any isPrelude res] ++ res
where
-- Package qualifier of an import declaration.
pkg :: LImportDecl GhcPs -> Maybe StringLiteral
pkg (L _ x) = ideclPkgQual x
-- The import declaraions contained by the module 'xs'.
res :: [LImportDecl GhcPs]
res = [x | x <- hsmodImports xs , pkg x /= Just (StringLiteral NoSourceText (fsLit "hint"))]
-- Mock up an import declaraion corresponding to 'import Prelude'.
prelude :: LImportDecl GhcPs
prelude = noLoc $ simpleImportDecl (mkModuleName "Prelude")
-- Predicate to test for a 'Prelude' import declaration.
isPrelude :: LImportDecl GhcPs -> Bool
isPrelude (L _ x) = moduleNameString (unLoc (ideclName x)) == "Prelude"
-- Test if two names in two scopes may be referring to the same
-- thing. This is the case if the names are equal and (1) denote a
-- builtin type or data constructor or (2) the intersection of the
-- candidate modules where the two names arise is non-empty.
scopeMatch :: (Scope, Located RdrName) -> (Scope, Located RdrName) -> Bool
scopeMatch (a, x) (b, y)
| isSpecial x && isSpecial y = rdrNameStr x == rdrNameStr y
| isSpecial x || isSpecial y = False
| otherwise =
rdrNameStr (unqual x) == rdrNameStr (unqual y) && not (possModules a x `disjointOrd` possModules b y)
-- Given a name in a scope, and a new scope, create a name for the new
-- scope that will refer to the same thing. If the resulting name is
-- ambiguous, pick a plausible candidate.
scopeMove :: (Scope, Located RdrName) -> Scope -> Located RdrName
scopeMove (a, x@(fromQual -> Just name)) (Scope b) = case imps of
[] -> headDef x real
imp:_ | all (\x -> ideclQualified x /= NotQualified) imps -> noLoc $ mkRdrQual (unLoc . fromMaybe (ideclName imp) $ firstJust ideclAs imps) name
| otherwise -> unqual x
where
real :: [Located RdrName]
real = [noLoc $ mkRdrQual m name | m <- possModules a x]
imps :: [ImportDecl GhcPs]
imps = [unLoc i | r <- real, i <- b, possImport i r]
scopeMove (_, x) _ = x
-- Calculate which modules a name could possibly lie in. If 'x' is
-- qualified but no imported element matches it, assume the user just
-- lacks an import.
possModules :: Scope -> Located RdrName -> [ModuleName]
possModules (Scope is) x = f x
where
res :: [ModuleName]
res = [unLoc $ ideclName $ unLoc i | i <- is, possImport i x]
f :: Located RdrName -> [ModuleName]
f n | isSpecial n = [mkModuleName ""]
f (L _ (Qual mod _)) = [mod | null res] ++ res
f _ = res
-- Determine if 'x' could possibly lie in the module named by the
-- import declaration 'i'.
possImport :: LImportDecl GhcPs -> Located RdrName -> Bool
possImport i n | isSpecial n = False
possImport (L _ i) (L _ (Qual mod x)) =
mod `elem` ms && possImport (noLoc i{ideclQualified=NotQualified}) (noLoc $ mkRdrUnqual x)
where ms = map unLoc $ ideclName i : maybeToList (ideclAs i)
possImport (L _ i) (L _ (Unqual x)) = ideclQualified i == NotQualified && maybe True f (ideclHiding i)
where
f :: (Bool, Located [LIE GhcPs]) -> Bool
f (hide, L _ xs) =
if hide then
Just True `notElem` ms
else
Nothing `elem` ms || Just True `elem` ms
where ms = map g xs
tag :: String
tag = occNameString x
g :: LIE GhcPs -> Maybe Bool -- Does this import cover the name 'x'?
g (L _ (IEVar _ y)) = Just $ tag == unwrapName y
g (L _ (IEThingAbs _ y)) = Just $ tag == unwrapName y
g (L _ (IEThingAll _ y)) = if tag == unwrapName y then Just True else Nothing
g (L _ (IEThingWith _ y _wildcard ys _fields)) = Just $ tag `elem` unwrapName y : map unwrapName ys
g _ = Just False
unwrapName :: LIEWrappedName RdrName -> String
unwrapName x = occNameString (rdrNameOcc $ ieWrappedName (unLoc x))
possImport _ _ = False
hlint-3.1.6/src/GHC/Util/HsExpr.hs 0000644 0000000 0000000 00000030623 13671470061 014710 0 ustar 00 0000000 0000000 {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module GHC.Util.HsExpr (
dotApps, lambda
, simplifyExp, niceLambda, niceLambdaR
, Brackets(..)
, rebracket1, appsBracket, transformAppsM, fromApps, apps, universeApps, universeParentExp
, paren
, replaceBranches
, needBracketOld, transformBracketOld, fromParen1
, allowLeftSection, allowRightSection
) where
import GHC.Hs
import BasicTypes
import SrcLoc
import FastString
import RdrName
import OccName
import Bag(bagToList)
import GHC.Util.Brackets
import GHC.Util.FreeVars
import GHC.Util.View
import Control.Applicative
import Control.Monad.Trans.State
import Data.Data
import Data.Generics.Uniplate.DataOnly
import Data.List.Extra
import Data.Tuple.Extra
import Refact (toSS)
import Refact.Types hiding (SrcSpan, Match)
import qualified Refact.Types as R (SrcSpan)
import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
-- | 'dotApp a b' makes 'a . b'.
dotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
dotApp x y = noLoc $ OpApp noExtField x (noLoc $ HsVar noExtField (noLoc $ mkVarUnqual (fsLit "."))) y
dotApps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps [] = error "GHC.Util.HsExpr.dotApps', does not work on an empty list"
dotApps [x] = x
dotApps (x : xs) = dotApp x (dotApps xs)
-- | @lambda [p0, p1..pn] body@ makes @\p1 p1 .. pn -> body@
lambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda vs body = noLoc $ HsLam noExtField (MG noExtField (noLoc [noLoc $ Match noExtField LambdaExpr vs (GRHSs noExtField [noLoc $ GRHS noExtField [] body] (noLoc $ EmptyLocalBinds noExtField))]) Generated)
-- | 'paren e' wraps 'e' in parens if 'e' is non-atomic.
paren :: LHsExpr GhcPs -> LHsExpr GhcPs
paren x
| isAtom x = x
| otherwise = addParen x
universeParentExp :: Data a => a -> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)]
universeParentExp xs = concat [(Nothing, x) : f x | x <- childrenBi xs]
where f p = concat [(Just (i,p), c) : f c | (i,c) <- zipFrom 0 $ children p]
apps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
apps = foldl1' mkApp where mkApp x y = noLoc (HsApp noExtField x y)
fromApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps (L _ (HsApp _ x y)) = fromApps x ++ [y]
fromApps x = [x]
childrenApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
childrenApps (L _ (HsApp _ x y)) = childrenApps x ++ [y]
childrenApps x = children x
universeApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
universeApps x = x : concatMap universeApps (childrenApps x)
descendAppsM :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
descendAppsM f (L l (HsApp _ x y)) = liftA2 (\x y -> L l $ HsApp noExtField x y) (descendAppsM f x) (f y)
descendAppsM f x = descendM f x
transformAppsM :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
transformAppsM f x = f =<< descendAppsM (transformAppsM f) x
descendIndex :: Data a => (Int -> a -> a) -> a -> a
descendIndex f x = flip evalState 0 $ flip descendM x $ \y -> do
i <- get
modify (+1)
pure $ f i y
-- There are differences in pretty-printing between GHC and HSE. This
-- version never removes brackets.
descendBracket :: (LHsExpr GhcPs -> (Bool, LHsExpr GhcPs)) -> LHsExpr GhcPs -> LHsExpr GhcPs
descendBracket op x = descendIndex g x
where
g i y = if a then f i b else b
where (a, b) = op y
f i y@(L _ e) | needBracket i x y = addParen y
f _ y = y
-- Add brackets as suggested 'needBracket at 1-level of depth.
rebracket1 :: LHsExpr GhcPs -> LHsExpr GhcPs
rebracket1 = descendBracket (True, )
-- A list of application, with any necessary brackets.
appsBracket :: [LHsExpr GhcPs] -> LHsExpr GhcPs
appsBracket = foldl1 mkApp
where mkApp x y = rebracket1 (noLoc $ HsApp noExtField x y)
simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs
-- Replace appliciations 'f $ x' with 'f (x)'.
simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (noLoc (HsPar noExtField y)))
simplifyExp e@(L _ (HsLet _ (L _ (HsValBinds _ (ValBinds _ binds []))) z)) =
-- An expression of the form, 'let x = y in z'.
case bagToList binds of
[L _ (FunBind _ _(MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _) [] (GRHSs _[L _ (GRHS _ [] y)] (L _ (EmptyLocalBinds _))))]) _) _ _)]
-- If 'x' is not in the free variables of 'y', beta-reduce to
-- 'z[(y)/x]'.
| occNameStr x `notElem` vars y && length [() | Unqual a <- universeBi z, a == rdrNameOcc x] <= 1 ->
transform f z
where f (view -> Var_ x') | occNameStr x == x' = paren y
f x = x
_ -> e
simplifyExp e = e
-- Rewrite '($) . b' as 'b'.
niceDotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
niceDotApp (L _ (HsVar _ (L _ r))) b | occNameStr r == "$" = b
niceDotApp a b = dotApp a b
-- Generate a lambda expression but prettier if possible.
niceLambda :: [String] -> LHsExpr GhcPs -> LHsExpr GhcPs
niceLambda ss e = fst (niceLambdaR ss e)-- We don't support refactorings yet.
allowRightSection :: String -> Bool
allowRightSection x = x `notElem` ["-","#"]
allowLeftSection :: String -> Bool
allowLeftSection x = x /= "#"
-- Implementation. Try to produce special forms (e.g. sections,
-- compositions) where we can.
niceLambdaR :: [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, R.SrcSpan -> [Refactoring R.SrcSpan])
-- Rewrite @\ -> e@ as @e@
-- These are encountered as recursive calls.
niceLambdaR xs (SimpleLambda [] x) = niceLambdaR xs x
-- Rewrite @\xs -> (e)@ as @\xs -> e@.
niceLambdaR xs (L _ (HsPar _ x)) = niceLambdaR xs x
-- @\vs v -> ($) e v@ ==> @\vs -> e@
-- @\vs v -> e $ v@ ==> @\vs -> e@
niceLambdaR (unsnoc -> Just (vs, v)) (view -> App2 f e (view -> Var_ v'))
| isDol f
, v == v'
, vars e `disjoint` [v]
= niceLambdaR vs e
-- @\v -> thing + v@ ==> @\v -> (thing +)@ (heuristic: @v@ must be a single
-- lexeme, or it all gets too complex)
niceLambdaR [v] (L _ (OpApp _ e f (view -> Var_ v')))
| isLexeme e
, v == v'
, vars e `disjoint` [v]
, L _ (HsVar _ (L _ fname)) <- f
, isSymOcc $ rdrNameOcc fname
= let res = noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField e f
in (res, \s -> [Replace Expr s [] (unsafePrettyPrint res)])
-- @\vs v -> f x v@ ==> @\vs -> f x@
niceLambdaR (unsnoc -> Just (vs, v)) (L _ (HsApp _ f (view -> Var_ v')))
| v == v'
, vars f `disjoint` [v]
= niceLambdaR vs f
-- @\vs v -> (v `f`)@ ==> @\vs -> f@
niceLambdaR (unsnoc -> Just (vs, v)) (L _ (SectionL _ (view -> Var_ v') f))
| v == v' = niceLambdaR vs f
-- Strip one variable pattern from the end of a lambdas match, and place it in our list of factoring variables.
niceLambdaR xs (SimpleLambda ((view -> PVar_ v):vs) x)
| v `notElem` xs = niceLambdaR (xs++[v]) $ lambda vs x
-- Rewrite @\x -> x + a@ as @(+ a)@ (heuristic: @a@ must be a single
-- lexeme, or it all gets too complex).
niceLambdaR [x] (view -> App2 op@(L _ (HsVar _ (L _ tag))) l r)
| isLexeme r, view l == Var_ x, x `notElem` vars r, allowRightSection (occNameStr tag) =
let e = rebracket1 $ addParen (noLoc $ SectionR noExtField op r)
in (e, \s -> [Replace Expr s [] (unsafePrettyPrint e)])
-- Rewrite (1) @\x -> f (b x)@ as @f . b@, (2) @\x -> f $ b x@ as @f . b@.
niceLambdaR [x] y
| Just (z, subts) <- factor y, x `notElem` vars z = (z, \s -> [mkRefact subts s])
where
-- Factor the expression with respect to x.
factor :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
factor y@(L _ (HsApp _ ini lst)) | view lst == Var_ x = Just (ini, [ini])
factor y@(L _ (HsApp _ ini lst)) | Just (z, ss) <- factor lst
= let r = niceDotApp ini z
in if astEq r z then Just (r, ss) else Just (r, ini : ss)
factor (L _ (OpApp _ y op (factor -> Just (z, ss))))| isDol op
= let r = niceDotApp y z
in if astEq r z then Just (r, ss) else Just (r, y : ss)
factor (L _ (HsPar _ y@(L _ HsApp{}))) = factor y
factor _ = Nothing
mkRefact :: [LHsExpr GhcPs] -> R.SrcSpan -> Refactoring R.SrcSpan
mkRefact subts s =
let tempSubts = zipWith (\a b -> ([a], toSS b)) ['a' .. 'z'] subts
template = dotApps (map (strToVar . fst) tempSubts)
in Replace Expr s tempSubts (unsafePrettyPrint template)
-- Rewrite @\x y -> x + y@ as @(+)@.
niceLambdaR [x,y] (L _ (OpApp _ (view -> Var_ x1) op@(L _ HsVar {}) (view -> Var_ y1)))
| x == x1, y == y1, vars op `disjoint` [x, y] = (op, \s -> [Replace Expr s [] (unsafePrettyPrint op)])
-- Rewrite @\x y -> f y x@ as @flip f@.
niceLambdaR [x, y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1))
| x == x1, y == y1, vars op `disjoint` [x, y] =
( gen op
, \s -> [Replace Expr s [("x", toSS op)] (unsafePrettyPrint $ gen (strToVar "x"))]
)
where
gen = noLoc . HsApp noExtField (strToVar "flip")
-- We're done factoring, but have no variables left, so we shouldn't make a lambda.
-- @\ -> e@ ==> @e@
niceLambdaR [] e = (e, const [])
-- Base case. Just a good old fashioned lambda.
niceLambdaR ss e =
let grhs = noLoc $ GRHS noExtField [] e :: LGRHS GhcPs (LHsExpr GhcPs)
grhss = GRHSs {grhssExt = noExtField, grhssGRHSs=[grhs], grhssLocalBinds=noLoc $ EmptyLocalBinds noExtField}
match = noLoc $ Match {m_ext=noExtField, m_ctxt=LambdaExpr, m_pats=map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)
matchGroup = MG {mg_ext=noExtField, mg_origin=Generated, mg_alts=noLoc [match]}
in (noLoc $ HsLam noExtField matchGroup, const [])
-- 'case' and 'if' expressions have branches, nothing else does (this
-- doesn't consider 'HsMultiIf' perhaps it should?).
replaceBranches :: LHsExpr GhcPs -> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs)
replaceBranches (L l (HsIf _ _ a b c)) = ([b, c], \[b, c] -> cL l (HsIf noExtField Nothing a b c))
replaceBranches (L s (HsCase _ a (MG _ (L l bs) FromSource))) =
(concatMap f bs, \xs -> cL s (HsCase noExtField a (MG noExtField (cL l (g bs xs)) Generated)))
where
f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]
f (L _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (L _ (GRHS _ _ x)) <- xs]
f _ = error "GHC.Util.HsExpr.replaceBranches: unexpected XMatch"
g :: [LMatch GhcPs (LHsExpr GhcPs)] -> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)]
g (L s1 (Match _ CaseAlt a (GRHSs _ ns b)) : rest) xs =
cL s1 (Match noExtField CaseAlt a (GRHSs noExtField [cL a (GRHS noExtField gs x) | (L a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs
where (as, bs) = splitAt (length ns) xs
g [] [] = []
g _ _ = error "GHC.Util.HsExpr.replaceBranches': internal invariant failed, lists are of differing lengths"
replaceBranches x = ([], \[] -> x)
-- Like needBracket, but with a special case for 'a . b . b', which was
-- removed from haskell-src-exts-util-0.2.2.
needBracketOld :: Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
needBracketOld i parent child
| isDotApp parent, isDotApp child, i == 2 = False
| otherwise = needBracket i parent child
transformBracketOld :: (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)) -> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs)
transformBracketOld op = first snd . g
where
g = first f . descendBracketOld g
f x = maybe (False, x) (True, ) (op x)
-- Descend, and if something changes then add/remove brackets
-- appropriately. Returns (suggested replacement, refactor template).
-- Whenever a bracket is added to the suggested replacement, a
-- corresponding bracket is added to the refactor template.
descendBracketOld :: (LHsExpr GhcPs -> ((Bool, LHsExpr GhcPs), LHsExpr GhcPs))
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, LHsExpr GhcPs)
descendBracketOld op x = (descendIndex g1 x, descendIndex g2 x)
where
g i y = if a then (f1 i b z, f2 i b z) else (b, z)
where ((a, b), z) = op y
g1 = (fst .) . g
g2 = (snd .) . g
f i (L _ (HsPar _ y)) z
| not $ needBracketOld i x y = (y, z)
f i y z
| needBracketOld i x y = (addParen y, addParen z)
-- https://github.com/mpickering/apply-refact/issues/7
| isOp y = (y, addParen z)
f _ y z = (y, z)
f1 = ((fst .) .) . f
f2 = ((snd .) .) . f
isOp = \case
L _ (HsVar _ (L _ name)) -> isSymbolRdrName name
_ -> False
fromParen1 :: LHsExpr GhcPs -> LHsExpr GhcPs
fromParen1 (L _ (HsPar _ x)) = x
fromParen1 x = x
hlint-3.1.6/src/GHC/Util/HsDecl.hs 0000644 0000000 0000000 00000002742 13661521317 014642 0 ustar 00 0000000 0000000 {-# LANGUAGE NamedFieldPuns #-}
module GHC.Util.HsDecl (declName,bindName)
where
import GHC.Hs
import SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
-- | @declName x@ returns the \"new name\" that is created (for
-- example a function declaration) by @x@. If @x@ isn't a declaration
-- that creates a new name (for example an instance declaration),
-- 'Nothing' is returned instead. This is useful because we don't
-- want to tell users to rename binders that they aren't creating
-- right now and therefore usually cannot change.
declName :: LHsDecl GhcPs -> Maybe String
declName (L _ x) = occNameStr <$> case x of
TyClD _ FamDecl{tcdFam=FamilyDecl{fdLName}} -> Just $ unLoc fdLName
TyClD _ SynDecl{tcdLName} -> Just $ unLoc tcdLName
TyClD _ DataDecl{tcdLName} -> Just $ unLoc tcdLName
TyClD _ ClassDecl{tcdLName} -> Just $ unLoc tcdLName
ValD _ FunBind{fun_id} -> Just $ unLoc fun_id
ValD _ VarBind{var_id} -> Just var_id
ValD _ (PatSynBind _ PSB{psb_id}) -> Just $ unLoc psb_id
SigD _ (TypeSig _ (x:_) _) -> Just $ unLoc x
SigD _ (PatSynSig _ (x:_) _) -> Just $ unLoc x
SigD _ (ClassOpSig _ _ (x:_) _) -> Just $ unLoc x
ForD _ ForeignImport{fd_name} -> Just $ unLoc fd_name
ForD _ ForeignExport{fd_name} -> Just $ unLoc fd_name
_ -> Nothing
bindName :: LHsBind GhcPs -> Maybe String
bindName (L _ FunBind{fun_id}) = Just $ rdrNameStr fun_id
bindName (L _ VarBind{var_id}) = Just $ occNameStr var_id
bindName _ = Nothing
hlint-3.1.6/src/GHC/Util/FreeVars.hs 0000644 0000000 0000000 00000031644 13671470061 015220 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Util.FreeVars (
vars, varss, pvars,
Vars (..), FreeVars(..) , AllVars (..)
) where
import RdrName
import GHC.Hs.Types
import OccName
import Name
import GHC.Hs
import SrcLoc
import Bag (bagToList)
import Data.Generics.Uniplate.DataOnly
import Data.Monoid
import Data.Semigroup
import Data.List.Extra
import Data.Set (Set)
import qualified Data.Set as Set
import Prelude
( ^+ ) :: Set OccName -> Set OccName -> Set OccName
( ^+ ) = Set.union
( ^- ) :: Set OccName -> Set OccName -> Set OccName
( ^- ) = Set.difference
-- See [Note : Space leaks lurking here?] below.
data Vars = Vars{bound :: Set OccName, free :: Set OccName}
-- Useful for debugging.
instance Show Vars where
show (Vars bs fs) = "bound : " ++
show (map occNameString (Set.toList bs)) ++
", free : " ++ show (map occNameString (Set.toList fs))
instance Semigroup Vars where
Vars x1 x2 <> Vars y1 y2 = Vars (x1 ^+ y1) (x2 ^+ y2)
instance Monoid Vars where
mempty = Vars Set.empty Set.empty
mconcat vs = Vars (Set.unions $ map bound vs) (Set.unions $ map free vs)
-- A type `a` is a model of `AllVars a` if exists a function
-- `allVars` for producing a pair of the bound and free varaiable
-- sets in a value of `a`.
class AllVars a where
-- | Return the variables, erring on the side of more free
-- variables.
allVars :: a -> Vars
-- A type `a` is a model of `FreeVars a` if exists a function
-- `freeVars` for producing a set of free varaiable of a value of
-- `a`.
class FreeVars a where
-- | Return the variables, erring on the side of more free
-- variables.
freeVars :: a -> Set OccName
-- Trivial instances.
instance AllVars Vars where allVars = id
instance FreeVars (Set OccName) where freeVars = id
-- [Note : Space leaks lurking here?]
-- ==================================
-- We make use of `foldr`. @cocreature suggests we want bangs on `data
-- Vars` and replace usages of `mconcat` with `foldl`.
instance (AllVars a) => AllVars [a] where allVars = mconcatMap allVars
instance (FreeVars a) => FreeVars [a] where freeVars = Set.unions . map freeVars
-- Construct a `Vars` value with no bound vars.
freeVars_ :: (FreeVars a) => a -> Vars
freeVars_ = Vars Set.empty . freeVars
-- `inFree a b` is the set of free variables in a together with the
-- free variables in b not bound in a.
inFree :: (AllVars a, FreeVars b) => a -> b -> Set OccName
inFree a b = free aa ^+ (freeVars b ^- bound aa)
where aa = allVars a
-- `inVars a b` is a value of `Vars_` with bound variables the union
-- of the bound variables of a and b and free variables the union
-- of the free variables of a and the free variables of b not
-- bound by a.
inVars :: (AllVars a, AllVars b) => a -> b -> Vars
inVars a b =
Vars (bound aa ^+ bound bb) (free aa ^+ (free bb ^- bound aa))
where aa = allVars a
bb = allVars b
-- Get an `OccName` out of a reader name.
unqualNames :: Located RdrName -> [OccName]
unqualNames (L _ (Unqual x)) = [x]
unqualNames (L _ (Exact x)) = [nameOccName x]
unqualNames _ = []
instance FreeVars (LHsExpr GhcPs) where
freeVars (L _ (HsVar _ x)) = Set.fromList $ unqualNames x -- Variable.
freeVars (L _ (HsUnboundVar _ x)) = Set.fromList [unboundVarOcc x] -- Unbound variable; also used for "holes".
freeVars (L _ (HsLam _ mg)) = free (allVars mg) -- Lambda abstraction. Currently always a single match.
freeVars (L _ (HsLamCase _ MG{mg_alts=(L _ ms)})) = free (allVars ms) -- Lambda case
freeVars (L _ (HsCase _ of_ MG{mg_alts=(L _ ms)})) = freeVars of_ ^+ free (allVars ms) -- Case expr.
freeVars (L _ (HsLet _ binds e)) = inFree binds e -- Let (rec).
freeVars (L _ (HsDo _ ctxt (L _ stmts))) = free (allVars stmts) -- Do block.
freeVars (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars flds -- Record construction.
freeVars (L _ (RecordUpd _ e flds)) = Set.unions $ freeVars e : map freeVars flds -- Record update.
freeVars (L _ (HsMultiIf _ grhss)) = free (allVars grhss) -- Multi-way if.
freeVars (L _ HsConLikeOut{}) = mempty -- After typechecker.
freeVars (L _ HsRecFld{}) = mempty -- Variable pointing to a record selector.
freeVars (L _ HsOverLabel{}) = mempty -- Overloaded label. The id of the in-scope fromLabel.
freeVars (L _ HsIPVar{}) = mempty -- Implicit parameter.
freeVars (L _ HsOverLit{}) = mempty -- Overloaded literal.
freeVars (L _ HsLit{}) = mempty -- Simple literal.
freeVars (L _ HsRnBracketOut{}) = mempty -- Renamer produces these.
freeVars (L _ HsTcBracketOut{}) = mempty -- Typechecker produces these.
freeVars (L _ HsWrap{}) = mempty -- Typechecker output.
-- freeVars (e@(L _ HsAppType{})) = freeVars $ children e -- Visible type application e.g. f @ Int x y.
-- freeVars (e@(L _ HsApp{})) = freeVars $ children e -- Application.
-- freeVars (e@(L _ OpApp{})) = freeVars $ children e -- Operator application.
-- freeVars (e@(L _ NegApp{})) = freeVars $ children e -- Negation operator.
-- freeVars (e@(L _ HsPar{})) = freeVars $ children e -- Parenthesized expr.
-- freeVars (e@(L _ SectionL{})) = freeVars $ children e -- Left section.
-- freeVars (e@(L _ SectionR{})) = freeVars $ children e -- Right section.
-- freeVars (e@(L _ ExplicitTuple{})) = freeVars $ children e -- Explicit tuple and sections thereof.
-- freeVars (e@(L _ ExplicitSum{})) = freeVars $ children e -- Used for unboxed sum types.
-- freeVars (e@(L _ HsIf{})) = freeVars $ children e -- If.
-- freeVars (e@(L _ ExplicitList{})) = freeVars $ children e -- Syntactic list e.g. [a, b, c].
-- freeVars (e@(L _ ExprWithTySig{})) = freeVars $ children e -- Expr with type signature.
-- freeVars (e@(L _ ArithSeq {})) = freeVars $ children e -- Arithmetic sequence.
-- freeVars (e@(L _ HsSCC{})) = freeVars $ children e -- Set cost center pragma (expr whose const is to be measured).
-- freeVars (e@(L _ HsCoreAnn{})) = freeVars $ children e -- Pragma.
-- freeVars (e@(L _ HsBracket{})) = freeVars $ children e -- Haskell bracket.
-- freeVars (e@(L _ HsSpliceE{})) = freeVars $ children e -- Template haskell splice expr.
-- freeVars (e@(L _ HsProc{})) = freeVars $ children e -- Proc notation for arrows.
-- freeVars (e@(L _ HsStatic{})) = freeVars $ children e -- Static pointers extension.
-- freeVars (e@(L _ HsArrApp{})) = freeVars $ children e -- Arrow tail or arrow application.
-- freeVars (e@(L _ HsArrForm{})) = freeVars $ children e -- Come back to it. Arrow tail or arrow application.
-- freeVars (e@(L _ HsTick{})) = freeVars $ children e -- Haskell program coverage (Hpc) support.
-- freeVars (e@(L _ HsBinTick{})) = freeVars $ children e -- Haskell program coverage (Hpc) support.
-- freeVars (e@(L _ HsTickPragma{})) = freeVars $ children e -- Haskell program coverage (Hpc) support.
-- freeVars (e@(L _ EAsPat{})) = freeVars $ children e -- Expr as pat.
-- freeVars (e@(L _ EViewPat{})) = freeVars $ children e -- View pattern.
-- freeVars (e@(L _ ELazyPat{})) = freeVars $ children e -- Lazy pattern.
freeVars e = freeVars $ children e
instance FreeVars (LHsTupArg GhcPs) where
freeVars (L _ (Present _ args)) = freeVars args
freeVars _ = mempty
instance FreeVars (LHsRecField GhcPs (LHsExpr GhcPs)) where
freeVars o@(L _ (HsRecField x _ True)) = Set.singleton $ occName $ unLoc $ rdrNameFieldOcc $ unLoc x -- a pun
freeVars o@(L _ (HsRecField _ x _)) = freeVars x
instance FreeVars (LHsRecUpdField GhcPs) where
freeVars (L _ (HsRecField _ x _)) = freeVars x
instance AllVars (Located (Pat GhcPs)) where
allVars (L _ (VarPat _ (L _ x))) = Vars (Set.singleton $ rdrNameOcc x) Set.empty -- Variable pattern.
allVars (L _ (AsPat _ n x)) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs) <> allVars x -- As pattern.
allVars (L _ (ConPatIn _ (RecCon (HsRecFields flds _)))) = allVars flds
allVars (L _ (NPlusKPat _ n _ _ _ _)) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs) -- n+k pattern.
allVars (L _ (ViewPat _ e p)) = freeVars_ e <> allVars p -- View pattern.
allVars (L _ WildPat{}) = mempty -- Wildcard pattern.
allVars (L _ ConPatOut{}) = mempty -- Renamer/typechecker.
allVars (L _ LitPat{}) = mempty -- Literal pattern.
allVars (L _ NPat{}) = mempty -- Natural pattern.
-- allVars p@SplicePat{} = allVars $ children p -- Splice pattern (includes quasi-quotes).
-- allVars p@SigPat{} = allVars $ children p -- Pattern with a type signature.
-- allVars p@CoPat{} = allVars $ children p -- Coercion pattern.
-- allVars p@LazyPat{} = allVars $ children p -- Lazy pattern.
-- allVars p@ParPat{} = allVars $ children p -- Parenthesized pattern.
-- allVars p@BangPat{} = allVars $ children p -- Bang pattern.
-- allVars p@ListPat{} = allVars $ children p -- Syntactic list.
-- allVars p@TuplePat{} = allVars $ children p -- Tuple sub patterns.
-- allVars p@SumPat{} = allVars $ children p -- Anonymous sum pattern.
allVars p = allVars $ children p
instance AllVars (LHsRecField GhcPs (Located (Pat GhcPs))) where
allVars (L _ (HsRecField _ x _)) = allVars x
instance AllVars (LStmt GhcPs (LHsExpr GhcPs)) where
allVars (L _ (LastStmt _ expr _ _)) = freeVars_ expr -- The last stmt of a ListComp, MonadComp, DoExpr,MDoExpr.
allVars (L _ (BindStmt _ pat expr _ _)) = allVars pat <> freeVars_ expr -- A generator e.g. x <- [1, 2, 3].
allVars (L _ (BodyStmt _ expr _ _)) = freeVars_ expr -- A boolean guard e.g. even x.
allVars (L _ (LetStmt _ binds)) = allVars binds -- A local declaration e.g. let y = x + 1
allVars (L _ (TransStmt _ _ stmts _ using by _ _ fmap_)) = allVars stmts <> freeVars_ using <> maybe mempty freeVars_ by <> freeVars_ (noLoc fmap_ :: Located (HsExpr GhcPs)) -- Apply a function to a list of statements in order.
allVars (L _ (RecStmt _ stmts _ _ _ _ _)) = allVars stmts -- A recursive binding for a group of arrows.
allVars (L _ ApplicativeStmt{}) = mempty -- Generated by the renamer.
allVars (L _ ParStmt{}) = mempty -- Parallel list thing. Come back to it.
allVars _ = mempty -- New ctor.
instance AllVars (LHsLocalBinds GhcPs) where
allVars (L _ (HsValBinds _ (ValBinds _ binds _))) = allVars (bagToList binds) -- Value bindings.
allVars (L _ (HsIPBinds _ (IPBinds _ binds))) = allVars binds -- Implicit parameter bindings.
allVars (L _ EmptyLocalBinds{}) = mempty -- The case of no local bindings (signals the empty `let` or `where` clause).
allVars _ = mempty -- New ctor.
instance AllVars (LIPBind GhcPs) where
allVars (L _ (IPBind _ _ e)) = freeVars_ e
allVars _ = mempty -- New ctor.
instance AllVars (LHsBind GhcPs) where
allVars (L _ FunBind{fun_id=n, fun_matches=MG{mg_alts=(L _ ms)}}) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs) <> allVars ms -- Function bindings and simple variable bindings e.g. f x = e, f !x = 3, f = e, !x = e, x `f` y = e
allVars (L _ PatBind{pat_lhs=n, pat_rhs=grhss}) = allVars n <> allVars grhss -- Ctor patterns and some other interesting cases e.g. Just x = e, (x) = e, x :: Ty = e.
allVars (L _ (PatSynBind _ PSB{})) = mempty -- Come back to it.
allVars (L _ VarBind{}) = mempty -- Typechecker.
allVars (L _ AbsBinds{}) = mempty -- Not sure but I think renamer.
allVars _ = mempty -- New ctor.
instance AllVars (MatchGroup GhcPs (LHsExpr GhcPs)) where
allVars (MG _ _alts@(L _ alts) _) = inVars (foldMap (allVars . m_pats) ms) (allVars (map m_grhss ms))
where ms = map unLoc alts
allVars _ = mempty -- New ctor.
instance AllVars (LMatch GhcPs (LHsExpr GhcPs)) where
allVars (L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars (noLoc $ VarPat noExtField name :: LPat GhcPs) <> allVars pats <> allVars grhss -- A pattern matching on an argument of a function binding.
allVars (L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars ctxt <> allVars pats <> allVars grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.
allVars (L _ (Match _ _ pats grhss)) = inVars (allVars pats) (allVars grhss) -- Everything else.
allVars _ = mempty -- New ctor.
instance AllVars (HsStmtContext RdrName) where
allVars (PatGuard FunRhs{mc_fun=n}) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs)
allVars ParStmtCtxt{} = mempty -- Come back to it.
allVars TransStmtCtxt{} = mempty -- Come back to it.
allVars _ = mempty -- Everything else (correct).
instance AllVars (GRHSs GhcPs (LHsExpr GhcPs)) where
allVars (GRHSs _ grhss binds) = inVars binds (mconcatMap allVars grhss)
allVars _ = mempty -- New ctor.
instance AllVars (LGRHS GhcPs (LHsExpr GhcPs)) where
allVars (L _ (GRHS _ guards expr)) = Vars (bound gs) (free gs ^+ (freeVars expr ^- bound gs)) where gs = allVars guards
allVars _ = mempty -- New ctor.
instance AllVars (LHsDecl GhcPs) where
allVars (L l (ValD _ bind)) = allVars (L l bind :: LHsBind GhcPs)
allVars _ = mempty -- We only consider value bindings.
vars :: FreeVars a => a -> [String]
vars = Set.toList . Set.map occNameString . freeVars
varss :: AllVars a => a -> [String]
varss = Set.toList . Set.map occNameString . free . allVars
pvars :: AllVars a => a -> [String]
pvars = Set.toList . Set.map occNameString . bound . allVars
hlint-3.1.6/src/GHC/Util/DynFlags.hs 0000644 0000000 0000000 00000001562 13671470061 015206 0 ustar 00 0000000 0000000 module GHC.Util.DynFlags (initGlobalDynFlags, baseDynFlags) where
import DynFlags
import GHC.LanguageExtensions.Type
import Data.List.Extra
import Language.Haskell.GhclibParserEx.GHC.Settings.Config
baseDynFlags :: DynFlags
baseDynFlags =
-- The list of default enabled extensions is empty except for
-- 'TemplateHaskellQuotes'. This is because:
-- * The extensions to enable/disable are set exclusively in
-- 'parsePragmasIntoDynFlags' based solely on HSE parse flags
-- (and source level annotations);
-- * 'TemplateHaskellQuotes' is not a known HSE extension but IS
-- needed if the GHC parse is to succeed for the unit-test at
-- hlint.yaml:860
let enable = [TemplateHaskellQuotes]
in foldl' xopt_set (defaultDynFlags fakeSettings fakeLlvmConfig) enable
initGlobalDynFlags :: IO ()
initGlobalDynFlags = setUnsafeGlobalDynFlags baseDynFlags
hlint-3.1.6/src/GHC/Util/Brackets.hs 0000644 0000000 0000000 00000013574 13656755416 015260 0 ustar 00 0000000 0000000 {-# LANGUAGE MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-overlapping-patterns #-}
module GHC.Util.Brackets (Brackets(..), isApp,isOpApp,isAnyApp) where
import GHC.Hs
import SrcLoc
import BasicTypes
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
class Brackets a where
remParen :: a -> Maybe a -- Remove one paren or nothing if there is no paren.
addParen :: a -> a -- Write out a paren.
-- | Is this item lexically requiring no bracketing ever i.e. is
-- totally atomic.
isAtom :: a -> Bool
-- | Is the child safe free from brackets in the parent
-- position. Err on the side of caution, True = don't know.
needBracket :: Int -> a -> a -> Bool
instance Brackets (LHsExpr GhcPs) where
-- When GHC parses a section in concrete syntax, it will produce an
-- 'HsPar (Section[L|R])'. There is no concrete syntax that will
-- result in a "naked" section. Consequently, given an expression,
-- when stripping brackets (c.f. 'Hint.Brackets), don't remove the
-- paren's surrounding a section - they are required.
remParen (L _ (HsPar _ (L _ SectionL{}))) = Nothing
remParen (L _ (HsPar _ (L _ SectionR{}))) = Nothing
remParen (L _ (HsPar _ x)) = Just x
remParen _ = Nothing
addParen e = noLoc $ HsPar noExtField e
isAtom (L _ x) = case x of
HsVar{} -> True
HsUnboundVar{} -> True
HsRecFld{} -> True
HsOverLabel{} -> True
HsIPVar{} -> True
-- Note that sections aren't atoms (but parenthesized sections are).
HsPar{} -> True
ExplicitTuple{} -> True
ExplicitSum{} -> True
ExplicitList{} -> True
RecordCon{} -> True
RecordUpd{} -> True
ArithSeq{}-> True
HsBracket{} -> True
HsSpliceE {} -> True
HsOverLit _ x | not $ isNegativeOverLit x -> True
HsLit _ x | not $ isNegativeLit x -> True
_ -> False
where
isNegativeLit (HsInt _ i) = il_neg i
isNegativeLit (HsRat _ f _) = fl_neg f
isNegativeLit (HsFloatPrim _ f) = fl_neg f
isNegativeLit (HsDoublePrim _ f) = fl_neg f
isNegativeLit (HsIntPrim _ x) = x < 0
isNegativeLit (HsInt64Prim _ x) = x < 0
isNegativeLit (HsInteger _ x _) = x < 0
isNegativeLit _ = False
isNegativeOverLit OverLit {ol_val=HsIntegral i} = il_neg i
isNegativeOverLit OverLit {ol_val=HsFractional f} = fl_neg f
isNegativeOverLit _ = False
isAtom _ = False -- '{-# COMPLETE L #-}'
needBracket i parent child -- Note: i is the index in children, not in the AST.
| isAtom child = False
| isSection parent, L _ HsApp{} <- child = False
| L _ OpApp{} <- parent, L _ HsApp{} <- child, i /= 0 || isAtomOrApp child = False
| L _ ExplicitList{} <- parent = False
| L _ ExplicitTuple{} <- parent = False
| L _ HsIf{} <- parent, isAnyApp child = False
| L _ HsApp{} <- parent, i == 0, L _ HsApp{} <- child = False
| L _ ExprWithTySig{} <- parent, i == 0, isApp child = False
| L _ RecordCon{} <- parent = False
| L _ RecordUpd{} <- parent, i /= 0 = False
-- These all have view patterns embedded within them, or are naturally followed by ->, so we have to watch out for
-- @(x::y) -> z@ which is valid, as either a type annotation, or a view pattern.
| L _ HsLet{} <- parent, isApp child = False
| L _ HsDo{} <- parent, isAnyApp child = False
| L _ HsLam{} <- parent, isAnyApp child = False
| L _ HsCase{} <- parent, isAnyApp child = False
| L _ HsPar{} <- parent = False
| otherwise = True
-- | Am I an HsApp such that having me in an infix doesn't require brackets.
-- Before BlockArguments that was _all_ HsApps. Now, imagine:
--
-- (f \x -> x) *> ...
-- (f do x) *> ...
isAtomOrApp :: LHsExpr GhcPs -> Bool
isAtomOrApp x | isAtom x = True
isAtomOrApp (L _ (HsApp _ _ x)) = isAtomOrApp x
isAtomOrApp _ = False
instance Brackets (Located (Pat GhcPs)) where
remParen (L _ (ParPat _ x)) = Just x
remParen _ = Nothing
addParen e = noLoc $ ParPat noExtField e
isAtom (L _ x) = case x of
ParPat{} -> True
TuplePat{} -> True
ListPat{} -> True
ConPatIn _ RecCon{} -> True
ConPatIn _ (PrefixCon []) -> True
VarPat{} -> True
WildPat{} -> True
SumPat{} -> True
AsPat{} -> True
SplicePat{} -> True
LitPat _ x | not $ isSignedLit x -> True
_ -> False
where
isSignedLit HsInt{} = True
isSignedLit HsIntPrim{} = True
isSignedLit HsInt64Prim{} = True
isSignedLit HsInteger{} = True
isSignedLit HsRat{} = True
isSignedLit HsFloatPrim{} = True
isSignedLit HsDoublePrim{} = True
isSignedLit _ = False
isAtom _ = False -- '{-# COMPLETE L #-}'
needBracket _ parent child
| isAtom child = False
| L _ TuplePat{} <- parent = False
| L _ ListPat{} <- parent = False
| otherwise = True
instance Brackets (LHsType GhcPs) where
remParen (L _ (HsParTy _ x)) = Just x
remParen _ = Nothing
addParen e = noLoc $ HsParTy noExtField e
isAtom (L _ x) = case x of
HsParTy{} -> True
HsTupleTy{} -> True
HsListTy{} -> True
HsExplicitTupleTy{} -> True
HsExplicitListTy{} -> True
HsTyVar{} -> True
HsSumTy{} -> True
HsSpliceTy{} -> True
HsWildCardTy{} -> True
_ -> False
isAtom _ = False -- '{-# COMPLETE L #-}'
needBracket _ parent child
| isAtom child = False
-- a -> (b -> c) is not a required bracket, but useful for documentation about arity etc.
-- | TyFun{} <- parent, i == 1, TyFun{} <- child = False
| L _ HsFunTy{} <- parent, L _ HsAppTy{} <- child = False
| L _ HsTupleTy{} <- parent = False
| L _ HsListTy{} <- parent = False
| L _ HsExplicitTupleTy{} <- parent = False
| L _ HsListTy{} <- parent = False
| L _ HsExplicitListTy{} <- parent = False
| L _ HsOpTy{} <- parent, L _ HsAppTy{} <- child = False
| L _ HsParTy{} <- parent = False
| otherwise = True
hlint-3.1.6/src/GHC/Util/ApiAnnotation.hs 0000644 0000000 0000000 00000007065 13653537201 016247 0 ustar 00 0000000 0000000
module GHC.Util.ApiAnnotation (
comment, commentText, isCommentMultiline
, pragmas, flags, languagePragmas
, mkFlags, mkLanguagePragmas
) where
import ApiAnnotation
import SrcLoc
import Control.Applicative
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.List.Extra
trimCommentStart :: String -> String
trimCommentStart s
| Just s <- stripPrefix "{-" s = s
| Just s <- stripPrefix "--" s = s
| otherwise = s
trimCommentEnd :: String -> String
trimCommentEnd s
| Just s <- stripSuffix "-}" s = s
| otherwise = s
trimCommentDelims :: String -> String
trimCommentDelims = trimCommentEnd . trimCommentStart
-- | A comment as a string.
comment :: Located AnnotationComment -> String
comment (L _ (AnnBlockComment s)) = s
comment (L _ (AnnLineComment s)) = s
comment (L _ (AnnDocOptions s)) = s
comment (L _ (AnnDocCommentNamed s)) = s
comment (L _ (AnnDocCommentPrev s)) = s
comment (L _ (AnnDocCommentNext s)) = s
comment (L _ (AnnDocSection _ s)) = s
-- | The comment string with delimiters removed.
commentText :: Located AnnotationComment -> String
commentText = trimCommentDelims . comment
isCommentMultiline :: Located AnnotationComment -> Bool
isCommentMultiline (L _ (AnnBlockComment _)) = True
isCommentMultiline _ = False
-- GHC parse trees don't contain pragmas. We work around this with
-- (nasty) parsing of comments.
-- Pragmas. Comments not associated with a span in the annotations
-- that have the form @{-# ...#-}@.
pragmas :: ApiAnns -> [(Located AnnotationComment, String)]
pragmas anns =
-- 'ApiAnns' stores pragmas in reverse order to how they were
-- encountered in the source file with the last at the head of the
-- list (makes sense when you think about it).
reverse
[ (c, s) |
c@(L _ (AnnBlockComment comm)) <- fromMaybe [] $ Map.lookup noSrcSpan (snd anns)
, let body = trimCommentDelims comm
, Just rest <- [stripSuffix "#" =<< stripPrefix "#" body]
, let s = trim rest
]
-- Utility for a case insensitive prefix strip.
stripPrefixCI :: String -> String -> Maybe String
stripPrefixCI pref str =
let pref' = lower pref
(str_pref, rest) = splitAt (length pref') str
in if lower str_pref == pref' then Just rest else Nothing
-- Flags. The first element of the pair is the (located) annotation
-- comment that sets the flags enumerated in the second element of the
-- pair.
flags :: [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
flags ps =
-- Old versions of GHC accepted 'OPTIONS' rather than 'OPTIONS_GHC' (but
-- this is deprecated).
[(c, opts) | (c, s) <- ps
, Just rest <- [stripPrefixCI "OPTIONS_GHC " s
<|> stripPrefixCI "OPTIONS " s]
, let opts = words rest]
-- Language pragmas. The first element of the
-- pair is the (located) annotation comment that enables the
-- pragmas enumerated by he second element of the pair.
languagePragmas :: [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
languagePragmas ps =
[(c, exts) | (c, s) <- ps
, Just rest <- [stripPrefixCI "LANGUAGE " s]
, let exts = map trim (splitOn "," rest)]
-- Given a list of flags, make a GHC options pragma.
mkFlags :: SrcSpan -> [String] -> Located AnnotationComment
mkFlags loc flags =
L loc $ AnnBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")
mkLanguagePragmas :: SrcSpan -> [String] -> Located AnnotationComment
mkLanguagePragmas loc exts =
L loc $ AnnBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")
hlint-3.1.6/src/Config/ 0000755 0000000 0000000 00000000000 13674744765 013050 5 ustar 00 0000000 0000000 hlint-3.1.6/src/Config/Yaml.hs 0000644 0000000 0000000 00000033250 13671470061 014267 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, TupleSections #-}
{-# LANGUAGE CPP #-}
module Config.Yaml(
ConfigYaml,
readFileConfigYaml,
settingsFromConfigYaml
) where
import Config.Type
import Data.Either
import Data.Maybe
import Data.List.Extra
import Data.Tuple.Extra
import Control.Monad.Extra
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.ByteString.Char8 as BS
import qualified Data.HashMap.Strict as Map
import Data.Generics.Uniplate.DataOnly
import GHC.All
import Fixity
import Extension
import Module
import Data.Functor
import Data.Semigroup
import Timing
import Prelude
import Bag
import Lexer
import ErrUtils hiding (Severity)
import Outputable
import GHC.Hs
import SrcLoc
import RdrName
import OccName
import GHC.Util (baseDynFlags, Scope, scopeCreate)
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import Data.Char
#ifdef HS_YAML
import Data.YAML (Pos)
import Data.YAML.Aeson (encode1Strict, decode1Strict)
import Data.Aeson hiding (encode)
import Data.Aeson.Types (Parser)
import qualified Data.ByteString as BSS
decodeFileEither :: FilePath -> IO (Either (Pos, String) ConfigYaml)
decodeFileEither path = decode1Strict <$> BSS.readFile path
decodeEither' :: BSS.ByteString -> Either (Pos, String) ConfigYaml
decodeEither' = decode1Strict
displayException :: (Pos, String) -> String
displayException = show
encode :: Value -> BSS.ByteString
encode = encode1Strict
#else
import Data.Yaml
import Control.Exception.Extra
#endif
-- | Read a config file in YAML format. Takes a filename, and optionally the contents.
-- Fails if the YAML doesn't parse or isn't valid HLint YAML
readFileConfigYaml :: FilePath -> Maybe String -> IO ConfigYaml
readFileConfigYaml file contents = timedIO "Config" file $ do
val <- case contents of
Nothing -> decodeFileEither file
Just src -> pure $ decodeEither' $ BS.pack src
case val of
Left e -> fail $ "Failed to read YAML configuration file " ++ file ++ "\n " ++ displayException e
Right v -> pure v
---------------------------------------------------------------------
-- YAML DATA TYPE
newtype ConfigYaml = ConfigYaml [ConfigItem] deriving (Semigroup,Monoid,Show)
data ConfigItem
= ConfigPackage Package
| ConfigGroup Group
| ConfigSetting [Setting]
deriving Show
data Package = Package
{packageName :: String
,packageModules :: [HsExtendInstances (LImportDecl GhcPs)]
} deriving Show
data Group = Group
{groupName :: String
,groupEnabled :: Bool
,groupImports :: [Either String (HsExtendInstances (LImportDecl GhcPs))]
,groupRules :: [Either HintRule Classify] -- HintRule has scope set to mempty
} deriving Show
---------------------------------------------------------------------
-- YAML PARSING LIBRARY
data Val = Val
Value -- the actual value I'm focused on
[(String, Value)] -- the path of values I followed (for error messages)
newVal :: Value -> Val
newVal x = Val x [("root", x)]
getVal :: Val -> Value
getVal (Val x _) = x
addVal :: String -> Value -> Val -> Val
addVal key v (Val focus path) = Val v $ (key,v) : path
-- | Failed when parsing some value, give an informative error message.
parseFail :: Val -> String -> Parser a
parseFail (Val focus path) msg = fail $
"Error when decoding YAML, " ++ msg ++ "\n" ++
"Along path: " ++ unwords steps ++ "\n" ++
"When at: " ++ fst (word1 $ show focus) ++ "\n" ++
-- aim to show a smallish but relevant context
dotDot (fromMaybe (encode focus) $ listToMaybe $ dropWhile (\x -> BS.length x > 250) $ map encode contexts)
where
(steps, contexts) = unzip $ reverse path
dotDot x = let (a,b) = BS.splitAt 250 x in BS.unpack a ++ (if BS.null b then "" else "...")
parseArray :: Val -> Parser [Val]
parseArray v@(getVal -> Array xs) = concatMapM parseArray $ zipWithFrom (\i x -> addVal (show i) x v) 0 $ V.toList xs
parseArray v = pure [v]
parseObject :: Val -> Parser (Map.HashMap T.Text Value)
parseObject (getVal -> Object x) = pure x
parseObject v = parseFail v "Expected an Object"
parseObject1 :: Val -> Parser (String, Val)
parseObject1 v = do
mp <- parseObject v
case Map.keys mp of
[T.unpack -> s] -> (s,) <$> parseField s v
_ -> parseFail v $ "Expected exactly one key but got " ++ show (Map.size mp)
parseString :: Val -> Parser String
parseString (getVal -> String x) = pure $ T.unpack x
parseString v = parseFail v "Expected a String"
parseInt :: Val -> Parser Int
parseInt (getVal -> s@Number{}) = parseJSON s
parseInt v = parseFail v "Expected an Int"
parseArrayString :: Val -> Parser [String]
parseArrayString = parseArray >=> mapM parseString
maybeParse :: (Val -> Parser a) -> Maybe Val -> Parser (Maybe a)
maybeParse parseValue Nothing = pure Nothing
maybeParse parseValue (Just value) = Just <$> parseValue value
parseBool :: Val -> Parser Bool
parseBool (getVal -> Bool b) = pure b
parseBool v = parseFail v "Expected a Bool"
parseField :: String -> Val -> Parser Val
parseField s v = do
x <- parseFieldOpt s v
case x of
Nothing -> parseFail v $ "Expected a field named " ++ s
Just v -> pure v
parseFieldOpt :: String -> Val -> Parser (Maybe Val)
parseFieldOpt s v = do
mp <- parseObject v
case Map.lookup (T.pack s) mp of
Nothing -> pure Nothing
Just x -> pure $ Just $ addVal s x v
allowFields :: Val -> [String] -> Parser ()
allowFields v allow = do
mp <- parseObject v
let bad = map T.unpack (Map.keys mp) \\ allow
when (bad /= []) $
parseFail v $ "Not allowed keys: " ++ unwords bad
parseGHC :: (ParseFlags -> String -> ParseResult v) -> Val -> Parser v
parseGHC parser v = do
x <- parseString v
case parser defaultParseFlags{enabledExtensions=configExtensions, disabledExtensions=[]} x of
POk _ x -> pure x
PFailed ps ->
let (_, errs) = getMessages ps baseDynFlags
errMsg = head (bagToList errs)
msg = Outputable.showSDoc baseDynFlags $ ErrUtils.pprLocErrMsg errMsg
in parseFail v $ "Failed to parse " ++ msg ++ ", when parsing:\n " ++ x
---------------------------------------------------------------------
-- YAML TO DATA TYPE
instance FromJSON ConfigYaml where
parseJSON Null = pure mempty
parseJSON x = parseConfigYaml $ newVal x
parseConfigYaml :: Val -> Parser ConfigYaml
parseConfigYaml v = do
vs <- parseArray v
fmap ConfigYaml $ forM vs $ \o -> do
(s, v) <- parseObject1 o
case s of
"package" -> ConfigPackage <$> parsePackage v
"group" -> ConfigGroup <$> parseGroup v
"arguments" -> ConfigSetting . map SettingArgument <$> parseArrayString v
"fixity" -> ConfigSetting <$> parseFixity v
"smell" -> ConfigSetting <$> parseSmell v
_ | isJust $ getSeverity s -> ConfigGroup . ruleToGroup <$> parseRule o
_ | Just r <- getRestrictType s -> ConfigSetting . map SettingRestrict <$> (parseArray v >>= mapM (parseRestrict r))
_ -> parseFail v "Expecting an object with a 'package' or 'group' key, a hint or a restriction"
parsePackage :: Val -> Parser Package
parsePackage v = do
packageName <- parseField "name" v >>= parseString
packageModules <- parseField "modules" v >>= parseArray >>= mapM (fmap extendInstances <$> parseGHC parseImportDeclGhcWithMode)
allowFields v ["name","modules"]
pure Package{..}
parseFixity :: Val -> Parser [Setting]
parseFixity v = parseArray v >>= concatMapM (parseGHC parseDeclGhcWithMode >=> f)
where
f (L _ (SigD _ (FixSig _ x))) = pure $ map Infix $ fromFixitySig x
f _ = parseFail v "Expected fixity declaration"
parseSmell :: Val -> Parser [Setting]
parseSmell v = do
smellName <- parseField "type" v >>= parseString
smellType <- require v "Expected SmellType" $ getSmellType smellName
smellLimit <- parseField "limit" v >>= parseInt
pure [SettingSmell smellType smellLimit]
where
require :: Val -> String -> Maybe a -> Parser a
require _ _ (Just a) = pure a
require val err Nothing = parseFail val err
parseGroup :: Val -> Parser Group
parseGroup v = do
groupName <- parseField "name" v >>= parseString
groupEnabled <- parseFieldOpt "enabled" v >>= maybe (pure True) parseBool
groupImports <- parseFieldOpt "imports" v >>= maybe (pure []) (parseArray >=> mapM parseImport)
groupRules <- parseFieldOpt "rules" v >>= maybe (pure []) parseArray >>= concatMapM parseRule
allowFields v ["name","enabled","imports","rules"]
pure Group{..}
where
parseImport v = do
x <- parseString v
case word1 x of
("package", x) -> pure $ Left x
_ -> Right . extendInstances <$> parseGHC parseImportDeclGhcWithMode v
ruleToGroup :: [Either HintRule Classify] -> Group
ruleToGroup = Group "" True []
parseRule :: Val -> Parser [Either HintRule Classify]
parseRule v = do
(severity, v) <- parseSeverityKey v
isRule <- isJust <$> parseFieldOpt "lhs" v
if isRule then do
hintRuleNotes <- parseFieldOpt "note" v >>= maybe (pure []) (fmap (map asNote) . parseArrayString)
lhs <- parseField "lhs" v >>= parseGHC parseExpGhcWithMode
rhs <- parseField "rhs" v >>= parseGHC parseExpGhcWithMode
hintRuleSide <- parseFieldOpt "side" v >>= maybe (pure Nothing) (fmap (Just . extendInstances) . parseGHC parseExpGhcWithMode)
hintRuleName <- parseFieldOpt "name" v >>= maybe (pure $ guessName lhs rhs) parseString
allowFields v ["lhs","rhs","note","name","side"]
let hintRuleScope = mempty
pure [Left HintRule{hintRuleSeverity=severity,hintRuleLHS=extendInstances lhs,hintRuleRHS=extendInstances rhs, ..}]
else do
names <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString
within <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin)
pure [Right $ Classify severity n a b | (a,b) <- within, n <- ["" | null names] ++ names]
parseRestrict :: RestrictType -> Val -> Parser Restrict
parseRestrict restrictType v = do
def <- parseFieldOpt "default" v
case def of
Just def -> do
b <- parseBool def
allowFields v ["default"]
pure $ Restrict restrictType b [] [] [] [] Nothing
Nothing -> do
restrictName <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString
restrictWithin <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin)
restrictAs <- parseFieldOpt "as" v >>= maybe (pure []) parseArrayString
restrictBadIdents <- parseFieldOpt "badidents" v >>= maybe (pure []) parseArrayString
restrictMessage <- parseFieldOpt "message" v >>= maybeParse parseString
allowFields v $ ["as" | restrictType == RestrictModule] ++ ["badidents", "name", "within", "message"]
pure Restrict{restrictDefault=True,..}
parseWithin :: Val -> Parser [(String, String)] -- (module, decl)
parseWithin v = do
x <- parseGHC parseExpGhcWithMode v
case x of
L _ (HsVar _ (L _ (Unqual x))) -> pure $ f "" (occNameString x)
L _ (HsVar _ (L _ (Qual mod x))) -> pure $ f (moduleNameString mod) (occNameString x)
_ -> parseFail v "Bad classification rule"
where
f mod name@(c:_) | isUpper c = [(mod,name),(mod ++ ['.' | mod /= ""] ++ name, "")]
f mod name = [(mod, name)]
parseSeverityKey :: Val -> Parser (Severity, Val)
parseSeverityKey v = do
(s, v) <- parseObject1 v
case getSeverity s of
Just sev -> pure (sev, v)
_ -> parseFail v $ "Key should be a severity (e.g. warn/error/suggest) but got " ++ s
guessName :: LHsExpr GhcPs -> LHsExpr GhcPs -> String
guessName lhs rhs
| n:_ <- rs \\ ls = "Use " ++ n
| n:_ <- ls \\ rs = "Redundant " ++ n
| otherwise = defaultHintName
where
(ls, rs) = both f (lhs, rhs)
f :: LHsExpr GhcPs -> [String]
f x = [y | L _ (HsVar _ (L _ x)) <- universe x, let y = occNameStr x, not $ isUnifyVar y, y /= "."]
asNote :: String -> Note
asNote "IncreasesLaziness" = IncreasesLaziness
asNote "DecreasesLaziness" = DecreasesLaziness
asNote (word1 -> ("RemovesError",x)) = RemovesError x
asNote (word1 -> ("ValidInstance",x)) = uncurry ValidInstance $ word1 x
asNote (word1 -> ("RequiresExtension",x)) = RequiresExtension x
asNote x = Note x
---------------------------------------------------------------------
-- SETTINGS
settingsFromConfigYaml :: [ConfigYaml] -> [Setting]
settingsFromConfigYaml (mconcat -> ConfigYaml configs) = settings ++ concatMap f groups
where
packages = [x | ConfigPackage x <- configs]
groups = [x | ConfigGroup x <- configs]
settings = concat [x | ConfigSetting x <- configs]
packageMap' = Map.fromListWith (++) [(packageName, fmap unextendInstances packageModules) | Package{..} <- packages]
groupMap = Map.fromListWith (\new old -> new) [(groupName, groupEnabled) | Group{..} <- groups]
f Group{..}
| Map.lookup groupName groupMap == Just False = []
| otherwise = map (either (\r -> SettingMatchExp r{hintRuleScope=scope'}) SettingClassify) groupRules
where
scope'= asScope' packageMap' (map (fmap unextendInstances) groupImports)
asScope' :: Map.HashMap String [LImportDecl GhcPs] -> [Either String (LImportDecl GhcPs)] -> Scope
asScope' packages xs = scopeCreate (HsModule Nothing Nothing (concatMap f xs) [] Nothing Nothing)
where
f (Right x) = [x]
f (Left x) | Just pkg <- Map.lookup x packages = pkg
| otherwise = error $ "asScope' failed to do lookup, " ++ x
hlint-3.1.6/src/Config/Type.hs 0000644 0000000 0000000 00000013211 13637734575 014320 0 ustar 00 0000000 0000000
module Config.Type(
Severity(..), Classify(..), HintRule(..), Note(..), Setting(..),
Restrict(..), RestrictType(..), SmellType(..),
defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType, getSmellType
) where
import Data.Char
import Data.List.Extra
import Prelude
import qualified GHC.Hs
import Fixity
import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
getSeverity :: String -> Maybe Severity
getSeverity "ignore" = Just Ignore
getSeverity "warn" = Just Warning
getSeverity "warning" = Just Warning
getSeverity "suggest" = Just Suggestion
getSeverity "suggestion" = Just Suggestion
getSeverity "error" = Just Error
getSeverity "hint" = Just Suggestion
getSeverity _ = Nothing
getRestrictType :: String -> Maybe RestrictType
getRestrictType "modules" = Just RestrictModule
getRestrictType "extensions" = Just RestrictExtension
getRestrictType "flags" = Just RestrictFlag
getRestrictType "functions" = Just RestrictFunction
getRestrictType _ = Nothing
defaultHintName :: String
defaultHintName = "Use alternative"
-- | How severe an issue is.
data Severity
= Ignore -- ^ The issue has been explicitly ignored and will usually be hidden (pass @--show@ on the command line to see ignored ideas).
| Suggestion -- ^ Suggestions are things that some people may consider improvements, but some may not.
| Warning -- ^ Warnings are suggestions that are nearly always a good idea to apply.
| Error -- ^ Available as a setting for the user. Only parse errors have this setting by default.
deriving (Eq,Ord,Show,Read,Bounded,Enum)
-- Any 1-letter variable names are assumed to be unification variables
isUnifyVar :: String -> Bool
isUnifyVar [x] = x == '?' || isAlpha x
isUnifyVar [] = False
isUnifyVar xs = all (== '?') xs
---------------------------------------------------------------------
-- TYPE
-- | A note describing the impact of the replacement.
data Note
= IncreasesLaziness -- ^ The replacement is increases laziness, for example replacing @reverse (reverse x)@ with @x@ makes the code lazier.
| DecreasesLaziness -- ^ The replacement is decreases laziness, for example replacing @(fst x, snd x)@ with @x@ makes the code stricter.
| RemovesError String -- ^ The replacement removes errors, for example replacing @foldr1 (+)@ with @sum@ removes an error on @[]@, and might contain the text @\"on []\"@.
| ValidInstance String String -- ^ The replacement assumes standard type class lemmas, a hint with the note @ValidInstance \"Eq\" \"x\"@ might only be valid if
-- the @x@ variable has a reflexive @Eq@ instance.
| RequiresExtension String -- ^ The replacement requires this extension to be available.
| Note String -- ^ An arbitrary note.
deriving (Eq,Ord)
instance Show Note where
show IncreasesLaziness = "increases laziness"
show DecreasesLaziness = "decreases laziness"
show (RemovesError x) = "removes error " ++ x
show (ValidInstance x y) = "requires a valid `" ++ x ++ "` instance for `" ++ y ++ "`"
show (RequiresExtension x) = "may require `{-# LANGUAGE " ++ x ++ " #-}` adding to the top of the file"
show (Note x) = x
showNotes :: [Note] -> String
showNotes = intercalate ", " . map show . filter use
where use ValidInstance{} = False -- Not important enough to tell an end user
use _ = True
-- | How to classify an 'Idea'. If any matching field is @\"\"@ then it matches everything.
data Classify = Classify
{classifySeverity :: Severity -- ^ Severity to set the 'Idea' to.
,classifyHint :: String -- ^ Match on 'Idea' field 'ideaHint'.
,classifyModule :: String -- ^ Match on 'Idea' field 'ideaModule'.
,classifyDecl :: String -- ^ Match on 'Idea' field 'ideaDecl'.
}
deriving Show
-- | A @LHS ==> RHS@ style hint rule.
data HintRule = HintRule
{hintRuleSeverity :: Severity -- ^ Default severity for the hint.
,hintRuleName :: String -- ^ Name for the hint.
,hintRuleNotes :: [Note] -- ^ Notes about application of the hint.
,hintRuleScope :: Scope -- ^ Module scope in which the hint operates (GHC parse tree).
-- We wrap these GHC elements in 'HsExtendInstances' in order that we may derive 'Show'.
,hintRuleLHS :: HsExtendInstances (GHC.Hs.LHsExpr GHC.Hs.GhcPs) -- ^ LHS (GHC parse tree).
,hintRuleRHS :: HsExtendInstances (GHC.Hs.LHsExpr GHC.Hs.GhcPs) -- ^ RHS (GHC parse tree).
,hintRuleSide :: Maybe (HsExtendInstances (GHC.Hs.LHsExpr GHC.Hs.GhcPs)) -- ^ Side condition (GHC parse tree).
}
deriving Show
data RestrictType = RestrictModule | RestrictExtension | RestrictFlag | RestrictFunction deriving (Show,Eq,Ord)
data Restrict = Restrict
{restrictType :: RestrictType
,restrictDefault :: Bool
,restrictName :: [String]
,restrictAs :: [String] -- for RestrictModule only, what module names you can import it as
,restrictWithin :: [(String, String)]
,restrictBadIdents :: [String]
,restrictMessage :: Maybe String
} deriving Show
data SmellType = SmellLongFunctions | SmellLongTypeLists | SmellManyArgFunctions | SmellManyImports
deriving (Show,Eq,Ord)
getSmellType :: String -> Maybe SmellType
getSmellType "long functions" = Just SmellLongFunctions
getSmellType "long type lists" = Just SmellLongTypeLists
getSmellType "many arg functions" = Just SmellManyArgFunctions
getSmellType "many imports" = Just SmellManyImports
getSmellType _ = Nothing
data Setting
= SettingClassify Classify
| SettingMatchExp HintRule
| SettingRestrict Restrict
| SettingArgument String -- ^ Extra command-line argument
| SettingSmell SmellType Int
| Builtin String -- use a builtin hint set
| Infix FixityInfo
deriving Show
hlint-3.1.6/src/Config/Read.hs 0000644 0000000 0000000 00000001452 13632352456 014243 0 ustar 00 0000000 0000000
module Config.Read(readFilesConfig) where
import Config.Type
import Control.Monad
import Control.Exception.Extra
import Config.Yaml
import Data.List.Extra
import System.FilePath
readFilesConfig :: [(FilePath, Maybe String)] -> IO [Setting]
readFilesConfig files = do
let (yaml, haskell) = partition (\(x,_) -> lower (takeExtension x) `elem` [".yml",".yaml"]) files
unless (null haskell) $
errorIO $ "HLint 2.3 and beyond cannot use Haskell configuration files.\n" ++
"Tried to use: " ++ show haskell ++ "\n" ++
"Convert it to .yaml file format, following the example at\n" ++
" "
yaml <- mapM (uncurry readFileConfigYaml) yaml
pure $ settingsFromConfigYaml yaml
hlint-3.1.6/src/Config/Haskell.hs 0000644 0000000 0000000 00000005744 13663430505 014757 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ViewPatterns, TupleSections #-}
module Config.Haskell(
readPragma,
readComment
) where
import Data.Char
import Data.List.Extra
import Text.Read
import Data.Tuple.Extra
import Data.Maybe
import Config.Type
import Util
import Prelude
import GHC.Util
import SrcLoc
import GHC.Hs.Extension
import GHC.Hs.Decls hiding (SpliceDecl)
import GHC.Hs.Expr hiding (Match)
import GHC.Hs.Lit
import FastString
import ApiAnnotation
import Outputable
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
-- | Read an {-# ANN #-} pragma and determine if it is intended for HLint.
-- Return Nothing if it is not an HLint pragma, otherwise what it means.
readPragma :: AnnDecl GhcPs -> Maybe Classify
readPragma (HsAnnotation _ _ provenance expr) = f expr
where
name = case provenance of
ValueAnnProvenance (L _ x) -> occNameStr x
TypeAnnProvenance (L _ x) -> occNameStr x
ModuleAnnProvenance -> ""
f (L _ (HsLit _ (HsString _ (unpackFS -> s)))) | "hlint:" `isPrefixOf` lower s =
case getSeverity a of
Nothing -> errorOn expr "bad classify pragma"
Just severity -> Just $ Classify severity (trimStart b) "" name
where (a,b) = break isSpace $ trimStart $ drop 6 s
f (L _ (HsPar _ x)) = f x
f (L _ (ExprWithTySig _ x _)) = f x
f _ = Nothing
readPragma _ = Nothing
readComment :: Located AnnotationComment -> [Classify]
readComment c@(L pos AnnBlockComment{})
| (hash, x) <- maybe (False, x) (True,) $ stripPrefix "#" x
, x <- trim x
, (hlint, x) <- word1 x
, lower hlint == "hlint"
= f hash x
where
x = commentText c
f hash x
| Just x <- if hash then stripSuffix "#" x else Just x
, (sev, x) <- word1 x
, Just sev <- getSeverity sev
, (things, x) <- g x
, Just hint <- if x == "" then Just "" else readMaybe x
= map (Classify sev hint "") $ ["" | null things] ++ things
f hash _ = errorOnComment c $ "bad HLINT pragma, expected:\n {-" ++ h ++ " HLINT \"Hint name\" " ++ h ++ "-}"
where h = ['#' | hash]
g x | (s, x) <- word1 x
, s /= ""
, not $ "\"" `isPrefixOf` s
= first ((if s == "module" then "" else s):) $ g x
g x = ([], x)
readComment _ = []
errorOn :: Outputable a => Located a -> String -> b
errorOn (L pos val) msg = exitMessageImpure $
showSrcSpan pos ++
": Error while reading hint file, " ++ msg ++ "\n" ++
unsafePrettyPrint val
errorOnComment :: Located AnnotationComment -> String -> b
errorOnComment c@(L s _) msg = exitMessageImpure $
let isMultiline = isCommentMultiline c in
showSrcSpan s ++
": Error while reading hint file, " ++ msg ++ "\n" ++
(if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "")
hlint-3.1.6/src/Config/Compute.hs 0000644 0000000 0000000 00000006512 13671470061 015002 0 ustar 00 0000000 0000000 {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
-- | Given a file, guess settings from it by looking at the hints.
module Config.Compute(computeSettings) where
import GHC.All
import GHC.Util
import Config.Type
import Fixity
import Data.Generics.Uniplate.DataOnly
import GHC.Hs hiding (Warning)
import RdrName
import Name
import Bag
import SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import Prelude
-- | Given a source file, guess some hints that might apply.
-- Returns the text of the hints (if you want to save it down) along with the settings to be used.
computeSettings :: ParseFlags -> FilePath -> IO (String, [Setting])
computeSettings flags file = do
x <- parseModuleEx flags file Nothing
case x of
Left (ParseError sl msg _) ->
pure ("# Parse error " ++ showSrcSpan sl ++ ": " ++ msg, [])
Right ModuleEx{ghcModule=m} -> do
let xs = concatMap findSetting (hsmodDecls $ unLoc m)
s = unlines $ ["# hints found in " ++ file] ++ concatMap renderSetting xs ++ ["# no hints found" | null xs]
pure (s,xs)
renderSetting :: Setting -> [String]
-- Only need to convert the subset of Setting we generate
renderSetting (SettingMatchExp HintRule{..}) =
["- warn: {lhs: " ++ show (unsafePrettyPrint hintRuleLHS) ++ ", rhs: " ++ show (unsafePrettyPrint hintRuleRHS) ++ "}"]
renderSetting (Infix x) =
["- fixity: " ++ show (unsafePrettyPrint $ toFixitySig x)]
renderSetting _ = []
findSetting :: LHsDecl GhcPs -> [Setting]
findSetting (L _ (ValD _ x)) = findBind x
findSetting (L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =
concatMap (findBind . unLoc) $ bagToList cid_binds
findSetting (L _ (SigD _ (FixSig _ x))) = map Infix $ fromFixitySig x
findSetting x = []
findBind :: HsBind GhcPs -> [Setting]
findBind VarBind{var_id, var_rhs} = findExp var_id [] $ unLoc var_rhs
findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noExtField fun_matches
findBind _ = []
findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
findExp name vs (HsLam _ MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=L _ (EmptyLocalBinds _)}}]})
= if length m_pats == length ps then findExp name (vs++ps) $ unLoc x else []
where ps = [rdrNameStr x | L _ (VarPat _ x) <- m_pats]
findExp name vs HsLam{} = []
findExp name vs HsVar{} = []
findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $
HsApp noExtField x $ noLoc $ HsPar noExtField $ noLoc $ HsApp noExtField y $ noLoc $ mkVar "_hlint"
findExp name vs bod = [SettingMatchExp $
HintRule Warning defaultHintName []
mempty (extendInstances lhs) (extendInstances $ fromParen rhs) Nothing]
where
lhs = fromParen $ noLoc $ transform f bod
rhs = apps $ map noLoc $ HsVar noExtField (noLoc name) : map snd rep
rep = zip vs $ map (mkVar . pure) ['a'..]
f (HsVar _ x) | Just y <- lookup (rdrNameStr x) rep = y
f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ noLoc $ HsPar noExtField y
f x = x
mkVar :: String -> HsExpr GhcPs
mkVar = HsVar noExtField . noLoc . Unqual . mkVarOcc
hlint-3.1.6/data/ 0000755 0000000 0000000 00000000000 13674744766 011766 5 ustar 00 0000000 0000000 hlint-3.1.6/data/Test.hs 0000644 0000000 0000000 00000005750 13605323475 013230 0 ustar 00 0000000 0000000 -- These hints are for test purposes, and are not intended to
-- be used for real.
-- FIXME: Should make this module modules in one file, so can easily test lots of
-- things without them overlapping
module HLint.Test where
error = Prelude.readFile ==> bad
error = (x :: Int) ==> (x :: Int32)
where _ = noTypeCheck
error "Test1" = scanr ==> scanr
error "Test2" = filter ==> filter
error "Test3" = foldr ==> foldr
error "Test4" = foldl ==> foldl
ignore "Test1" = ""
ignore "Test3"
ignore "Test2" = ignoreTest
warn = ignoreTest3
suggest = ignoreTest4
ignore = Ignore_Test
{-# ANN module "HLint: ignore Test4" #-}
{-# ANN annTest2 "HLint: error" #-}
{-# ANN annTest3 ("HLint: warn" :: String) #-}
{-# ANN annTest4 ("HLint: suggest" :: String) #-}
{-# ANN type Ann_Test ("HLint: ignore") #-}
error = concat (map f x) ==> Data.List.concatMap f x
infix 9 +
error = a * (b+c) ==> undefined
error = Array.head ==> head
error = tail ==> Array.tail
warn = id Control.Arrow.*** id ==> id
error = zip [1..length x] x ==> zipFrom 1 x
error = before a ==> after a
warn "noop" = a ? 0 ==> a
{-
<--! TEST (temporarily disabled see issue https://github.com/ndmitchell/hlint/issues/809) !-->
main = readFile "foo" >>= putStr \
-- bad
import Prelude hiding(readFile) \
import Data.ByteString.Char8(readFile) \
test = readFile "foo" >>= putStr
import Prelude as Prelude2 \
yes = Prelude2.readFile "foo" >>= putStr \
-- bad
yes = 32 :: Int -- 32 :: Int32
yes = before 12 -- after 12
ignoreTest = filter -- @Ignore ???
ignoreTest2 = filter -- @Error ???
ignoreTest3 = filter -- @Warning ???
ignoreTest4 = filter -- @Suggestion ???
ignoreAny = scanr -- @Ignore ???
ignoreNew = foldr -- @Ignore ???
type Ignore_Test = Int -- @Ignore ???
annTest = foldl -- @Ignore ???
annTest2 = foldl -- @Error ???
annTest3 = scanr -- @Warning ???
annTest4 = scanr -- @Suggestion ???
type Ann_Test = Int -- @Ignore ???
concatMap f x = concat (map f x)
concatMop f x = concat (map f x) -- Data.List.concatMap f x
yes = 1 * 2+3 -- undefined
import Foo; test = Foo.id 1
test = head
import Array; test = Array.head -- head
test = Array.head -- head
test = head
import qualified Array; test = head
import Array(tail); test = head
import Array(head); test = head -- head
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
test = 5 + 0 -- 5
{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} \
{-# LANGUAGE RecordWildCards #-} -- @Ignore ???
{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} \
{-# LANGUAGE RecordWildCards #-} -- @Ignore ???
{-# ANN lam "HLint: ignore Redundant lambda" #-} \
lam = \x -> x x x -- @Ignore ???
{-# ANN module "HLint: ignore Reduce duplication" #-} \
dup = do a; a; a; a; a; a -- @Ignore ???
-}
hlint-3.1.6/data/report_template.html 0000644 0000000 0000000 00000010072 13474042413 016034 0 ustar 00 0000000 0000000
HLint Report
Report generated by HLint
$VERSION
- a tool to suggest improvements to your Haskell code.
$CONTENT
hlint-3.1.6/data/hs-lint.el 0000644 0000000 0000000 00000007623 13311534446 013652 0 ustar 00 0000000 0000000 ;;; hs-lint.el --- minor mode for HLint code checking
;; Copyright 2009 (C) Alex Ott
;;
;; Author: Alex Ott
;; Keywords: haskell, lint, HLint
;; Requirements:
;; Status: distributed under terms of GPL2 or above
;; Typical message from HLint looks like:
;;
;; /Users/ott/projects/lang-exp/haskell/test.hs:52:1: Eta reduce
;; Found:
;; count1 p l = length (filter p l)
;; Perhaps:
;; count1 p = length . filter p
(require 'compile)
(defgroup hs-lint nil
"Run HLint as inferior of Emacs, parse error messages."
:group 'tools
:group 'haskell)
(defcustom hs-lint-command "hlint"
"The default hs-lint command for \\[hlint]."
:type 'string
:group 'hs-lint)
(defcustom hs-lint-save-files t
"Save modified files when run HLint or no (ask user)"
:type 'boolean
:group 'hs-lint)
(defcustom hs-lint-replace-with-suggestions nil
"Replace user's code with suggested replacements"
:type 'boolean
:group 'hs-lint)
(defcustom hs-lint-replace-without-ask nil
"Replace user's code with suggested replacements automatically"
:type 'boolean
:group 'hs-lint)
(defun hs-lint-process-setup ()
"Setup compilation variables and buffer for `hlint'."
(run-hooks 'hs-lint-setup-hook))
;; regex for replace suggestions
;;
;; ^\(.*?\):\([0-9]+\):\([0-9]+\): .*
;; Found:
;; \s +\(.*\)
;; Perhaps:
;; \s +\(.*\)
(defvar hs-lint-regex
"^\\(.*?\\):\\([0-9]+\\):\\([0-9]+\\): .*[\n\C-m]Found:[\n\C-m]\\s +\\(.*\\)[\n\C-m]Perhaps:[\n\C-m]\\s +\\(.*\\)[\n\C-m]"
"Regex for HLint messages")
(defun make-short-string (str maxlen)
(if (< (length str) maxlen)
str
(concat (substring str 0 (- maxlen 3)) "...")))
(defun hs-lint-replace-suggestions ()
"Perform actual replacement of suggestions"
(goto-char (point-min))
(while (re-search-forward hs-lint-regex nil t)
(let* ((fname (match-string 1))
(fline (string-to-number (match-string 2)))
(old-code (match-string 4))
(new-code (match-string 5))
(msg (concat "Replace '" (make-short-string old-code 30)
"' with '" (make-short-string new-code 30) "'"))
(bline 0)
(eline 0)
(spos 0)
(new-old-code ""))
(save-excursion
(switch-to-buffer (get-file-buffer fname))
(goto-line fline)
(beginning-of-line)
(setf bline (point))
(when (or hs-lint-replace-without-ask
(yes-or-no-p msg))
(end-of-line)
(setf eline (point))
(beginning-of-line)
(setf old-code (regexp-quote old-code))
(while (string-match "\\\\ " old-code spos)
(setf new-old-code (concat new-old-code
(substring old-code spos (match-beginning 0))
"\\ *"))
(setf spos (match-end 0)))
(setf new-old-code (concat new-old-code (substring old-code spos)))
(remove-text-properties bline eline '(composition nil))
(when (re-search-forward new-old-code eline t)
(replace-match new-code nil t)))))))
(defun hs-lint-finish-hook (buf msg)
"Function, that is executed at the end of HLint execution"
(if hs-lint-replace-with-suggestions
(hs-lint-replace-suggestions)
(next-error 1 t)))
(define-compilation-mode hs-lint-mode "HLint"
"Mode for check Haskell source code."
(set (make-local-variable 'compilation-process-setup-function)
'hs-lint-process-setup)
(set (make-local-variable 'compilation-disable-input) t)
(set (make-local-variable 'compilation-scroll-output) nil)
(set (make-local-variable 'compilation-finish-functions)
(list 'hs-lint-finish-hook))
)
(defun hs-lint ()
"Run HLint for current buffer with haskell source"
(interactive)
(save-some-buffers hs-lint-save-files)
(compilation-start (concat hs-lint-command " \"" buffer-file-name "\"")
'hs-lint-mode))
(provide 'hs-lint)
;;; hs-lint.el ends here
hlint-3.1.6/data/HLint_TypeCheck.hs 0000644 0000000 0000000 00000000471 13637726522 015266 0 ustar 00 0000000 0000000
-- Used with --typecheck
module HLint_TypeCheck where
(==>) :: a -> a -> a
(==>) = undefined
_noParen_ = id
---------------------------------------------------------------------
-- EXAMPLES
main :: IO ()
main = return ()
{-# LINE 116 "data\\Default.hs" #-}
_test64 = \ p x -> (and (map p x)) ==> (all p x)
hlint-3.1.6/data/HLint_QuickCheck.hs 0000644 0000000 0000000 00000011234 13637726537 015426 0 ustar 00 0000000 0000000 {-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules, ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
-- | 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,[Bool],Int,Dbl)
-- We need a Show instance that nails down the sides, so defaulting works.
-- The one from Text.Show.Functions is insufficient.
instance (Show a, Show b) => Show (a -> b) where show _ = ""
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 (IO a) where show _ = ""
instance Show a => Show (Weak a) where show _ = ""
instance Show a => Show (Chan a) where show _ = ""
instance Eq (IO a) where _ == _ = True
instance Eq SomeException where a == b = show a == show b
deriving instance Typeable IOMode
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
withMain :: IO () -> IO ()
withMain act = do
act
bad <- readIORef bad
when (bad > 0) $
error $ "Failed " ++ show bad ++ " tests"
---------------------------------------------------------------------
-- EXAMPLES
main :: IO ()
main = withMain $ do
let t = \ a -> (findIndex ((==) a)) ==> (elemIndex a)
in test "data\\Default.hs" 144 "findIndex ((==) a) ==> elemIndex a" t
let t = ((foldr1 (&&)) ?==> (and))
in test "data\\Default.hs" 179 "foldr1 (&&) ==> and" t
let t = \ x -> (sqrt x) ==> (x ** 0.5)
in test "data\\Default.hs" 407 "sinh x / cosh x ==> tanh x" t
let t = \ (NegZero i) x -> (take i x) ==> ([])
in test "data\\Default.hs" 154 "take i x ==> []" t
let t = \ (Compare f) x -> (head (sortBy f x)) ==> (minimumBy f x)
in test "data\\Default.hs" 70 "head (sortBy f x) ==> minimumBy f x" t
let t = \ f -> ((f $)) ==> (f)
in test "data\\Default.hs" 218 "(f $) ==> f" t
hlint-3.1.6/data/hlint.yaml 0000644 0000000 0000000 00000170476 13674736772 014005 0 ustar 00 0000000 0000000 # hlint configuration file
# ==================================
# The hlint tool is mainly automatic, but some hints/restrictions can be specified here.
- package:
name: base
modules:
- import Prelude
- import Control.Arrow
- import Control.Exception
- import Control.Monad
- import Control.Monad.Trans.State
- import qualified Data.Foldable
- import Data.Foldable(asum, sequenceA_, traverse_, for_)
- import Data.Traversable(traverse, for)
- import Control.Applicative
- import Data.Bifunctor
- import Data.Function
- import Data.Int
- import Data.Char
- import Data.List as Data.List
- import Data.List as X
- import Data.Maybe
- import Data.Monoid
- import System.IO
- import Control.Concurrent.Chan
- import System.Mem.Weak
- import Control.Exception.Base
- import System.Exit
- import Data.Either
- import Numeric
- import IO as System.IO
- import List as Data.List
- import Maybe as Data.Maybe
- import Monad as Control.Monad
- import Char as Data.Char
- package:
name: lens
modules:
- import Control.Lens
- import Control.Lens.Operators
- import Control.Monad.Reader
- package:
name: attoparsec
modules:
- import Data.Attoparsec.Text
- import Data.Attoparsec.ByteString
- package:
name: codeworld-api
modules:
- import CodeWorld
- group:
name: default
enabled: true
imports:
- package base
rules:
# I/O
- warn: {lhs: putStrLn (show x), rhs: print x}
- warn: {lhs: mapM_ putChar, rhs: putStr}
- warn: {lhs: hGetChar stdin, rhs: getChar}
- warn: {lhs: hGetLine stdin, rhs: getLine}
- warn: {lhs: hGetContents stdin, rhs: getContents}
- warn: {lhs: hPutChar stdout, rhs: putChar}
- warn: {lhs: hPutStr stdout, rhs: putStr}
- warn: {lhs: hPutStrLn stdout, rhs: putStrLn}
- warn: {lhs: hPrint stdout, rhs: print}
- warn: {lhs: hWaitForInput a 0, rhs: hReady a}
- warn: {lhs: hPutStrLn a (show b), rhs: hPrint a b}
- warn: {lhs: hIsEOF stdin, rhs: isEOF}
- warn: {lhs: withFile f WriteMode (\h -> hPutStr h x), rhs: writeFile f x}
- warn: {lhs: withFile f WriteMode (\h -> hPutStrLn h x), rhs: writeFile f (x ++ "\n")}
- warn: {lhs: withFile f AppendMode (\h -> hPutStr h x), rhs: appendFile f x}
- warn: {lhs: withFile f AppendMode (\h -> hPutStrLn h x), rhs: appendFile f (x ++ "\n")}
# EXIT
- warn: {lhs: exitWith ExitSuccess, rhs: exitSuccess}
# ORD
- warn: {lhs: not (a == b), rhs: a /= b, note: incorrect if either value is NaN}
- warn: {lhs: not (a /= b), rhs: a == b, note: incorrect if either value is NaN}
- warn: {lhs: not (a > b), rhs: a <= b, note: incorrect if either value is NaN}
- warn: {lhs: not (a >= b), rhs: a < b, note: incorrect if either value is NaN}
- warn: {lhs: not (a < b), rhs: a >= b, note: incorrect if either value is NaN}
- warn: {lhs: not (a <= b), rhs: a > b, note: incorrect if either value is NaN}
- warn: {lhs: compare x y /= GT, rhs: x <= y}
- warn: {lhs: compare x y == LT, rhs: x < y}
- warn: {lhs: compare x y /= LT, rhs: x >= y}
- warn: {lhs: compare x y == GT, rhs: x > y}
- warn: {lhs: compare x y == EQ, rhs: x == y}
- warn: {lhs: compare x y /= EQ, rhs: x /= y}
- warn: {lhs: head (sort x), rhs: minimum x}
- warn: {lhs: last (sort x), rhs: maximum x}
- warn: {lhs: head (sortBy f x), rhs: minimumBy f x, side: isCompare f}
- warn: {lhs: last (sortBy f x), rhs: maximumBy f x, side: isCompare f}
- warn: {lhs: reverse (sortBy f x), rhs: sortBy (flip f) x, name: Avoid reverse, side: isCompare f, note: Stabilizes sort order}
- warn: {lhs: sortBy (flip (comparing f)), rhs: sortOn (Down . f)}
- warn: {lhs: sortBy (comparing f), rhs: sortOn f, side: notEq f fst && notEq f snd}
- warn: {lhs: reverse (sortOn f x), rhs: sortOn (Data.Ord.Down . f) x, name: Avoid reverse, note: Stabilizes sort order}
# This suggestion likely costs performance, see https://github.com/ndmitchell/hlint/issues/669#issuecomment-607154496
# - warn: {lhs: reverse (sort x), rhs: sortOn Data.Ord.Down x, name: Avoid reverse, note: Stabilizes sort order}
- hint: {lhs: flip (g `on` h), rhs: flip g `on` h, name: Move flip}
- hint: {lhs: (f `on` g) `on` h, rhs: f `on` (g . h), name: Fuse on/on}
# READ/SHOW
- warn: {lhs: showsPrec 0 x "", rhs: show x}
- warn: {lhs: readsPrec 0, rhs: reads}
- warn: {lhs: showsPrec 0, rhs: shows}
- hint: {lhs: showIntAtBase 16 intToDigit, rhs: showHex}
- hint: {lhs: showIntAtBase 8 intToDigit, rhs: showOct}
# LIST
- warn: {lhs: concat (map f x), rhs: concatMap f x}
- warn: {lhs: concat (fmap f x), rhs: concatMap f x}
- hint: {lhs: "concat [a, b]", rhs: a ++ b}
- hint: {lhs: map f (map g x), rhs: map (f . g) x, name: Use map once}
- hint: {lhs: concatMap f (map g x), rhs: concatMap (f . g) x, name: Fuse concatMap/map}
- hint: {lhs: x !! 0, rhs: head x}
- warn: {lhs: take n (repeat x), rhs: replicate n x}
- warn: {lhs: map f (replicate n x), rhs: replicate n (f x)}
- warn: {lhs: map f (repeat x), rhs: repeat (f x)}
- warn: {lhs: "cycle [x]", rhs: repeat x}
- warn: {lhs: head (reverse x), rhs: last x}
- warn: {lhs: head (drop n x), rhs: x !! n, side: isNat n}
- warn: {lhs: head (drop n x), rhs: x !! max 0 n, side: not (isNat n) && not (isNeg n)}
- warn: {lhs: reverse (tail (reverse x)), rhs: init x, note: IncreasesLaziness}
- warn: {lhs: reverse (reverse x), rhs: x, note: IncreasesLaziness, name: Avoid reverse}
- warn: {lhs: isPrefixOf (reverse x) (reverse y), rhs: isSuffixOf x y}
- warn: {lhs: "foldr (++) []", rhs: concat}
- warn: {lhs: foldr (++) "", rhs: concat}
- warn: {lhs: "foldr ((++) . f) []", rhs: concatMap f}
- warn: {lhs: foldr ((++) . f) "", rhs: concatMap f}
- warn: {lhs: "foldl (++) []", rhs: concat, note: IncreasesLaziness}
- warn: {lhs: foldl (++) "", rhs: concat, note: IncreasesLaziness}
- warn: {lhs: foldl f (head x) (tail x), rhs: foldl1 f x}
- warn: {lhs: foldr f (last x) (init x), rhs: foldr1 f x}
- warn: {lhs: "foldr (\\c a -> x : a) []", rhs: "map (\\c -> x)"}
- warn: {lhs: foldr (.) id l z, rhs: foldr ($) z l}
- warn: {lhs: span (not . p), rhs: break p}
- warn: {lhs: break (not . p), rhs: span p}
- warn: {lhs: "(takeWhile p x, dropWhile p x)", rhs: span p x, note: DecreasesLaziness}
- warn: {lhs: fst (span p x), rhs: takeWhile p x}
- warn: {lhs: snd (span p x), rhs: dropWhile p x}
- warn: {lhs: fst (break p x), rhs: takeWhile (not . p) x}
- warn: {lhs: snd (break p x), rhs: dropWhile (not . p) x}
- warn: {lhs: "(take n x, drop n x)", rhs: splitAt n x, note: DecreasesLaziness}
- warn: {lhs: fst (splitAt p x), rhs: take p x}
- warn: {lhs: snd (splitAt p x), rhs: drop p x}
- warn: {lhs: concatMap (++ "\n"), rhs: unlines}
- warn: {lhs: map id, rhs: id}
- warn: {lhs: concatMap id, rhs: concat}
- warn: {lhs: or (map p x), rhs: any p x}
- warn: {lhs: and (map p x), rhs: all p x}
- warn: {lhs: any f (map g x), rhs: any (f . g) x}
- warn: {lhs: all f (map g x), rhs: all (f . g) x}
- warn: {lhs: "zipWith (,)", rhs: zip}
- warn: {lhs: "zipWith3 (,,)", rhs: zip3}
- hint: {lhs: length x == 0, rhs: null x, note: IncreasesLaziness}
- hint: {lhs: 0 == length x, rhs: null x, note: IncreasesLaziness}
- hint: {lhs: length x < 1, rhs: null x, note: IncreasesLaziness}
- hint: {lhs: 1 > length x, rhs: null x, note: IncreasesLaziness}
- hint: {lhs: length x <= 0, rhs: null x, note: IncreasesLaziness}
- hint: {lhs: 0 >= length x, rhs: null x, note: IncreasesLaziness}
- hint: {lhs: "x == []", rhs: null x}
- hint: {lhs: "[] == x", rhs: null x}
- hint: {lhs: all (const False), rhs: "null"}
- hint: {lhs: any (const True) x, rhs: not (null x), name: Use null}
- hint: {lhs: length x /= 0, rhs: not (null x), note: IncreasesLaziness, name: Use null}
- hint: {lhs: 0 /= length x, rhs: not (null x), note: IncreasesLaziness, name: Use null}
- hint: {lhs: "\\x -> [x]", rhs: "(:[])", name: "Use :"}
- hint: {lhs: map f (zip x y), rhs: zipWith (curry f) x y, side: not (isApp f)}
- hint: {lhs: "map f (fromMaybe [] x)", rhs: "maybe [] (map f) x"}
- warn: {lhs: not (elem x y), rhs: notElem x y}
- hint: {lhs: foldr f z (map g x), rhs: foldr (f . g) z x, name: Fuse foldr/map}
- warn: {lhs: "x ++ concatMap (' ':) y", rhs: "unwords (x:y)"}
- warn: {lhs: intercalate " ", rhs: unwords}
- hint: {lhs: concat (intersperse x y), rhs: intercalate x y, side: notEq x " "}
- hint: {lhs: concat (intersperse " " x), rhs: unwords x}
- warn: {lhs: null (filter f x), rhs: not (any f x), name: Use any}
- warn: {lhs: "filter f x == []", rhs: not (any f x), name: Use any}
- warn: {lhs: "filter f x /= []", rhs: any f x}
- warn: {lhs: any id, rhs: or}
- warn: {lhs: all id, rhs: and}
- warn: {lhs: any (not . f) x, rhs: not (all f x), name: Hoist not}
- warn: {lhs: all (not . f) x, rhs: not (any f x), name: Hoist not}
- warn: {lhs: any ((==) a), rhs: elem a, note: ValidInstance Eq a}
- warn: {lhs: any (== a), rhs: elem a}
- warn: {lhs: any (a ==), rhs: elem a, note: ValidInstance Eq a}
- warn: {lhs: all ((/=) a), rhs: notElem a, note: ValidInstance Eq a}
- warn: {lhs: all (/= a), rhs: notElem a, note: ValidInstance Eq a}
- warn: {lhs: all (a /=), rhs: notElem a, note: ValidInstance Eq a}
- warn: {lhs: elem True, rhs: or}
- warn: {lhs: notElem False, rhs: and}
- warn: {lhs: True `elem` l, rhs: or l}
- warn: {lhs: False `notElem` l, rhs: and l}
- warn: {lhs: findIndex ((==) a), rhs: elemIndex a}
- warn: {lhs: findIndex (a ==), rhs: elemIndex a}
- warn: {lhs: findIndex (== a), rhs: elemIndex a}
- warn: {lhs: findIndices ((==) a), rhs: elemIndices a}
- warn: {lhs: findIndices (a ==), rhs: elemIndices a}
- warn: {lhs: findIndices (== a), rhs: elemIndices a}
- warn: {lhs: "lookup b (zip l [0..])", rhs: elemIndex b l}
- hint: {lhs: "elem x [y]", rhs: x == y, note: ValidInstance Eq a}
- hint: {lhs: "notElem x [y]", rhs: x /= y, note: ValidInstance Eq a}
- hint: {lhs: length x >= 0, rhs: "True", name: Length always non-negative}
- hint: {lhs: 0 <= length x, rhs: "True", name: Length always non-negative}
- hint: {lhs: length x > 0, rhs: not (null x), note: IncreasesLaziness, name: Use null}
- hint: {lhs: 0 < length x, rhs: not (null x), note: IncreasesLaziness, name: Use null}
- hint: {lhs: length x >= 1, rhs: not (null x), note: IncreasesLaziness, name: Use null}
- hint: {lhs: 1 <= length x, rhs: not (null x), note: IncreasesLaziness, name: Use null}
- warn: {lhs: take i x, rhs: "[]", side: isNegZero i, name: Take on a non-positive}
- warn: {lhs: drop i x, rhs: x, side: isNegZero i, name: Drop on a non-positive}
- warn: {lhs: last (scanl f z x), rhs: foldl f z x}
- warn: {lhs: head (scanr f z x), rhs: foldr f z x}
- warn: {lhs: iterate id, rhs: repeat}
- warn: {lhs: zipWith f (repeat x), rhs: map (f x)}
- warn: {lhs: zipWith f y (repeat z), rhs: map (\x -> f x z) y}
- warn: {lhs: listToMaybe (filter p x), rhs: find p x}
- warn: {lhs: zip (take n x) (take n y), rhs: take n (zip x y)}
- warn: {lhs: zip (take n x) (take m y), rhs: take (min n m) (zip x y), side: notEq n m, note: IncreasesLaziness, name: Redundant take}
# MONOIDS
- warn: {lhs: mempty <> x, rhs: x, name: "Monoid law, left identity"}
- warn: {lhs: mempty `mappend` x, rhs: x, name: "Monoid law, left identity"}
- warn: {lhs: x <> mempty, rhs: x, name: "Monoid law, right identity"}
- warn: {lhs: x `mappend` mempty, rhs: x, name: "Monoid law, right identity"}
- warn: {lhs: foldr (<>) mempty, rhs: mconcat}
- warn: {lhs: foldr mappend mempty, rhs: mconcat}
# TRAVERSABLES
- warn: {lhs: sequenceA (map f x), rhs: traverse f x}
- warn: {lhs: sequenceA (fmap f x), rhs: traverse f x}
- warn: {lhs: sequenceA_ (map f x), rhs: traverse_ f x}
- warn: {lhs: sequenceA_ (fmap f x), rhs: traverse_ f x}
- warn: {lhs: foldMap id, rhs: fold}
- warn: {lhs: fold (fmap f x), rhs: foldMap f x}
- warn: {lhs: fold (map f x), rhs: foldMap f x}
- warn: {lhs: foldMap f (fmap g x), rhs: foldMap (f . g) x, name: Fuse foldMap/fmap}
- warn: {lhs: foldMap f (map g x), rhs: foldMap (f . g) x, name: Fuse foldMap/map}
# BY
- warn: {lhs: deleteBy (==), rhs: delete}
- warn: {lhs: groupBy (==), rhs: group}
- warn: {lhs: insertBy compare, rhs: insert}
- warn: {lhs: intersectBy (==), rhs: intersect}
- warn: {lhs: maximumBy compare, rhs: maximum}
- warn: {lhs: minimumBy compare, rhs: minimum}
- warn: {lhs: nubBy (==), rhs: nub}
- warn: {lhs: sortBy compare, rhs: sort}
- warn: {lhs: unionBy (==), rhs: union}
# FOLDS
- warn: {lhs: foldr (>>) (return ()), rhs: sequence_}
- warn: {lhs: foldr (&&) True, rhs: and}
- warn: {lhs: foldl (&&) True, rhs: and, note: IncreasesLaziness}
- warn: {lhs: foldr1 (&&) , rhs: and, note: "RemovesError on `[]`"}
- warn: {lhs: foldl1 (&&) , rhs: and, note: "RemovesError on `[]`"}
- warn: {lhs: foldr (||) False, rhs: or}
- warn: {lhs: foldl (||) False, rhs: or, note: IncreasesLaziness}
- warn: {lhs: foldr1 (||) , rhs: or, note: "RemovesError on `[]`"}
- warn: {lhs: foldl1 (||) , rhs: or, note: "RemovesError on `[]`"}
- warn: {lhs: foldl (+) 0, rhs: sum}
- warn: {lhs: foldr (+) 0, rhs: sum}
- warn: {lhs: foldl1 (+) , rhs: sum, note: "RemovesError on `[]`"}
- warn: {lhs: foldr1 (+) , rhs: sum, note: "RemovesError on `[]`"}
- warn: {lhs: foldl (*) 1, rhs: product}
- warn: {lhs: foldr (*) 1, rhs: product}
- warn: {lhs: foldl1 (*) , rhs: product, note: "RemovesError on `[]`"}
- warn: {lhs: foldr1 (*) , rhs: product, note: "RemovesError on `[]`"}
- warn: {lhs: foldl1 max , rhs: maximum}
- warn: {lhs: foldr1 max , rhs: maximum}
- warn: {lhs: foldl1 min , rhs: minimum}
- warn: {lhs: foldr1 min , rhs: minimum}
- warn: {lhs: foldr mplus mzero, rhs: msum}
# FUNCTION
- warn: {lhs: \x -> x, rhs: id}
- warn: {lhs: \x y -> x, rhs: const}
- warn: {lhs: "\\(x,y) -> y", rhs: snd}
- warn: {lhs: "\\(x,y) -> x", rhs: fst}
- hint: {lhs: "\\x y -> f (x,y)", rhs: curry f}
- hint: {lhs: "\\(x,y) -> f x y", rhs: uncurry f, note: IncreasesLaziness}
- warn: {lhs: f (fst p) (snd p), rhs: uncurry f p}
- warn: {lhs: "uncurry (\\x y -> z)", rhs: "\\(x,y) -> z"}
- warn: {lhs: "curry (\\(x,y) -> z)", rhs: "\\x y -> z"}
- warn: {lhs: uncurry (curry f), rhs: f}
- warn: {lhs: curry (uncurry f), rhs: f}
- warn: {lhs: ($) (f x), rhs: f x, name: Redundant $}
- warn: {lhs: (f $), rhs: f, name: Redundant $}
- warn: {lhs: (Data.Function.& f), rhs: f, name: Redundant Data.Function.&}
- hint: {lhs: \x -> y, rhs: const y, side: isAtom y && not (isWildcard y)}
# If any isWildcard recursively then x may be used but not mentioned explicitly
- warn: {lhs: flip f x y, rhs: f y x, side: isApp original && isAtom y}
- warn: {lhs: id x, rhs: x}
- warn: {lhs: id . x, rhs: x, name: Redundant id}
- warn: {lhs: x . id, rhs: x, name: Redundant id}
- warn: {lhs: "((,) x)", rhs: "(_noParen_ x,)", name: Use tuple-section, note: RequiresExtension TupleSections}
- warn: {lhs: "flip (,) x", rhs: "(,_noParen_ x)", name: Use tuple-section, note: RequiresExtension TupleSections}
# CHAR
- warn: {lhs: a >= 'a' && a <= 'z', rhs: isAsciiLower a}
- warn: {lhs: a >= 'A' && a <= 'Z', rhs: isAsciiUpper a}
- warn: {lhs: a >= '0' && a <= '9', rhs: isDigit a}
- warn: {lhs: a >= '0' && a <= '7', rhs: isOctDigit a}
- warn: {lhs: isLower a || isUpper a, rhs: isAlpha a}
- warn: {lhs: isUpper a || isLower a, rhs: isAlpha a}
# BOOL
- warn: {lhs: x == True, rhs: x, name: Redundant ==}
- hint: {lhs: x == False, rhs: not x, name: Redundant ==}
- warn: {lhs: True == a, rhs: a, name: Redundant ==}
- hint: {lhs: False == a, rhs: not a, name: Redundant ==}
- warn: {lhs: a /= True, rhs: not a, name: Redundant /=}
- hint: {lhs: a /= False, rhs: a, name: Redundant /=}
- warn: {lhs: True /= a, rhs: not a, name: Redundant /=}
- hint: {lhs: False /= a, rhs: a, name: Redundant /=}
- warn: {lhs: if a then x else x, rhs: x, note: IncreasesLaziness, name: Redundant if}
- warn: {lhs: if a then True else False, rhs: a, name: Redundant if}
- warn: {lhs: if a then False else True, rhs: not a, name: Redundant if}
- warn: {lhs: if a then t else (if b then t else f), rhs: if a || b then t else f, name: Redundant if}
- warn: {lhs: if a then (if b then t else f) else f, rhs: if a && b then t else f, name: Redundant if}
- warn: {lhs: if x then True else y, rhs: x || y, side: notEq y False, name: Redundant if}
- warn: {lhs: if x then y else False, rhs: x && y, side: notEq y True, name: Redundant if}
- warn: {lhs: if | b -> t | otherwise -> f, rhs: if b then t else f, name: Redundant multi-way if}
- hint: {lhs: "case a of {True -> t; False -> f}", rhs: if a then t else f, name: Use if}
- hint: {lhs: "case a of {False -> f; True -> t}", rhs: if a then t else f, name: Use if}
- hint: {lhs: "case a of {True -> t; _ -> f}", rhs: if a then t else f, name: Use if}
- hint: {lhs: "case a of {False -> f; _ -> t}", rhs: if a then t else f, name: Use if}
- hint: {lhs: "if c then (True, x) else (False, x)", rhs: "(c, x)", note: IncreasesLaziness, name: Redundant if}
- hint: {lhs: "if c then (False, x) else (True, x)", rhs: "(not c, x)", note: IncreasesLaziness, name: Redundant if}
- hint: {lhs: "or [x, y]", rhs: x || y}
- hint: {lhs: "or [x, y, z]", rhs: x || y || z}
- hint: {lhs: "and [x, y]", rhs: x && y}
- hint: {lhs: "and [x, y, z]", rhs: x && y && z}
- warn: {lhs: if x then False else y, rhs: not x && y, side: notEq y True, name: Redundant if}
- warn: {lhs: if x then y else True, rhs: not x || y, side: notEq y False, name: Redundant if}
- warn: {lhs: not (not x), rhs: x, name: Redundant not}
# ARROW
- warn: {lhs: id *** g, rhs: second g}
- warn: {lhs: f *** id, rhs: first f}
- ignore: {lhs: zip (map f x) (map g x), rhs: map (f Control.Arrow.&&& g) x}
- ignore: {lhs: "\\x -> (f x, g x)", rhs: f Control.Arrow.&&& g}
- hint: {lhs: "(fst x, snd x)", rhs: x, note: DecreasesLaziness, name: Redundant pair}
# BIFUNCTOR
- warn: {lhs: bimap id g, rhs: second g}
- warn: {lhs: bimap f id, rhs: first f}
- warn: {lhs: first id, rhs: id}
- warn: {lhs: second id, rhs: id}
- warn: {lhs: bimap id id, rhs: id}
- warn: {lhs: first f (second g x), rhs: bimap f g x}
- warn: {lhs: second g (first f x), rhs: bimap f g x}
- warn: {lhs: first f (first g x), rhs: first (f . g) x}
- warn: {lhs: second f (second g x), rhs: second (f . g) x}
- warn: {lhs: bimap f h (bimap g i x), rhs: bimap (f . g) (h . i) x}
- warn: {lhs: first f (bimap g h x), rhs: bimap (f . g) h x}
- warn: {lhs: second g (bimap f h x), rhs: bimap f (g . h) x}
- warn: {lhs: bimap f h (first g x), rhs: bimap (f . g) h x}
- warn: {lhs: bimap f g (second h x), rhs: bimap f (g . h) x}
- hint: {lhs: "\\(x,y) -> (f x, g y)", rhs: Data.Bifunctor.bimap f g, note: IncreasesLaziness}
- hint: {lhs: "\\(x,y) -> (f x,y)", rhs: Data.Bifunctor.first f, note: IncreasesLaziness}
- hint: {lhs: "\\(x,y) -> (x,f y)", rhs: Data.Bifunctor.second f, note: IncreasesLaziness}
- hint: {lhs: "(f (fst x), g (snd x))", rhs: Data.Bifunctor.bimap f g x}
- hint: {lhs: "(f (fst x), snd x)", rhs: Data.Bifunctor.first f x}
- hint: {lhs: "(fst x, g (snd x))", rhs: Data.Bifunctor.second g x}
# FUNCTOR
- warn: {lhs: fmap f (fmap g x), rhs: fmap (f . g) x, name: Functor law}
- warn: {lhs: f <$> g <$> x, rhs: f . g <$> x, name: Functor law}
- warn: {lhs: fmap id, rhs: id, name: Functor law}
- warn: {lhs: id <$> x, rhs: x, name: Functor law}
- hint: {lhs: fmap f $ x, rhs: f <$> x, side: isApp x || isAtom x}
- hint: {lhs: \x -> a <$> b x, rhs: fmap a . b}
- hint: {lhs: x *> pure y, rhs: x Data.Functor.$> y}
- hint: {lhs: x *> return y, rhs: x Data.Functor.$> y}
- hint: {lhs: pure x <* y, rhs: x Data.Functor.<$ y}
- hint: {lhs: return x <* y, rhs: x Data.Functor.<$ y}
- hint: {lhs: const x <$> y, rhs: x <$ y}
- hint: {lhs: pure x <$> y, rhs: x <$ y}
- hint: {lhs: return x <$> y, rhs: x <$ y}
- hint: {lhs: x <&> const y, rhs: x Data.Functor.$> y}
- hint: {lhs: x <&> pure y, rhs: x Data.Functor.$> y}
- hint: {lhs: x <&> return y, rhs: x Data.Functor.$> y}
# APPLICATIVE
- hint: {lhs: return x <*> y, rhs: x <$> y}
- hint: {lhs: pure x <*> y, rhs: x <$> y}
- warn: {lhs: x <* pure y, rhs: x}
- warn: {lhs: pure x *> y, rhs: "y"}
# MONAD
- warn: {lhs: return a >>= f, rhs: f a, name: "Monad law, left identity"}
- warn: {lhs: f =<< return a, rhs: f a, name: "Monad law, left identity"}
- warn: {lhs: m >>= return, rhs: m, name: "Monad law, right identity"}
- warn: {lhs: return =<< m, rhs: m, name: "Monad law, right identity"}
- warn: {lhs: liftM, rhs: fmap}
- warn: {lhs: liftA, rhs: fmap}
- hint: {lhs: m >>= return . f, rhs: f <$> m}
- hint: {lhs: return . f =<< m, rhs: f <$> m}
- warn: {lhs: fmap f x >>= g, rhs: x >>= g . f}
- warn: {lhs: f <$> x >>= g, rhs: x >>= g . f}
- warn: {lhs: x Data.Functor.<&> f >>= g, rhs: x >>= g . f}
- warn: {lhs: g =<< fmap f x, rhs: g . f =<< x}
- warn: {lhs: g =<< f <$> x, rhs: g . f =<< x}
- warn: {lhs: g =<< (x Data.Functor.<&> f), rhs: g . f =<< x}
- warn: {lhs: if x then y else return (), rhs: Control.Monad.when x $ _noParen_ y, side: not (isAtom y)}
- warn: {lhs: if x then y else return (), rhs: Control.Monad.when x y, side: isAtom y}
- warn: {lhs: if x then return () else y, rhs: Control.Monad.unless x $ _noParen_ y, side: isAtom y}
- warn: {lhs: if x then return () else y, rhs: Control.Monad.unless x y, side: isAtom y}
- warn: {lhs: sequence (map f x), rhs: mapM f x}
- warn: {lhs: sequence_ (map f x), rhs: mapM_ f x}
- warn: {lhs: sequence (fmap f x), rhs: mapM f x}
- warn: {lhs: sequence_ (fmap f x), rhs: mapM_ f x}
- hint: {lhs: flip mapM, rhs: Control.Monad.forM}
- hint: {lhs: flip mapM_, rhs: Control.Monad.forM_}
- hint: {lhs: flip forM, rhs: mapM}
- hint: {lhs: flip forM_, rhs: mapM_}
- warn: {lhs: when (not x), rhs: unless x}
- warn: {lhs: unless (not x), rhs: when x}
- warn: {lhs: x >>= id, rhs: Control.Monad.join x}
- warn: {lhs: id =<< x, rhs: Control.Monad.join x}
- warn: {lhs: id =<< x, rhs: Control.Monad.join x}
- warn: {lhs: id =<< x, rhs: Control.Monad.join x}
- hint: {lhs: join (f <$> x), rhs: f =<< x}
- hint: {lhs: join (fmap f x), rhs: f =<< x}
- hint: {lhs: a >> return (), rhs: Control.Monad.void a, side: isAtom a || isApp a}
- warn: {lhs: fmap (const ()), rhs: Control.Monad.void}
- warn: {lhs: const () <$> x, rhs: Control.Monad.void x}
- warn: {lhs: flip (>=>), rhs: (<=<)}
- warn: {lhs: flip (<=<), rhs: (>=>)}
- warn: {lhs: flip (>>=), rhs: (=<<)}
- warn: {lhs: flip (=<<), rhs: (>>=)}
- hint: {lhs: \x -> f x >>= g, rhs: f Control.Monad.>=> g}
- hint: {lhs: \x -> f =<< g x, rhs: f Control.Monad.<=< g}
- hint: {lhs: (>>= f) . g, rhs: f Control.Monad.<=< g}
- hint: {lhs: (f =<<) . g, rhs: f Control.Monad.<=< g}
- warn: {lhs: a >> forever a, rhs: forever a}
- hint: {lhs: liftM2 id, rhs: ap}
- warn: {lhs: liftA2 f (return x), rhs: fmap (f x)}
- warn: {lhs: liftM2 f (pure x), rhs: fmap (f x)}
- warn: {lhs: liftM2 f (return x), rhs: fmap (f x)}
- warn: {lhs: fmap f (return x), rhs: return (f x)}
- warn: {lhs: f <$> return x, rhs: return (f x)}
- warn: {lhs: mapM (uncurry f) (zip l m), rhs: zipWithM f l m}
- warn: {lhs: mapM_ (void . f), rhs: mapM_ f}
- warn: {lhs: forM_ x (void . f), rhs: forM_ x f}
- warn: {lhs: a >>= \_ -> b, rhs: a >> b}
- warn: {lhs: m <* return x, rhs: m}
- warn: {lhs: return x *> m, rhs: m}
- warn: {lhs: pure x >> m, rhs: m}
- warn: {lhs: return x >> m, rhs: m}
# STATE MONAD
- warn: {lhs: fst (runState x y), rhs: evalState x y}
- warn: {lhs: snd (runState x y), rhs: execState x y}
# MONAD LIST
- warn: {lhs: fmap unzip (mapM f x), rhs: Control.Monad.mapAndUnzipM f x}
- warn: {lhs: sequence (zipWith f x y), rhs: Control.Monad.zipWithM f x y}
- warn: {lhs: sequence_ (zipWith f x y), rhs: Control.Monad.zipWithM_ f x y}
- warn: {lhs: sequence (replicate n x), rhs: Control.Monad.replicateM n x}
- warn: {lhs: sequence_ (replicate n x), rhs: Control.Monad.replicateM_ n x}
- warn: {lhs: sequenceA (zipWith f x y), rhs: Control.Monad.zipWithM f x y}
- warn: {lhs: sequenceA_ (zipWith f x y), rhs: Control.Monad.zipWithM_ f x y}
- warn: {lhs: sequenceA (replicate n x), rhs: Control.Monad.replicateM n x}
- warn: {lhs: sequenceA_ (replicate n x), rhs: Control.Monad.replicateM_ n x}
- warn: {lhs: mapM f (replicate n x), rhs: Control.Monad.replicateM n (f x)}
- warn: {lhs: mapM_ f (replicate n x), rhs: Control.Monad.replicateM_ n (f x)}
- warn: {lhs: mapM f (map g x), rhs: mapM (f . g) x, name: Fuse mapM/map}
- warn: {lhs: mapM_ f (map g x), rhs: mapM_ (f . g) x, name: Fuse mapM_/map}
- warn: {lhs: traverse f (map g x), rhs: traverse (f . g) x, name: Fuse traverse/map}
- warn: {lhs: traverse_ f (map g x), rhs: traverse_ (f . g) x, name: Fuse traverse_/map}
- warn: {lhs: mapM id, rhs: sequence}
- warn: {lhs: mapM_ id, rhs: sequence_}
# APPLICATIVE / TRAVERSABLE
- warn: {lhs: flip traverse, rhs: for}
- warn: {lhs: flip for, rhs: traverse}
- warn: {lhs: flip traverse_, rhs: for_}
- warn: {lhs: flip for_, rhs: traverse_}
- warn: {lhs: foldr (*>) (pure ()), rhs: sequenceA_}
- warn: {lhs: foldr (<|>) empty, rhs: asum}
- warn: {lhs: liftA2 (flip ($)), rhs: (<**>)}
- warn: {lhs: liftA2 f (pure x), rhs: fmap (f x)}
- warn: {lhs: fmap f (pure x), rhs: pure (f x)}
- warn: {lhs: f <$> pure x, rhs: pure (f x)}
- warn: {lhs: Just <$> a <|> pure Nothing, rhs: optional a}
- hint: {lhs: m >>= pure . f, rhs: f <$> m}
- hint: {lhs: pure . f =<< m, rhs: f <$> m}
- warn: {lhs: empty <|> x, rhs: x, name: "Alternative law, left identity"}
- warn: {lhs: x <|> empty, rhs: x, name: "Alternative law, right identity"}
- warn: {lhs: traverse id, rhs: sequenceA}
- warn: {lhs: traverse_ id, rhs: sequenceA_}
# LIST COMP
- hint: {lhs: "if b then [x] else []", rhs: "[x | b]", name: Use list comprehension}
- hint: {lhs: "if b then [] else [x]", rhs: "[x | not b]", name: Use list comprehension}
- hint: {lhs: "[x | x <- y]", rhs: "y", side: isVar x, name: Redundant list comprehension}
# SEQ
- warn: {lhs: seq x x, rhs: x, name: Redundant seq}
- warn: {lhs: join seq, rhs: id, name: Redundant seq}
- warn: {lhs: id $! x, rhs: x, name: Redundant $!}
- 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: rnf x, name: Redundant seq}
# TUPLE
- warn: {lhs: fst (unzip x), rhs: map fst x}
- warn: {lhs: snd (unzip x), rhs: map snd x}
# MAYBE
- warn: {lhs: maybe x id, rhs: Data.Maybe.fromMaybe x}
- warn: {lhs: maybe Nothing Just, rhs: id, name: Redundant maybe}
- warn: {lhs: maybe False (const True), rhs: Data.Maybe.isJust}
- warn: {lhs: maybe True (const False), rhs: Data.Maybe.isNothing}
- warn: {lhs: maybe False (x ==), rhs: (Just x ==)}
- warn: {lhs: maybe True (x /=), rhs: (Just x /=)}
- warn: {lhs: maybe False (== x), rhs: (Just x ==), note: ValidInstance Eq x}
- warn: {lhs: maybe True (/= x), rhs: (Just x /=), note: ValidInstance Eq x}
- warn: {lhs: fromMaybe False x, rhs: Just True == x} # Eta expanded, see https://github.com/ndmitchell/hlint/issues/970#issuecomment-643645053
- warn: {lhs: fromMaybe True x, rhs: Just False /= x}
- warn: {lhs: not (isNothing x), rhs: isJust x}
- warn: {lhs: not (isJust x), rhs: isNothing x}
- warn: {lhs: "maybe [] (:[])", rhs: maybeToList}
- warn: {lhs: catMaybes (map f x), rhs: mapMaybe f x}
- warn: {lhs: catMaybes (fmap f x), rhs: mapMaybe f x}
- hint: {lhs: case x of Nothing -> y; Just a -> a , rhs: Data.Maybe.fromMaybe y x, side: isAtom y, name: Replace case with fromMaybe}
- hint: {lhs: case x of Just a -> a; Nothing -> y, rhs: Data.Maybe.fromMaybe y x, side: isAtom y, name: Replace case with fromMaybe}
- hint: {lhs: case x of Nothing -> y; Just a -> f a , rhs: maybe y f x, side: isAtom y && isAtom f, name: Replace case with maybe}
- hint: {lhs: case x of Just a -> f a; Nothing -> y, rhs: maybe y f x, side: isAtom y && isAtom f, name: Replace case with maybe}
- warn: {lhs: if isNothing x then y else f (fromJust x), rhs: maybe y f x}
- warn: {lhs: if isJust x then f (fromJust x) else y, rhs: maybe y f x}
- warn: {lhs: maybe Nothing (Just . f), rhs: fmap f}
- hint: {lhs: map fromJust (filter isJust x), rhs: Data.Maybe.catMaybes x}
- warn: {lhs: x == Nothing , rhs: isNothing x}
- warn: {lhs: Nothing == x , rhs: isNothing x}
- warn: {lhs: x /= Nothing , rhs: Data.Maybe.isJust x}
- warn: {lhs: Nothing /= x , rhs: Data.Maybe.isJust x}
- warn: {lhs: concatMap (maybeToList . f), rhs: Data.Maybe.mapMaybe f}
- warn: {lhs: concatMap maybeToList, rhs: catMaybes}
- warn: {lhs: maybe n Just x, rhs: x Control.Applicative.<|> n}
- warn: {lhs: if isNothing x then y else fromJust x, rhs: fromMaybe y x}
- warn: {lhs: if isJust x then fromJust x else y, rhs: fromMaybe y x}
- warn: {lhs: isJust x && (fromJust x == y), rhs: x == Just y}
- warn: {lhs: mapMaybe f (map g x), rhs: mapMaybe (f . g) x, name: Fuse mapMaybe/map}
- warn: {lhs: fromMaybe a (fmap f x), rhs: maybe a f x}
- warn: {lhs: fromMaybe a (f <$> x), rhs: maybe a f x}
- warn: {lhs: mapMaybe id, rhs: catMaybes}
- hint: {lhs: "[x | Just x <- a]", rhs: Data.Maybe.catMaybes a}
- hint: {lhs: case m of Nothing -> Nothing; Just x -> x, rhs: Control.Monad.join m}
- hint: {lhs: maybe Nothing id, rhs: join}
- hint: {lhs: maybe Nothing f x, rhs: f =<< x}
- warn: {lhs: maybe x f (fmap g y), rhs: maybe x (f . g) y, name: Redundant fmap}
- warn: {lhs: isJust (fmap f x), rhs: isJust x}
- warn: {lhs: isNothing (fmap f x), rhs: isNothing x}
- warn: {lhs: fromJust (fmap f x), rhs: f (fromJust x), note: IncreasesLaziness}
- warn: {lhs: mapMaybe f (fmap g x), rhs: mapMaybe (f . g) x, name: Redundant fmap}
# EITHER
- warn: {lhs: "[a | Left a <- a]", rhs: lefts a}
- warn: {lhs: "[a | Right a <- a]", rhs: rights a}
- warn: {lhs: either Left (Right . f), rhs: fmap f}
- warn: {lhs: either f g (fmap h x), rhs: either f (g . h) x, name: Redundant fmap}
- warn: {lhs: isLeft (fmap f x), rhs: isLeft x}
- warn: {lhs: isRight (fmap f x), rhs: isRight x}
- warn: {lhs: fromLeft x (fmap f y), rhs: fromLeft x y}
- warn: {lhs: fromRight x (fmap f y), rhs: either (const x) f y}
# INFIX
- hint: {lhs: elem x y, rhs: x `elem` y, side: not (isInfixApp original) && not (isParen result), name: Use infix}
- hint: {lhs: notElem x y, rhs: x `notElem` y, side: not (isInfixApp original) && not (isParen result), name: Use infix}
- hint: {lhs: isInfixOf x y, rhs: x `isInfixOf` y, side: not (isInfixApp original) && not (isParen result), name: Use infix}
- hint: {lhs: isSuffixOf x y, rhs: x `isSuffixOf` y, side: not (isInfixApp original) && not (isParen result), name: Use infix}
- hint: {lhs: isPrefixOf x y, rhs: x `isPrefixOf` y, side: not (isInfixApp original) && not (isParen result), name: Use infix}
- hint: {lhs: union x y, rhs: x `union` y, side: not (isInfixApp original) && not (isParen result), name: Use infix}
- hint: {lhs: intersect x y, rhs: x `intersect` y, side: not (isInfixApp original) && not (isParen result), name: Use infix}
# MATHS
- warn: {lhs: fromIntegral x, rhs: x, side: isLitInt x, name: Redundant fromIntegral}
- warn: {lhs: fromInteger x, rhs: x, side: isLitInt x, name: Redundant fromInteger}
- hint: {lhs: x + negate y, rhs: x - y}
- hint: {lhs: 0 - x, rhs: negate x}
- warn: {lhs: negate (negate x), rhs: x, name: Redundant negate}
- hint: {lhs: log y / log x, rhs: logBase x y}
- hint: {lhs: sin x / cos x, rhs: tan x}
- hint: {lhs: rem n 2 == 0, rhs: even n}
- hint: {lhs: 0 == rem n 2, rhs: even n}
- hint: {lhs: rem n 2 /= 0, rhs: odd n}
- hint: {lhs: 0 /= rem n 2, rhs: odd n}
- hint: {lhs: mod n 2 == 0, rhs: even n}
- hint: {lhs: 0 == mod n 2, rhs: even n}
- hint: {lhs: mod n 2 /= 0, rhs: odd n}
- hint: {lhs: 0 /= mod n 2, rhs: odd n}
- hint: {lhs: not (even x), rhs: odd x}
- hint: {lhs: not (odd x), rhs: even x}
- hint: {lhs: x ** 0.5, rhs: sqrt x}
- hint: {lhs: x ^ 0, rhs: "1", name: Use 1}
- hint: {lhs: round (x - 0.5), rhs: floor x}
# CONCURRENT
- hint: {lhs: mapM_ (writeChan a), rhs: writeList2Chan a}
- error: {lhs: atomically (readTVar x), rhs: readTVarIO x}
# TYPEABLE
- hint: {lhs: "typeOf (a :: b)", rhs: "typeRep (Proxy :: Proxy b)"}
# EXCEPTION
- hint: {lhs: flip Control.Exception.catch, rhs: handle}
- hint: {lhs: flip handle, rhs: Control.Exception.catch}
- hint: {lhs: flip (catchJust p), rhs: handleJust p}
- hint: {lhs: flip (handleJust p), rhs: catchJust p}
- hint: {lhs: Control.Exception.bracket b (const a) (const t), rhs: Control.Exception.bracket_ b a t}
- hint: {lhs: Control.Exception.bracket (openFile x y) hClose, rhs: withFile x y}
- hint: {lhs: Control.Exception.bracket (openBinaryFile x y) hClose, rhs: withBinaryFile x y}
- hint: {lhs: throw (ErrorCall a), rhs: error a}
- warn: {lhs: toException NonTermination, rhs: nonTermination}
- warn: {lhs: toException NestedAtomically, rhs: nestedAtomically}
# IOREF
- hint: {lhs: modifyIORef r (const x), rhs: writeIORef r x}
- hint: {lhs: modifyIORef r (\v -> x), rhs: writeIORef r x}
# STOREABLE/PTR
- hint: {lhs: castPtr nullPtr, rhs: nullPtr}
- hint: {lhs: castPtr (castPtr x), rhs: castPtr x}
- hint: {lhs: plusPtr (castPtr x), rhs: plusPtr x}
- hint: {lhs: minusPtr (castPtr x), rhs: minusPtr x}
- hint: {lhs: minusPtr x (castPtr y), rhs: minusPtr x y}
- hint: {lhs: peekByteOff (castPtr x), rhs: peekByteOff x}
- hint: {lhs: pokeByteOff (castPtr x), rhs: pokeByteOff x}
# WEAK POINTERS
- warn: {lhs: mkWeak a a b, rhs: mkWeakPtr a b}
- warn: {lhs: "mkWeak a (a, b) c", rhs: mkWeakPair a b c}
# FOLDABLE
- warn: {lhs: case m of Nothing -> return (); Just x -> f x, rhs: Data.Foldable.forM_ m f}
- warn: {lhs: case m of Just x -> f x; Nothing -> return (), rhs: Data.Foldable.forM_ m f}
- warn: {lhs: case m of Just x -> f x; _ -> return (), rhs: Data.Foldable.forM_ m f}
- warn: {lhs: when (isJust m) (f (fromJust m)), rhs: Data.Foldable.forM_ m f}
# STATE MONAD
- warn: {lhs: f <$> Control.Monad.State.get, rhs: gets f}
- warn: {lhs: fmap f Control.Monad.State.get, rhs: gets f}
- warn: {lhs: f <$> Control.Monad.State.gets g, rhs: gets (f . g)}
- warn: {lhs: fmap f (Control.Monad.State.gets g), rhs: gets (f . g)}
- warn: {lhs: f <$> Control.Monad.Reader.ask, rhs: asks f}
- warn: {lhs: fmap f Control.Monad.Reader.ask, rhs: asks f}
- warn: {lhs: f <$> Control.Monad.Reader.asks g, rhs: asks (f . g)}
- warn: {lhs: fmap f (Control.Monad.Reader.asks g), rhs: asks (f . g)}
- warn: {lhs: fst (runState m s), rhs: evalState m s}
- warn: {lhs: snd (runState m s), rhs: execState m s}
# EVALUATE
- warn: {lhs: True && x, rhs: x, name: Evaluate}
- warn: {lhs: False && x, rhs: "False", name: Evaluate}
- warn: {lhs: True || x, rhs: "True", name: Evaluate}
- warn: {lhs: False || x, rhs: x, name: Evaluate}
- warn: {lhs: not True, rhs: "False", name: Evaluate}
- warn: {lhs: not False, rhs: "True", name: Evaluate}
- warn: {lhs: Nothing >>= k, rhs: Nothing, name: Evaluate}
- warn: {lhs: k =<< Nothing, rhs: Nothing, name: Evaluate}
- warn: {lhs: either f g (Left x), rhs: f x, name: Evaluate}
- warn: {lhs: either f g (Right y), rhs: g y, name: Evaluate}
- warn: {lhs: "fst (x,y)", rhs: x, name: Evaluate}
- warn: {lhs: "snd (x,y)", rhs: "y", name: Evaluate}
- warn: {lhs: "init [x]", rhs: "[]", name: Evaluate}
- warn: {lhs: "null []", rhs: "True", name: Evaluate}
- warn: {lhs: "length []", rhs: "0", name: Evaluate}
- warn: {lhs: "foldl f z []", rhs: z, name: Evaluate}
- warn: {lhs: "foldr f z []", rhs: z, name: Evaluate}
- warn: {lhs: "foldr1 f [x]", rhs: x, name: Evaluate}
- warn: {lhs: "scanr f z []", rhs: "[z]", name: Evaluate}
- warn: {lhs: "scanr1 f []", rhs: "[]", name: Evaluate}
- warn: {lhs: "scanr1 f [x]", rhs: "[x]", name: Evaluate}
- warn: {lhs: "take n []", rhs: "[]", note: IncreasesLaziness, name: Evaluate}
- warn: {lhs: "drop n []", rhs: "[]", note: IncreasesLaziness, name: Evaluate}
- warn: {lhs: "takeWhile p []", rhs: "[]", name: Evaluate}
- warn: {lhs: "dropWhile p []", rhs: "[]", name: Evaluate}
- warn: {lhs: "span p []", rhs: "([],[])", name: Evaluate}
- warn: {lhs: lines "", rhs: "[]", name: Evaluate}
- warn: {lhs: "unwords []", rhs: "\"\"", name: Evaluate}
- warn: {lhs: x - 0, rhs: x, name: Evaluate}
- warn: {lhs: x * 1, rhs: x, name: Evaluate}
- warn: {lhs: x / 1, rhs: x, name: Evaluate}
- warn: {lhs: "concat [a]", rhs: a, name: Evaluate}
- warn: {lhs: "concat []", rhs: "[]", name: Evaluate}
- warn: {lhs: "zip [] []", rhs: "[]", name: Evaluate}
- warn: {lhs: const x y, rhs: x, name: Evaluate}
- warn: {lhs: any (const False), rhs: const False, note: IncreasesLaziness, name: Evaluate}
- warn: {lhs: all (const True), rhs: const True, note: IncreasesLaziness, name: Evaluate}
- warn: {lhs: "[] ++ x", rhs: x, name: Evaluate}
- warn: {lhs: "x ++ []", rhs: x, name: Evaluate}
# FOLDABLE + TUPLES
- warn: {lhs: "foldr f z (x,b)", rhs: f b z, name: Using foldr on tuple}
- warn: {lhs: "foldr' f z (x,b)", rhs: f b z, name: Using foldr' on tuple}
- warn: {lhs: "foldl f z (x,b)", rhs: f z b, name: Using foldl on tuple}
- warn: {lhs: "foldl' f z (x,b)", rhs: f z b, name: Using foldl' on tuple}
- warn: {lhs: "foldMap f (x,b)", rhs: f b, name: Using foldMap on tuple}
- warn: {lhs: "foldr1 f (x,b)", rhs: b, name: Using foldr1 on tuple}
- warn: {lhs: "foldl1 f (x,b)", rhs: b, name: Using foldl1 on tuple}
- warn: {lhs: "elem e (x,b)", rhs: e == b, name: Using elem on tuple}
- warn: {lhs: "fold (x,b)", rhs: b, name: Using fold on tuple}
- warn: {lhs: "toList (x,b)", rhs: b, name: Using toList on tuple}
- warn: {lhs: "maximum (x,b)", rhs: b, name: Using maximum on tuple}
- warn: {lhs: "minimum (x,b)", rhs: b, name: Using minimum on tuple}
- warn: {lhs: "sum (x,b)", rhs: b, name: Using sum on tuple}
- warn: {lhs: "product (x,b)", rhs: b, name: Using product on tuple}
- warn: {lhs: "concat (x,b)", rhs: b, name: Using concat on tuple}
- warn: {lhs: "and (x,b)", rhs: b, name: Using and on tuple}
- warn: {lhs: "or (x,b)", rhs: b, name: Using or on tuple}
- warn: {lhs: "any f (x,b)", rhs: f b, name: Using any on tuple}
- warn: {lhs: "all f (x,b)", rhs: f b, name: Using all on tuple}
- warn: {lhs: "foldr f z (x,y,b)", rhs: f b z, name: Using foldr on tuple}
- warn: {lhs: "foldr' f z (x,y,b)", rhs: f b z, name: Using foldr' on tuple}
- warn: {lhs: "foldl f z (x,y,b)", rhs: f z b, name: Using foldl on tuple}
- warn: {lhs: "foldl' f z (x,y,b)", rhs: f z b, name: Using foldl' on tuple}
- warn: {lhs: "foldMap f (x,y,b)", rhs: f b, name: Using foldMap on tuple}
- warn: {lhs: "foldr1 f (x,y,b)", rhs: b, name: Using foldr1 on tuple}
- warn: {lhs: "foldl1 f (x,y,b)", rhs: b, name: Using foldl1 on tuple}
- warn: {lhs: "elem e (x,y,b)", rhs: e == b, name: Using elem on tuple}
- warn: {lhs: "fold (x,y,b)", rhs: b, name: Using fold on tuple}
- warn: {lhs: "toList (x,y,b)", rhs: b, name: Using toList on tuple}
- warn: {lhs: "maximum (x,y,b)", rhs: b, name: Using maximum on tuple}
- warn: {lhs: "minimum (x,y,b)", rhs: b, name: Using minimum on tuple}
- warn: {lhs: "sum (x,y,b)", rhs: b, name: Using sum on tuple}
- warn: {lhs: "product (x,y,b)", rhs: b, name: Using product on tuple}
- warn: {lhs: "concat (x,y,b)", rhs: b, name: Using concat on tuple}
- warn: {lhs: "and (x,y,b)", rhs: b, name: Using and on tuple}
- warn: {lhs: "or (x,y,b)", rhs: b, name: Using or on tuple}
- warn: {lhs: "any f (x,y,b)", rhs: f b, name: Using any on tuple}
- warn: {lhs: "all f (x,y,b)", rhs: f b, name: Using all on tuple}
- warn: {lhs: null x , rhs: "False", side: isTuple x, name: Using null on tuple}
- warn: {lhs: length x, rhs: "1" , side: isTuple x, name: Using length on tuple}
# MAP
- warn: {lhs: "Data.Map.fromList []", rhs: Data.Map.empty}
- warn: {lhs: "Data.Map.Lazy.fromList []", rhs: Data.Map.Lazy.empty}
- warn: {lhs: "Data.Map.Strict.fromList []", rhs: Data.Map.Strict.empty}
- group:
name: lens
enabled: true
imports:
- package base
- package lens
rules:
- warn: {lhs: "(a ^. b) ^. c", rhs: "a ^. (b . c)"}
- warn: {lhs: "fromJust (a ^? b)", rhs: "a ^?! b"}
- warn: {lhs: "a .~ Just b", rhs: "a ?~ b"}
- warn: {lhs: "a & (mapped %~ b)", rhs: "a <&> b"}
- warn: {lhs: "a & ((mapped . b) %~ c)", rhs: "a <&> b %~ c"}
- warn: {lhs: "a & (mapped .~ b)", rhs: "b <$ a"}
- warn: {lhs: "ask <&> (^. a)", rhs: "view a"}
- warn: {lhs: "view a <&> (^. b)", rhs: "view (a . b)"}
# `at` pitfalls:
- warn: {lhs: "Control.Lens.at a . Control.Lens._Just", rhs: "Control.Lens.ix a"}
- error: {lhs: "Control.Lens.has (Control.Lens.at a)", rhs: "True"}
- error: {lhs: "Control.Lens.has (a . Control.Lens.at b)", rhs: "Control.Lens.has a"}
- error: {lhs: "Control.Lens.nullOf (Control.Lens.at a)", rhs: "False"}
- error: {lhs: "Control.Lens.nullOf (a . Control.Lens.at b)", rhs: "Control.Lens.nullOf a"}
- group:
name: use-lens
enabled: false
imports:
- package base
- package lens
rules:
- warn: {lhs: "either Just (const Nothing)", rhs: preview _Left}
- warn: {lhs: "either (const Nothing) Just", rhs: preview _Right}
- group:
name: attoparsec
enabled: true
imports:
- package base
- package attoparsec
rules:
- warn: {lhs: Data.Attoparsec.Text.option Nothing (Just <$> p), rhs: optional p}
- warn: {lhs: Data.Attoparsec.ByteString.option Nothing (Just <$> p), rhs: optional p}
- group:
name: generalise
enabled: false
imports:
- package base
rules:
- warn: {lhs: map, rhs: fmap}
- warn: {lhs: a ++ b, rhs: a <> b}
- warn: {lhs: "sequence [a]", rhs: "pure <$> a"}
- warn: {lhs: "x /= []", rhs: not (null x), name: Use null}
- warn: {lhs: "[] /= x", rhs: not (null x), name: Use null}
- group:
name: generalise-for-conciseness
enabled: false
imports:
- package base
rules:
- warn: {lhs: maybe mempty, rhs: foldMap}
- warn: {lhs: maybe False, rhs: any}
- warn: {lhs: maybe True, rhs: all}
- warn: {lhs: either (const mempty), rhs: foldMap}
- warn: {lhs: either (const False), rhs: any}
- warn: {lhs: either (const True), rhs: all}
- warn: {lhs: Data.Maybe.fromMaybe mempty, rhs: Data.Foldable.fold}
- warn: {lhs: Data.Maybe.fromMaybe 0, rhs: sum}
- warn: {lhs: Data.Maybe.fromMaybe 1, rhs: product}
- warn: {lhs: Data.Maybe.fromMaybe empty, rhs: Data.Foldable.asum}
- warn: {lhs: Data.Maybe.fromMaybe mzero, rhs: Data.Foldable.msum}
- warn: {lhs: Data.Either.fromRight mempty, rhs: Data.Foldable.fold}
- warn: {lhs: Data.Either.fromRight False, rhs: or}
- warn: {lhs: Data.Either.fromRight True, rhs: and}
- warn: {lhs: Data.Either.fromRight 0, rhs: sum}
- warn: {lhs: Data.Either.fromRight 1, rhs: product}
- warn: {lhs: Data.Either.fromRight empty, rhs: Data.Foldable.asum}
- warn: {lhs: Data.Either.fromRight mzero, rhs: Data.Foldable.msum}
- warn: {lhs: if f x then Just x else Nothing, rhs: mfilter f (Just x)}
- hint: {lhs: maybe (pure ()), rhs: traverse_, note: IncreasesLaziness}
- hint: {lhs: fromMaybe (pure ()), rhs: sequenceA_, note: IncreasesLaziness}
- hint: {lhs: fromRight (pure ()), rhs: sequenceA_, note: IncreasesLaziness}
- hint: {lhs: "[fst x, snd x]", rhs: Data.Bifoldable.biList x}
- hint: {lhs: "\\(x, y) -> [x, y]", rhs: Data.Bifoldable.biList, note: IncreasesLaziness}
# hints that use the 'extra' library
- group:
name: extra
enabled: false
rules:
- warn: {lhs: fmap concat (forM a b), rhs: concatForM a b}
- warn: {lhs: concat <$> forM a b, rhs: concatForM a b}
- warn: {lhs: fmap concat (forM_ a b), rhs: concatForM_ a b}
- warn: {lhs: concat <$> forM_ a b, rhs: concatForM_ a b}
- warn: {lhs: "maybe (pure ()) b a", rhs: "whenJust a b"}
- warn: {lhs: "maybe (return ()) b a", rhs: "whenJust a b"}
- warn: {lhs: "maybeM (pure ()) b a", rhs: "whenJustM a b"}
- warn: {lhs: "maybeM (return ()) b a", rhs: "whenJustM a b"}
- warn: {lhs: "if a then Just <$> b else pure Nothing", rhs: "whenMaybe a b"}
- warn: {lhs: "maybe a b =<< c", rhs: "maybeM a b c"}
- warn: {lhs: "maybeM a pure x", rhs: "fromMaybeM a b"}
- warn: {lhs: "maybeM a return x", rhs: "fromMaybeM a b"}
- warn: {lhs: "either a b =<< c", rhs: "eitherM a b c"}
- warn: {lhs: "fold1M a b >> return ()", rhs: "fold1M_ a b"}
- warn: {lhs: "fold1M a b >> pure ()", rhs: "fold1M_ a b"}
- warn: {lhs: "flip concatMapM", rhs: "concatForM"}
- warn: {lhs: "liftM mconcat (mapM a b)", rhs: "mconcatMapM a b"}
- warn: {lhs: "ifM a b (return ())", rhs: "whenM a b"}
- warn: {lhs: "ifM a (return ()) b", rhs: "unlessM a b"}
- warn: {lhs: "ifM a (return True) b", rhs: "(||^) a b"}
- warn: {lhs: "ifM a b (return False)", rhs: "(&&^) a b"}
- warn: {lhs: "anyM id", rhs: "orM"}
- warn: {lhs: "allM id", rhs: "andM"}
- warn: {lhs: "either id id", rhs: "fromEither"}
- warn: {lhs: "either (const Nothing) Just", rhs: "eitherToMaybe"}
- warn: {lhs: "either (Left . a) Right", rhs: "mapLeft a"}
- warn: {lhs: "atomicModifyIORef a (\\ v -> (b v, ()))", rhs: "atomicModifyIORef_ a b"}
- warn: {lhs: "atomicModifyIORef' a (\\ v -> (b v, ()))", rhs: "atomicModifyIORef'_ a b"}
- warn: {lhs: "null (intersect a b)", rhs: "disjoint a b"}
- warn: {lhs: "[minBound .. maxBound]", rhs: "enumerate"}
- warn: {lhs: "zipWithFrom (,)", rhs: "zipFrom"}
- warn: {lhs: "zip [i..]", rhs: "zipFrom i"}
- warn: {lhs: "zipWith f [i..]", rhs: "zipWithFrom f i"}
- warn: {lhs: "dropWhile isSpace", rhs: "trimStart"}
- warn: {lhs: "dropWhileEnd isSpace", rhs: "trimEnd"}
- warn: {lhs: "trimEnd (trimStart a)", rhs: "trim a"}
- warn: {lhs: "map toLower", rhs: "lower"}
- warn: {lhs: "map toUpper", rhs: "upper"}
- warn: {lhs: "mergeBy compare", rhs: "merge"}
- warn: {lhs: "breakEnd (not . a)", rhs: "spanEnd a"}
- warn: {lhs: "spanEnd (not . a)", rhs: "breakEnd a"}
- warn: {lhs: "mconcat (map a b)", rhs: "mconcatMap a b"}
- warn: {lhs: "fromMaybe b (stripPrefix a b)", rhs: "dropPrefix a b"}
- warn: {lhs: "fromMaybe b (stripSuffix a b)", rhs: "dropSuffix a b"}
- warn: {lhs: "nubSortBy compare", rhs: "nubSort"}
- warn: {lhs: "nubSortBy (compare `on` a)", rhs: "nubSortOn a"}
- warn: {lhs: "nubOrdBy compare", rhs: "nubOrd"}
- warn: {lhs: "\\a -> (a, a)", rhs: "dupe"}
- warn: {lhs: "showFFloat (Just a) b \"\"", rhs: "showDP a b"}
- warn: {lhs: "readFileEncoding utf8", rhs: "readFileUTF8"}
- warn: {lhs: "withFile a ReadMode hGetContents'", rhs: "readFile' a"}
- warn: {lhs: "readFileEncoding' utf8", rhs: "readFileUTF8'"}
- warn: {lhs: "withBinaryFile a ReadMode hGetContents'", rhs: "readFileBinary' a"}
- warn: {lhs: "writeFileEncoding utf8", rhs: "writeFileUTF8"}
- warn: {lhs: "head $ x ++ [y]", rhs: "headDef y x"}
- warn: {lhs: "last $ x : y", rhs: "lastDef x y"}
- warn: {lhs: "drop 1", rhs: "drop1"}
- warn: {lhs: "dropEnd 1", rhs: "dropEnd1"}
# hints that will be enabled in future
- group:
name: future
enabled: false
rules:
- warn: {lhs: return, rhs: pure}
- group:
name: dollar
enabled: false
imports:
- package base
rules:
- warn: {lhs: a $ b $ c, rhs: a . b $ c}
- group:
# These hints are same if all matched functions are monomorphic, or polymorphic, but don't have adhoc polymorphism
name: monomorphic
enabled: false
imports:
- package base
rules:
- warn: {lhs: if c then f x else f y, rhs: f (if c then x else y), note: IncreasesLaziness, name: Too strict if}
- hint: {lhs: maybe (f x) (f . g), rhs: f . maybe x g, note: IncreasesLaziness, name: Too strict maybe}
- hint: {lhs: maybe (f x) f y, rhs: f (Data.Maybe.fromMaybe x y), note: IncreasesLaziness, name: Too strict maybe}
- group:
name: codeworld
enabled: false
imports:
- package base
- package codeworld-api
rules:
- warn: {lhs: "pictures [ p ]", rhs: p, name: Evaluate}
- warn: {lhs: "pictures [ p, q ]", rhs: p & q, name: Evaluate}
- hint: {lhs: foldl1 (&), rhs: pictures}
- hint: {lhs: foldr (&) blank, rhs: pictures}
- hint: {lhs: scaled x x, rhs: dilated x}
- hint: {lhs: scaledPoint x x, rhs: dilatedPoint x}
- warn: {lhs: "brighter (- a)", rhs: "duller a"}
- warn: {lhs: "lighter (- a)", rhs: "darker a"}
- warn: {lhs: "duller (- a)", rhs: "brighter a"}
- warn: {lhs: "darker (- a)", rhs: "lighter a"}
- group:
name: teaching
enabled: false
imports:
- package base
rules:
- hint: {lhs: "x /= []", rhs: not (null x), name: Use null}
- hint: {lhs: "[] /= x", rhs: not (null x), name: Use null}
- hint: {lhs: "not (x || y)", rhs: "not x && not y", name: Apply De Morgan law}
- hint: {lhs: "not (x && y)", rhs: "not x || not y", name: Apply De Morgan law}
- hint: {lhs: "[ f x | x <- l ]", rhs: map f l}
- group:
# used for tests, enabled when testing this file
name: testing
enabled: false
rules:
- warn: {lhs: "[issue766| |]", rhs: "mempty", name: "Use mempty"}
#
# yes = concat . map f -- concatMap f
# yes = foo . bar . concat . map f . baz . bar -- concatMap f . baz . bar
# yes = map f (map g x) -- map (f . g) x
# yes = concat.map (\x->if x==e then l' else [x]) -- concatMap (\x->if x==e then l' else [x])
# yes = f x where f x = concat . map head -- concatMap head
# yes = concat . map f . g -- concatMap f . g
# yes = concat $ map f x -- concatMap f x
# yes = "test" ++ concatMap (' ':) ["of","this"] -- unwords ("test":["of","this"])
# yes = if f a then True else b -- f a || b
# yes = not (a == b) -- a /= b
# yes = not (a /= b) -- a == b
# yes = not . (a ==) -- (a /=)
# yes = not . (== a) -- (/= a)
# yes = not . (a /=) -- (a ==)
# yes = not . (/= a) -- (== a)
# yes = if a then 1 else if b then 1 else 2 -- if a || b then 1 else 2
# no = if a then 1 else if b then 3 else 2
# yes = a >>= return . bob -- bob <$> a
# yes = return . bob =<< a -- bob <$> a
# yes = m alice >>= pure . b -- b <$> m alice
# yes = pure .b =<< m alice -- b <$> m alice
# yes = asciiCI "hi" *> pure Hi -- asciiCI "hi" Data.Functor.$> Hi
# yes = asciiCI "bye" *> return Bye -- asciiCI "bye" Data.Functor.$> Bye
# yes = pure x <* y -- x Data.Functor.<$ y
# yes = return x <* y -- x Data.Functor.<$ y
# yes = const x <$> y -- x <$ y
# yes = pure alice <$> [1, 2] -- alice <$ [1, 2]
# yes = return alice <$> "Bob" -- alice <$ "Bob"
# yes = Just a <&> const b -- Just a Data.Functor.$> b
# yes = [a,b] <&> pure c -- [a,b] Data.Functor.$> c
# yes = Hi <&> return bye -- Hi Data.Functor.$> bye
# yes = (x !! 0) + (x !! 2) -- head x
# yes = if b < 42 then [a] else [] -- [a | b < 42]
# no = take n (foo xs) == "hello"
# yes = head (reverse xs) -- last xs
# yes = reverse xs `isPrefixOf` reverse ys -- isSuffixOf xs ys
# no = putStrLn $ show (length xs) ++ "Test"
# yes = ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable -- Data.Bifunctor.bimap toUpper urlEncode
# yes = map (\(a,b) -> a) xs -- fst
# yes = map (\(a,_) -> a) xs -- fst
# yes = readFile $ args !! 0 -- head args
# yes = if Debug `elem` opts then ["--debug"] else [] -- ["--debug" | Debug `elem` opts]
# yes = if nullPS s then return False else if headPS s /= '\n' then return False else alter_input tailPS >> return True \
# -- if nullPS s || (headPS s /= '\n') then return False else alter_input tailPS >> return True
# yes = if foo then do stuff; moreStuff; lastOfTheStuff else return () \
# -- Control.Monad.when foo $ do stuff ; moreStuff ; lastOfTheStuff
# yes = if foo then stuff else return () -- Control.Monad.when foo stuff
# yes = foo $ \(a, b) -> (a, y + b) -- Data.Bifunctor.second ((+) y)
# no = foo $ \(a, b) -> (a, a + b)
# yes = map (uncurry (+)) $ zip [1 .. 5] [6 .. 10] -- zipWith (curry (uncurry (+))) [1 .. 5] [6 .. 10]
# yes = curry (uncurry (+)) -- (+)
# yes = fst foo .= snd foo -- uncurry (.=) foo
# yes = fst foo `_ba__'r''` snd foo -- uncurry _ba__'r'' foo
# no = do iter <- textBufferGetTextIter tb ; textBufferSelectRange tb iter iter
# no = flip f x $ \y -> y*y+y
# no = \x -> f x (g x)
# no = foo (\ v -> f v . g)
# yes = concat . intersperse " " -- unwords
# yes = Prelude.concat $ intersperse " " xs -- unwords xs
# yes = concat $ Data.List.intersperse " " xs -- unwords xs
# yes = if a then True else False -- a
# yes = if x then true else False -- x && true
# yes = elem x y -- x `elem` y
# yes = foo (elem x y) -- x `elem` y
# no = x `elem` y
# no = elem 1 [] : []
# test a = foo (\x -> True) -- const True
# test a = foo (\_ -> True) -- const True
# test a = foo (\x -> x) -- id
# h a = flip f x (y z) -- f (y z) x
# h a = flip f x $ y z
# yes x = case x of {True -> a ; False -> b} -- if x then a else b
# yes x = case x of {False -> a ; _ -> b} -- if x then b else a
# no = const . ok . toResponse $ "saved"
# yes = case x z of Nothing -> y; Just pat -> pat -- Data.Maybe.fromMaybe y (x z)
# yes = if p then s else return () -- Control.Monad.when p s
# warn = a $$$$ b $$$$ c ==> a . b $$$$$ c
# yes = when (not . null $ asdf) -- unless (null asdf)
# yes = (foo . bar . when) (not . null $ asdf) -- (foo . bar) (unless (null asdf))
# yes = id 1 -- 1
# yes = case concat (map f x) of [] -> [] -- concatMap f x
# yes = [v | v <- xs] -- xs
# no = [Left x | Left x <- xs]
# when p s = if p then s else return ()
# no = x ^^ 18.5
# instance Arrow (->) where first f = f *** id
# yes = fromInteger 12 -- 12
# import Prelude hiding (catch); no = catch
# import Control.Exception as E; no = E.catch
# main = do f; putStrLn $ show x -- print x
# main = map (writer,) $ map arcObj $ filter (rdfPredEq (Res dctreferences)) ts -- map ((writer,) . arcObj) (filter (rdfPredEq (Res dctreferences)) ts)
# h x y = return $! (x, y) -- return (x, y)
# h x y = return $! x
# getInt = do { x <- readIO "0"; return $! (x :: Int) }
# 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
# foo = magic . isLeft $ fmap f x -- magic (isLeft x)
# foo = (bar . baz . magic . isRight) (fmap f x) -- (bar . baz . magic) (isRight x)
# main = print $ map (\_->5) [2,3,5] -- const 5
# main = head $ drop n x -- x !! max 0 n
# main = head $ drop (-3) x -- x
# main = head $ drop 2 x -- x !! 2
# main = foo . bar . baz . head $ drop 2 x -- (foo . bar . baz) (x !! 2)
# main = drop 0 x -- x
# main = take 0 x -- []
# main = take (-5) x -- []
# main = take (-y) x
# main = take 4 x
# main = let (first, rest) = (takeWhile p l, dropWhile p l) in rest -- span p l
# main = let (first, rest) = (take n l, drop n l) in rest -- splitAt n l
# main = fst (splitAt n l) -- take n l
# main = snd $ splitAt n l -- drop n l
# main = map $ \ d -> ([| $d |], [| $d |])
# pairs (x:xs) = map (x,) xs ++ pairs xs
# {-# ANN foo "HLint: ignore" #-};foo = map f (map g x) -- @Ignore ???
# {-# HLINT ignore foo #-};foo = map f (map g x) -- @Ignore ???
# yes = fmap lines $ abc 123 -- lines <$> abc 123
# no = fmap lines $ abc $ def 123
# test = foo . not . not -- id
# test = map (not . not) xs -- id
# used = not . not . any (`notElem` special) . fst . derives -- any (`notElem` special) . fst . derives
# test = foo . id . map -- map
# test = food id xs
# yes = baz baz >> return () -- Control.Monad.void (baz baz)
# no = foo >>= bar >>= something >>= elsee >> return ()
# no = f (#) x
# data Pair = P {a :: !Int}; foo = return $! P{a=undefined}
# data Pair = P {a :: !Int}; foo = return $! P undefined
# foo = return $! Just undefined -- return (Just undefined)
# foo = return $! (a,b) -- return (a,b)
# foo = return $! 1
# 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
# g = \ f -> parseFile f >>= (\ cu -> return (f, cu))
# foo = bar $ \(x,y) -> x x y
# foo = (\x -> f x >>= g) -- f Control.Monad.>=> g
# foo = (\f -> h f >>= g) -- h Control.Monad.>=> g
# foo = (\f -> h f >>= f)
# foo = bar $ \x -> [x,y]
# foo = bar $ \x -> [z,y] -- const [z,y]
# f condition tChar tBool = if condition then _monoField tChar else _monoField tBool
# foo = maybe Bar{..} id -- Data.Maybe.fromMaybe Bar{..}
# foo = (\a -> Foo {..}) 1
# foo = zipWith SymInfo [0 ..] (repeat ty) -- map (\ x -> SymInfo x ty) [0 ..]
# f rec = rec
# mean x = fst $ foldl (\(m, n) x' -> (m+(x'-m)/(n+1),n+1)) (0,0) x
# {-# LANGUAGE TypeApplications #-} \
# foo = id @Int
# {-# LANGUAGE TypeApplications #-} \
# foo = const @_ @SomeException
# foo = id 12 -- 12
# yes = foldr (\ curr acc -> (+ 1) curr : acc) [] -- map (\ curr -> (+ 1) curr)
# yes = foldr (\ curr acc -> curr + curr : acc) [] -- map (\ curr -> curr + curr)
# no = foo $ (,) x $ do {this is a test; and another test}
# no = sequence (return x)
# no = sequenceA (pure a)
# {-# LANGUAGE QuasiQuotes #-}; no = f (\url -> [hamlet|foo @{url}|])
# yes = f ((,) x) -- (x,)
# yes = f ((,) (2 + 3)) -- (2 + 3,)
# instance Class X where method = map f (map g x) -- map (f . g) x
# instance Eq X where x == y = compare x y == EQ
# issue1055 = map f ((sort . map g) xs)
# issue1049 = True `elem` xs -- or xs
# issue1049 = elem True -- or
# issue1062 = bar (\(f, x) -> baz () () . f $ x) -- uncurry ((.) (baz () ()))
# issue1058 n = [] ++ issue1058 (n+1) -- issue1058 (n+1)
# import Prelude \
# yes = flip mapM -- Control.Monad.forM
# import Control.Monad \
# yes = flip mapM -- forM
# import Control.Monad(forM) \
# yes = flip mapM -- forM
# import Control.Monad(forM_) \
# yes = flip mapM -- Control.Monad.forM
# import qualified Control.Monad \
# yes = flip mapM -- Control.Monad.forM
# import qualified Control.Monad as CM \
# yes = flip mapM -- CM.forM
# import qualified Control.Monad as CM(forM,filterM) \
# yes = flip mapM -- CM.forM
# import Control.Monad as CM(forM,filterM) \
# yes = flip mapM -- forM
# import Control.Monad hiding (forM) \
# yes = flip mapM -- Control.Monad.forM
# import Control.Monad hiding (filterM) \
# yes = flip mapM -- forM
# import qualified Data.Text.Lazy as DTL \
# main = DTL.concat $ map (`DTL.snoc` '-') [DTL.pack "one", DTL.pack "two", DTL.pack "three"]
# import Text.Blaze.Html5.Attributes as A \
# main = A.id (stringValue id')
# import Prelude((==)) \
# import qualified Prelude as P \
# main = P.length xs == 0 -- P.null xs
# main = hello .~ Just 12 -- hello ?~ 12
# foo = liftIO $ window `on` deleteEvent $ do a; b
# no = sort <$> f input `shouldBe` sort <$> x
# sortBy (comparing length) -- sortOn length
# myJoin = on $ child ^. ChildParentId ==. parent ^. ParentId
# foo = typeOf (undefined :: Foo Int) -- typeRep (Proxy :: Proxy (Foo Int))
# foo = typeOf (undefined :: a) -- typeRep (Proxy :: Proxy a)
# {-# RULES "Id-fmap-id" forall (x :: Id a). fmap id x = x #-}
# import Data.Map (fromList) \
# fromList [] -- Data.Map.empty
# import Data.Map.Lazy (fromList) \
# fromList [] -- Data.Map.Lazy.empty
# import Data.Map.Strict (fromList) \
# fromList [] -- Data.Map.Strict.empty
# test953 = for [] $ \n -> bar n >>= \case {Just n -> pure (); Nothing -> baz n}
# f = map (flip (,) "a") "123" -- (,"a")
# f = map ((,) "a") "123" -- ("a",)
# test979 = flip Map.traverseWithKey blocks \k v -> lots_of_code_goes_here
# infixl 4 <*! \
# test993 = f =<< g <$> x <*! y
# {-# LANGUAGE QuasiQuotes #-} \
# test = [issue766| |] -- mempty
# {-# LANGUAGE QuasiQuotes #-} \
# test = [issue766| x |]
#
hlint-3.1.6/data/hlint.ghci 0000644 0000000 0000000 00000002444 12725731243 013722 0 ustar 00 0000000 0000000 -- -*- mode: haskell; -*-
-- Begin copied material.
--
:{
:def redir \varcmd -> return $
case break Data.Char.isSpace varcmd of
(var,_:cmd) -> unlines
[":set -fno-print-bind-result"
,"tmp <- System.Directory.getTemporaryDirectory"
,"(f,h) <- System.IO.openTempFile tmp \"ghci\""
,"sto <- GHC.IO.Handle.hDuplicate System.IO.stdout"
,"GHC.IO.Handle.hDuplicateTo h System.IO.stdout"
,"System.IO.hClose h"
,cmd
,"GHC.IO.Handle.hDuplicateTo sto System.IO.stdout"
,"let readFileNow f = readFile f >>= \\t->Data.List.length t `seq` return t"
,var++" <- readFileNow f"
,"System.Directory.removeFile f"
]
_ -> "putStrLn \"usage: :redir \""
:}
--- Integration with the hlint code style tool
:{
:def hlint \extra -> return $ unlines
[":unset +t +s"
,":set -w"
,":redir hlintvar1 :show modules"
,":cmd return $ \":! hlint \" ++ unwords (map (takeWhile (/=',') . drop 2 . dropWhile (/= '(')) $ lines hlintvar1) ++ \" \" ++ " ++ show extra
,":set +t +s -Wall"
]
:}
hlint-3.1.6/data/hlint.1 0000644 0000000 0000000 00000002424 13472452374 013153 0 ustar 00 0000000 0000000 .TH HLINT "1" "July 2009" "HLint (C) Neil Mitchell 2006-2009" "User Commands"
.SH NAME
HLint \- haskell source code suggestions
.SH SYNOPSIS
.B hlint
[\fIfiles/directories\fR] [\fIoptions\fR]
.SH DESCRIPTION
\fIHLint\fR is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies.
.SH OPTIONS
.TP
\fB\-?\fR \fB\-\-help\fR
Display help message
.TP
\fB\-v\fR \fB\-\-version\fR
Display version information
.TP
\fB\-r[file]\fR \fB\-\-report\fR[=\fIfile\fR]
Generate a report in HTML
.TP
\fB\-h\fR \fIfile\fR \fB\-\-hint\fR=\fIfile\fR
Hint/ignore file to use
.TP
\fB\-c\fR \fB\-\-color\fR, \fB\-\-colour\fR
Color the output (requires ANSI terminal)
.TP
\fB\-i\fR \fImessage\fR \fB\-\-ignore\fR=\fImessage\fR
Ignore a particular hint
.TP
\fB\-s\fR \fB\-\-show\fR
Show all ignored ideas
.TP
\fB\-t\fR \fB\-\-test\fR
Run in test mode
.SH EXAMPLE
"To check all Haskell files in 'src' and generate a report type:"
.IP
hlint src \fB\-\-report\fR
.SH "SEE ALSO"
The full documentation for
.B HLint
is available in \fI/usr/share/doc/hlint/hlint.html\fI.
.SH AUTHOR
This manual page was written by Joachim Breitner
for the Debian system (but may be used by others).
hlint-3.1.6/data/default.yaml 0000644 0000000 0000000 00000003344 13075153430 014253 0 ustar 00 0000000 0000000 # HLint configuration file
# https://github.com/ndmitchell/hlint
##########################
# This file contains a template configuration file, which is typically
# placed as .hlint.yaml in the root of your project
# Specify additional command line arguments
#
# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
# Control which extensions/flags/modules/functions can be used
#
# - extensions:
# - default: false # all extension are banned by default
# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
#
# - flags:
# - {name: -w, within: []} # -w is allowed nowhere
#
# - modules:
# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
# - {name: Control.Arrow, within: []} # Certain modules are banned entirely
#
# - functions:
# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
# Add custom hints for this project
#
# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
# Turn on hints that are off by default
#
# Ban "module X(module X) where", to require a real export list
# - warn: {name: Use explicit module export list}
#
# Replace a $ b $ c with a . b $ c
# - group: {name: dollar, enabled: true}
#
# Generalise map to fmap, ++ to <>
# - group: {name: generalise, enabled: true}
# Ignore some builtin hints
# - ignore: {name: Use let}
# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
# Define some custom infix operators
# - fixity: infixr 3 ~^#^~
# To generate a suitable file for HLint do:
# $ hlint --default > .hlint.yaml