{-# LANGUAGE PatternGuards, DeriveDataTypeable, TupleSections #-}
{-# OPTIONS_GHC -Wno-missing-fields -fno-cse -O0 #-}
module CmdLine(
Cmd(..), getCmd,
CppFlags(..), cmdCpp, cmdExtensions, cmdHintFiles, cmdUseColour,
exitWithHelp, resolveFile
) where
import Control.Monad.Extra
import Control.Exception.Extra
import qualified Data.ByteString as BS
import Data.Char
import Data.List.Extra
import Data.Maybe
import Data.Functor
import HSE.All(CppFlags(..))
import GHC.LanguageExtensions.Type
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx
import DynFlags hiding (verbosity)
import Language.Preprocessor.Cpphs
import System.Console.ANSI(hSupportsANSI)
import System.Console.CmdArgs.Explicit(helpText, HelpFormat(..))
import System.Console.CmdArgs.Implicit
import System.Directory.Extra
import System.Environment.Extra
import System.Exit
import System.FilePath
import System.IO
import System.IO.Error
import System.Info.Extra
import System.Process
import System.FilePattern
import EmbedData
import Util
import Extension
import Paths_hlint
import Data.Version
import Prelude
getCmd :: [String] -> IO Cmd
getCmd args = withArgs (map f args) $ automatic =<< cmdArgsRun mode
where f x = if x == "-?" || x == "--help" then "--help=all" else x
automatic :: Cmd -> IO Cmd
automatic cmd = case cmd of
CmdMain{} -> dataDir =<< path =<< git =<< extension cmd
CmdGrep{} -> path =<< extension cmd
CmdTest{} -> dataDir cmd
where
path cmd = pure $ if null $ cmdPath cmd then cmd{cmdPath=["."]} else cmd
extension cmd = pure $ if null $ cmdExtension cmd then cmd{cmdExtension=["hs","lhs"]} else cmd
dataDir cmd
| cmdDataDir cmd /= "" = pure cmd
| otherwise = do
x <- getDataDir
b <- doesDirectoryExist x
if b then pure cmd{cmdDataDir=x} else do
exe <- getExecutablePath
pure cmd{cmdDataDir = takeDirectory exe </> "data"}
git cmd
| cmdGit cmd = do
mgit <- findExecutable "git"
case mgit of
Nothing -> errorIO "Could not find git"
Just git -> do
let args = ["ls-files", "--cached", "--others", "--exclude-standard"] ++
map ("*." ++) (cmdExtension cmd)
files <- readProcess git args ""
pure cmd{cmdFiles = cmdFiles cmd ++ lines files}
| otherwise = pure cmd
exitWithHelp :: IO a
exitWithHelp = do
putStr $ show $ helpText [] HelpFormatAll mode
exitSuccess
data ColorMode
= Never
| Always
| Auto
deriving (Show, Typeable, Data)
instance Default ColorMode where
def = if isWindows then Never else Auto
data Cmd
= CmdMain
{cmdFiles :: [FilePath]
,cmdReports :: [FilePath]
,cmdGivenHints :: [FilePath]
,cmdWithGroups :: [String]
,cmdGit :: Bool
,cmdColor :: ColorMode
,cmdThreads :: Int
,cmdIgnore :: [String]
,cmdShowAll :: Bool
,cmdExtension :: [String]
,cmdLanguage :: [String]
,cmdCross :: Bool
,cmdFindHints :: [FilePath]
,cmdDataDir :: FilePath
,cmdDefault :: Bool
,cmdPath :: [String]
,cmdCppDefine :: [String]
,cmdCppInclude :: [FilePath]
,cmdCppFile :: [FilePath]
,cmdCppSimple :: Bool
,cmdCppAnsi :: Bool
,cmdJson :: Bool
,cmdCC :: Bool
,cmdNoSummary :: Bool
,cmdOnly :: [String]
,cmdNoExitCode :: Bool
,cmdTiming :: Bool
,cmdSerialise :: Bool
,cmdRefactor :: Bool
,cmdRefactorOptions :: String
,cmdWithRefactor :: FilePath
,cmdIgnoreGlob :: [FilePattern]
}
| CmdGrep
{cmdFiles :: [FilePath]
,cmdPattern :: String
,cmdExtension :: [String]
,cmdLanguage :: [String]
,cmdPath :: [String]
,cmdCppDefine :: [String]
,cmdCppInclude :: [FilePath]
,cmdCppFile :: [FilePath]
,cmdCppSimple :: Bool
,cmdCppAnsi :: Bool
}
| CmdTest
{cmdProof :: [FilePath]
,cmdGivenHints :: [FilePath]
,cmdDataDir :: FilePath
,cmdReports :: [FilePath]
,cmdTempDir :: FilePath
,cmdQuickCheck :: Bool
,cmdTypeCheck :: Bool
,cmdWithRefactor :: FilePath
}
deriving (Data,Typeable,Show)
mode = cmdArgsMode $ modes
[CmdMain
{cmdFiles = def &= args &= typ "FILE/DIR"
,cmdReports = nam "report" &= opt "report.html" &= typFile &= help "Generate a report in HTML"
,cmdGivenHints = nam "hint" &= typFile &= help "Hint/ignore file to use"
,cmdWithGroups = nam_ "with-group" &= typ "GROUP" &= help "Extra hint groups to use"
,cmdGit = nam "git" &= help "Run on files tracked by git"
,cmdColor = nam "colour" &= name "color" &= opt Always &= typ "always/never/auto" &= help "Color output (requires ANSI terminal; auto means on when $TERM is supported; by itself, selects always)"
,cmdThreads = 1 &= name "threads" &= name "j" &= opt (0 :: Int) &= help "Number of threads to use (-j for all)"
,cmdIgnore = nam "ignore" &= typ "HINT" &= help "Ignore a particular hint"
,cmdShowAll = nam "show" &= help "Show all ignored ideas"
,cmdExtension = nam "extension" &= typ "EXT" &= help "File extensions to search (default hs/lhs)"
,cmdLanguage = nam_ "language" &= name "X" &= typ "EXTENSION" &= help "Language extensions (Arrows, NoCPP)"
,cmdCross = nam_ "cross" &= help "Work between modules"
,cmdFindHints = nam "find" &= typFile &= help "Find hints in a Haskell file"
,cmdDataDir = nam_ "datadir" &= typDir &= help "Override the data directory"
,cmdDefault = nam "default" &= help "Print a default file to stdout"
,cmdPath = nam "path" &= help "Directory in which to search for files"
,cmdCppDefine = nam_ "cpp-define" &= typ "NAME[=VALUE]" &= help "CPP #define"
,cmdCppInclude = nam_ "cpp-include" &= typDir &= help "CPP include path"
,cmdCppFile = nam_ "cpp-file" &= typFile &= help "CPP pre-include file"
,cmdCppSimple = nam_ "cpp-simple" &= help "Use a simple CPP (strip # lines)"
,cmdCppAnsi = nam_ "cpp-ansi" &= help "Use CPP in ANSI compatibility mode"
,cmdJson = nam_ "json" &= help "Display hint data as JSON"
,cmdCC = nam_ "cc" &= help "Display hint data as Code Climate Issues"
,cmdNoSummary = nam_ "no-summary" &= help "Do not show summary information"
,cmdOnly = nam "only" &= typ "HINT" &= help "Specify which hints explicitly"
,cmdNoExitCode = nam_ "no-exit-code" &= help "Do not give a negative exit if hints"
,cmdTiming = nam_ "timing" &= help "Display timing information"
,cmdSerialise = nam_ "serialise" &= help "Serialise hint data for consumption by apply-refact"
,cmdRefactor = nam_ "refactor" &= help "Automatically invoke `refactor` to apply hints"
,cmdRefactorOptions = nam_ "refactor-options" &= typ "OPTIONS" &= help "Options to pass to the `refactor` executable"
,cmdWithRefactor = nam_ "with-refactor" &= help "Give the path to refactor"
,cmdIgnoreGlob = nam_ "ignore-glob" &= help "Ignore paths matching glob pattern"
} &= auto &= explicit &= name "lint"
,CmdGrep
{cmdFiles = def &= args &= typ "FILE/DIR"
,cmdPattern = def &= argPos 0 &= typ "PATTERN"
} &= explicit &= name "grep"
,CmdTest
{cmdProof = nam_ "proof" &= typFile &= help "Isabelle/HOLCF theory file"
,cmdTypeCheck = nam_ "typecheck" &= help "Use GHC to type check the hints"
,cmdQuickCheck = nam_ "quickcheck" &= help "Use QuickCheck to check the hints"
,cmdTempDir = nam_ "tempdir" &= help "Where to put temporary files (not cleaned up)"
} &= explicit &= name "test"
&= details ["HLint gives hints on how to improve Haskell code."
,""
,"To check all Haskell files in 'src' and generate a report type:"
," hlint src --report"]
] &= program "hlint" &= verbosity
&= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2020")
where
nam xs = nam_ xs &= name [head xs]
nam_ xs = def &= explicit &= name xs
cmdHintFiles :: Cmd -> IO [(FilePath, Maybe String)]
cmdHintFiles cmd = do
let explicit = cmdGivenHints cmd
bad <- filterM (notM . doesFileExist) explicit
when (bad /= []) $
fail $ unlines $ "Failed to find requested hint files:" : map (" "++) bad
implicit <- if explicit /= [] then pure Nothing else do
curdir <- getCurrentDirectory
home <- catchIOError ((:[]) <$> getHomeDirectory) (const $ pure [])
findM doesFileExist $
map (</> ".hlint.yaml") (ancestors curdir ++ home)
pure $ hlintYaml : map (,Nothing) (maybeToList implicit ++ explicit)
where
ancestors = init . map joinPath . reverse . inits . splitPath
cmdExtensions :: Cmd -> (Maybe Language, [Extension])
cmdExtensions = getExtensions . cmdLanguage
cmdCpp :: Cmd -> CppFlags
cmdCpp cmd
| cmdCppSimple cmd = CppSimple
| Cpp `elem` snd (cmdExtensions cmd) = Cpphs defaultCpphsOptions
{boolopts=defaultBoolOptions{hashline=False, stripC89=True, ansi=cmdCppAnsi cmd}
,includes = cmdCppInclude cmd
,preInclude = cmdCppFile cmd
,defines = ("__HLINT__","1") : [(a,drop1 b) | x <- cmdCppDefine cmd, let (a,b) = break (== '=') x]
}
| otherwise = NoCpp
cmdUseColour :: Cmd -> IO Bool
cmdUseColour cmd = case cmdColor cmd of
Always -> pure True
Never -> pure False
Auto -> hSupportsANSI stdout
"." <\> x = x
x <\> y = x </> y
resolveFile
:: Cmd
-> Maybe FilePath
-> FilePath
-> IO [FilePath]
resolveFile cmd = getFile (toPredicate $ cmdIgnoreGlob cmd) (cmdPath cmd) (cmdExtension cmd)
where
toPredicate :: [FilePattern] -> FilePath -> Bool
toPredicate [] = const False
toPredicate globs = \x -> not $ null $ m [((), cleanup x)]
where m = matchMany (map ((),) globs)
cleanup :: FilePath -> FilePath
cleanup ('.':x:xs) | isPathSeparator x, not $ null xs = xs
cleanup x = x
getFile :: (FilePath -> Bool) -> [FilePath] -> [String] -> Maybe FilePath -> FilePath -> IO [FilePath]
getFile _ path _ (Just tmpfile) "-" =
BS.getContents >>= BS.writeFile tmpfile >> pure [tmpfile]
getFile _ path _ Nothing "-" = pure ["-"]
getFile _ [] exts _ file = exitMessage $ "Couldn't find file: " ++ file
getFile ignore (p:ath) exts t file = do
isDir <- doesDirectoryExist $ p <\> file
if isDir then do
let avoidDir x = let y = takeFileName x in "_" `isPrefixOf` y || ("." `isPrefixOf` y && not (all (== '.') y))
avoidFile x = let y = takeFileName x in "." `isPrefixOf` y || ignore x
xs <- listFilesInside (pure . not . avoidDir) $ p <\> file
pure [x | x <- xs, drop1 (takeExtension x) `elem` exts, not $ avoidFile x]
else do
isFil <- doesFileExist $ p <\> file
if isFil then pure [p <\> file]
else do
res <- getModule p exts file
case res of
Just x -> pure [x]
Nothing -> getFile ignore ath exts t file
getModule :: FilePath -> [String] -> FilePath -> IO (Maybe FilePath)
getModule path exts x | not (any isSpace x) && all isMod xs = f exts
where
xs = words $ map (\x -> if x == '.' then ' ' else x) x
isMod (x:xs) = isUpper x && all (\x -> isAlphaNum x || x == '_') xs
isMod _ = False
pre = path <\> joinPath xs
f [] = pure Nothing
f (x:xs) = do
let s = pre <.> x
b <- doesFileExist s
if b then pure $ Just s else f xs
getModule _ _ _ = pure Nothing
getExtensions :: [String] -> (Maybe Language, [Extension])
getExtensions args = (lang, foldl f (if null langs then defaultExtensions else []) exts)
where
lang = if null langs then Nothing else Just $ fromJust $ lookup (last langs) ls
(langs, exts) = partition (isJust . flip lookup ls) args
ls = [(show x, x) | x <- [Haskell98, Haskell2010]]
f a "Haskell98" = []
f a ('N':'o':x) | Just x <- GhclibParserEx.readExtension x = delete x a
f a x | Just x <- GhclibParserEx.readExtension x = x : delete x a
f a x = a