module HLint(hlint) where
import Control.Applicative
import Control.Monad.Extra
import Control.Exception
import System.Console.CmdArgs.Verbosity
import Data.List
import System.Exit
import System.IO.Extra
import Data.Tuple.Extra
import Prelude
import Data.Version
import System.Process.Extra
import Data.Maybe
import System.Directory
import Text.ParserCombinators.ReadP
import CmdLine
import Settings
import Report
import Idea
import Apply
import Test.All
import Grep
import Test.Proof
import Util
import Parallel
import HSE.All
hlint :: [String] -> IO [Idea]
hlint args = do
cmd <- getCmd args
case cmd of
CmdMain{} -> do xs <- hlintMain cmd; return $ if cmdNoExitCode cmd then [] else xs
CmdGrep{} -> hlintGrep cmd >> return []
CmdHSE{} -> hlintHSE cmd >> return []
CmdTest{} -> hlintTest cmd >> return []
hlintHSE :: Cmd -> IO ()
hlintHSE c@CmdHSE{..} = do
v <- getVerbosity
forM_ cmdFiles $ \x -> do
putStrLn $ "Parse result of " ++ x ++ ":"
let (lang,exts) = cmdExtensions c
res <- parseFileWithMode defaultParseMode{baseLanguage=lang, extensions=exts} x
case res of
x@ParseFailed{} -> print x
ParseOk m -> case v of
Loud -> print m
Quiet -> print $ prettyPrint m
_ -> print $ void m
putStrLn ""
hlintTest :: Cmd -> IO ()
hlintTest cmd@CmdTest{..} =
if not $ null cmdProof then do
files <- cmdHintFiles cmd
s <- readSettings2 cmdDataDir files []
let reps = if cmdReports == ["report.html"] then ["report.txt"] else cmdReports
mapM_ (proof reps s) cmdProof
else do
failed <- test cmd (\args -> do errs <- hlint args; unless (null errs) $ exitWith $ ExitFailure 1) cmdDataDir cmdGivenHints
when (failed > 0) exitFailure
hlintGrep :: Cmd -> IO ()
hlintGrep cmd@CmdGrep{..} = do
encoding <- if cmdUtf8 then return utf8 else readEncoding cmdEncoding
let flags = parseFlagsSetLanguage (cmdExtensions cmd) $
defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding}
if null cmdFiles then
exitWithHelp
else do
files <- concatMapM (resolveFile cmd Nothing) cmdFiles
if null files then
error "No files found"
else
runGrep cmdPattern flags files
hlintMain :: Cmd -> IO [Idea]
hlintMain cmd@CmdMain{..} = do
encoding <- if cmdUtf8 then return utf8 else readEncoding cmdEncoding
let flags = parseFlagsSetLanguage (cmdExtensions cmd) $
defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding}
if null cmdFiles && not (null cmdFindHints) then do
hints <- concatMapM (resolveFile cmd Nothing) cmdFindHints
mapM_ (putStrLn . fst <=< findSettings2 flags) hints >> return []
else if null cmdFiles then
exitWithHelp
else if cmdRefactor then
withTempFile (\t -> runHlintMain cmd (Just t) flags)
else runHlintMain cmd Nothing flags
runHlintMain :: Cmd -> Maybe FilePath -> ParseFlags -> IO [Idea]
runHlintMain cmd@CmdMain{..} fp flags = do
files <- concatMapM (resolveFile cmd fp) cmdFiles
if null files
then error "No files found"
else runHints cmd{cmdFiles=files} flags
readAllSettings :: Cmd -> ParseFlags -> IO [Setting]
readAllSettings cmd@CmdMain{..} flags = do
files <- cmdHintFiles cmd
settings1 <- readSettings2 cmdDataDir files cmdWithHints
settings2 <- concatMapM (fmap snd . findSettings2 flags) cmdFindHints
settings3 <- return [SettingClassify $ Classify Ignore x "" "" | x <- cmdIgnore]
return $ settings1 ++ settings2 ++ settings3
runHints :: Cmd -> ParseFlags -> IO [Idea]
runHints cmd@CmdMain{..} flags = do
let outStrLn = whenNormal . putStrLn
settings <- readAllSettings cmd flags
ideas <- getIdeas cmd settings flags
let (showideas,hideideas) = partition (\i -> cmdShowAll || ideaSeverity i /= Ignore) ideas
if cmdJson
then putStrLn . showIdeasJson $ showideas
else if cmdSerialise then do
hSetBuffering stdout NoBuffering
print $ map (show &&& ideaRefactoring) showideas
else if cmdRefactor then
handleRefactoring showideas cmdFiles cmd
else do
usecolour <- cmdUseColour cmd
showItem <- if usecolour then showANSI else return show
mapM_ (outStrLn . showItem) showideas
handleReporting showideas hideideas cmd
return showideas
getIdeas :: Cmd -> [Setting] -> ParseFlags -> IO [Idea]
getIdeas cmd@CmdMain{..} settings flags = do
ideas <- if cmdCross
then applyHintFiles flags settings cmdFiles
else concat <$> parallel [evaluateList =<< applyHintFile flags settings x Nothing | x <- cmdFiles]
return $ if not (null cmdOnly)
then [i | i <- ideas, ideaHint i `elem` cmdOnly]
else ideas
handleRefactoring :: [Idea] -> [String] -> Cmd -> IO ()
handleRefactoring showideas files cmd@CmdMain{..} =
case cmdFiles of
[file] -> do
path <- checkRefactor (if cmdWithRefactor == "" then Nothing else Just cmdWithRefactor)
let hints = show $ map (show &&& ideaRefactoring) showideas
withTempFile $ \f -> do
writeFile f hints
runRefactoring path file f cmdRefactorOptions
>>= exitWith
_ -> error "Refactor flag can only be used with an individual file"
handleReporting :: [Idea] -> [Idea] -> Cmd -> IO ()
handleReporting showideas hideideas cmd@CmdMain{..} = do
let outStrLn = whenNormal . putStrLn
if null showideas then
when (cmdReports /= []) $ outStrLn "Skipping writing reports"
else
forM_ cmdReports $ \x -> do
outStrLn $ "Writing report to " ++ x ++ " ..."
writeReport cmdDataDir x showideas
unless cmdNoSummary $
outStrLn $
(let i = length showideas in if i == 0 then "No hints" else show i ++ " hint" ++ ['s' | i/=1]) ++
(let i = length hideideas in if i == 0 then "" else " (" ++ show i ++ " ignored)")
runRefactoring :: FilePath -> FilePath -> FilePath -> String -> IO ExitCode
runRefactoring rpath fin hints opts = do
let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints]
(_, _, _, phand) <- createProcess $ proc rpath args
try $ hSetBuffering stdin LineBuffering :: IO (Either IOException ())
hSetBuffering stdout LineBuffering
waitForProcess phand
checkRefactor :: Maybe FilePath -> IO FilePath
checkRefactor rpath = do
let excPath = fromMaybe "refactor" rpath
mexc <- findExecutable excPath
case mexc of
Just exc -> do
vers <- readP_to_S parseVersion . tail <$> readProcess exc ["--version"] ""
case vers of
[] -> putStrLn "Unabled to determine version of refactor" >> return exc
(last -> (version, _)) -> if versionBranch version >= [0,1,0,0]
then return exc
else error "Your version of refactor is too old, please upgrade to the latest version"
Nothing -> error $ unlines [ "Could not find refactor"
, "Tried with: " ++ excPath ]
evaluateList :: [a] -> IO [a]
evaluateList xs = length xs `seq` return xs