File: CmdLine.hs

package info (click to toggle)
hlint 2.1.10-2
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 588 kB
  • sloc: haskell: 4,475; lisp: 86; makefile: 5
file content (324 lines) | stat: -rw-r--r-- 14,921 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
{-# LANGUAGE PatternGuards, DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-missing-fields -fno-cse -O0 #-}

module CmdLine(
    Cmd(..), getCmd,
    CppFlags(..), cmdCpp, cmdExtensions, cmdHintFiles, cmdUseColour,
    exitWithHelp, resolveFile
    ) where

import Control.Monad.Extra
import Data.Char
import Data.List
import Data.Maybe
import Data.Functor
import HSE.All(CppFlags(..))
import Language.Haskell.Exts(defaultParseMode, baseLanguage)
import Language.Haskell.Exts.Extension
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 Util
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
    _ -> return cmd
    where
        path cmd = return $ if null $ cmdPath cmd then cmd{cmdPath=["."]} else cmd
        extension cmd = return $ if null $ cmdExtension cmd then cmd{cmdExtension=["hs","lhs"]} else cmd
        dataDir cmd
            | cmdDataDir cmd  /= "" = return cmd
            | otherwise = do
                x <- getDataDir
                b <- doesDirectoryExist x
                if b then return cmd{cmdDataDir=x} else do
                    exe <- getExecutablePath
                    return cmd{cmdDataDir = takeDirectory exe </> "data"}
        git cmd
            | cmdGit cmd = do
                mgit <- findExecutable "git"
                case mgit of
                    Nothing -> error "Could not find git"
                    Just git -> do
                        let args = ["ls-files", "--cached", "--others", "--exclude-standard"] ++
                                   map ("*." ++) (cmdExtension cmd)
                        files <- readProcess git args ""
                        return cmd{cmdFiles = cmdFiles cmd ++ lines files}
            | otherwise = return cmd


exitWithHelp :: IO a
exitWithHelp = do
    putStr $ show $ helpText [] HelpFormatAll mode
    exitSuccess


-- | When to colour terminal output.
data ColorMode
    = Never  -- ^ Terminal output will never be coloured.
    | Always -- ^ Terminal output will always be coloured.
    | Auto   -- ^ Terminal output will be coloured if $TERM and stdout appear to support it.
      deriving (Show, Typeable, Data)


instance Default ColorMode where
  def = if isWindows then Never else Auto


data Cmd
    = CmdMain
        {cmdFiles :: [FilePath]    -- ^ which files to run it on, nothing = none given
        ,cmdReports :: [FilePath]        -- ^ where to generate reports
        ,cmdGivenHints :: [FilePath]     -- ^ which settignsfiles were explicitly given
        ,cmdWithHints :: [String]        -- ^ hints that are given on the command line
        ,cmdWithGroups :: [String]       -- ^ groups that are given on the command line
        ,cmdGit :: Bool                  -- ^ use git ls-files to find files
        ,cmdColor :: ColorMode           -- ^ color the result
        ,cmdThreads :: Int              -- ^ Numbmer of threads to use, 0 = whatever GHC has
        ,cmdIgnore :: [String]           -- ^ the hints to ignore
        ,cmdShowAll :: Bool              -- ^ display all skipped items
        ,cmdExtension :: [String]        -- ^ extensions
        ,cmdLanguage :: [String]      -- ^ the extensions (may be prefixed by "No")
        ,cmdCross :: Bool                -- ^ work between source files, applies to hints such as duplicate code between modules
        ,cmdFindHints :: [FilePath]      -- ^ source files to look for hints in
        ,cmdDataDir :: FilePath          -- ^ the data directory
        ,cmdDefault :: Bool              -- ^ Print a default file to stdout
        ,cmdPath :: [String]
        ,cmdCppDefine :: [String]
        ,cmdCppInclude :: [FilePath]
        ,cmdCppFile :: [FilePath]
        ,cmdCppSimple :: Bool
        ,cmdCppAnsi :: Bool
        ,cmdJson :: Bool                -- ^ display hint data as JSON
        ,cmdCC :: Bool                  -- ^ display hint data as Code Climate Issues
        ,cmdNoSummary :: Bool           -- ^ do not show the summary info
        ,cmdOnly :: [String]            -- ^ specify which hints explicitly
        ,cmdNoExitCode :: Bool
        ,cmdTiming :: Bool
        ,cmdSerialise :: Bool           -- ^ Display hints in serialisation format
        ,cmdRefactor :: Bool            -- ^ Run the `refactor` executable to automatically perform hints
        ,cmdRefactorOptions :: String   -- ^ Options to pass to the `refactor` executable.
        ,cmdWithRefactor :: FilePath    -- ^ Path to refactor tool
        }
    | CmdGrep
        {cmdFiles :: [FilePath]    -- ^ which files to run it on, nothing = none given
        ,cmdPattern :: String
        ,cmdExtension :: [String]        -- ^ extensions
        ,cmdLanguage :: [String]      -- ^ the extensions (may be prefixed by "No")
        ,cmdPath :: [String]
        ,cmdCppDefine :: [String]
        ,cmdCppInclude :: [FilePath]
        ,cmdCppFile :: [FilePath]
        ,cmdCppSimple :: Bool
        ,cmdCppAnsi :: Bool
        }
    | CmdTest
        {cmdProof :: [FilePath]          -- ^ a proof script to check against
        ,cmdGivenHints :: [FilePath]     -- ^ which settings files were explicitly given
        ,cmdDataDir :: FilePath          -- ^ the data directory
        ,cmdReports :: [FilePath]        -- ^ where to generate reports
        ,cmdWithHints :: [String]        -- ^ hints that are given on the command line
        ,cmdTempDir :: FilePath          -- ^ temporary directory to put the files in
        ,cmdQuickCheck :: Bool
        ,cmdTypeCheck :: Bool
        }
    | CmdHSE
        {cmdFiles :: [FilePath]
        ,cmdLanguage :: [String]      -- ^ the extensions (may be prefixed by "No")
        }
    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"
        ,cmdWithHints = nam "with" &= typ "HINT" &= help "Extra hints 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"
        } &= 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"]
    ,CmdHSE
        {} &= explicit &= name "hse"
    ] &= program "hlint" &= verbosity
    &=  summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2018")
    where
        nam xs = nam_ xs &= name [head xs]
        nam_ xs = def &= explicit &= name xs

-- | Where should we find the configuration files?
--   * If someone passes cmdWithHints, only look at files they explicitly request
--   * If someone passes an explicit hint name, automatically merge in data/hlint.yaml
--   We want more important hints to go last, since they override
cmdHintFiles :: Cmd -> IO [FilePath]
cmdHintFiles cmd = do
    let explicit1 = [cmdDataDir cmd </> "hlint.yaml" | null $ cmdWithHints cmd]
    let explicit2 = cmdGivenHints cmd
    bad <- filterM (notM . doesFileExist) $ explicit1 ++ explicit2
    when (bad /= []) $
        fail $ unlines $ "Failed to find requested hint files:" : map ("  "++) bad
    if cmdWithHints cmd /= [] then return $ explicit1 ++ explicit2 else do
        -- we follow the stylish-haskell config file search policy
        -- 1) current directory or its ancestors; 2) home directory
        curdir <- getCurrentDirectory
        -- Ignores home directory when it isn't present.
        home <- catchIOError ((:[]) <$> getHomeDirectory) (const $ return [])
        implicit <- findM doesFileExist $
            map (</> ".hlint.yaml") (ancestors curdir ++ home) -- to match Stylish Haskell
            ++ ["HLint.hs"] -- the default in HLint 1.*
        return $ explicit1 ++ maybeToList implicit ++ explicit2
    where
        ancestors = init . map joinPath . reverse . inits . splitPath

cmdExtensions :: Cmd -> (Language, [Extension])
cmdExtensions = getExtensions . cmdLanguage


cmdCpp :: Cmd -> CppFlags
cmdCpp cmd
    | cmdCppSimple cmd = CppSimple
    | EnableExtension CPP `elem` snd (cmdExtensions cmd) = Cpphs defaultCpphsOptions
        {boolopts=defaultBoolOptions{hashline=False, stripC89=True, ansi=cmdCppAnsi cmd}
        ,includes = cmdCppInclude cmd
        ,preInclude = cmdCppFile cmd
        ,defines = [(a,drop 1 b) | x <- cmdCppDefine cmd, let (a,b) = break (== '=') x]
        }
    | otherwise = NoCpp


-- | Determines whether to use colour or not.
cmdUseColour :: Cmd -> IO Bool
cmdUseColour cmd = case cmdColor cmd of
  Always -> return True
  Never  -> return False
  Auto   -> hSupportsANSI stdout


"." <\> x = x
x <\> y = x </> y


resolveFile
    :: Cmd
    -> Maybe FilePath -- ^ Temporary file
    -> FilePath       -- ^ File to resolve, may be "-" for stdin
    -> IO [FilePath]
resolveFile cmd = getFile (cmdPath cmd) (cmdExtension cmd)


getFile :: [FilePath] -> [String] -> Maybe FilePath -> FilePath -> IO [FilePath]
getFile path _ (Just tmpfile) "-" =
  getContents >>= writeFile tmpfile >> return [tmpfile]
getFile path _ Nothing "-" = return ["-"]
getFile [] exts _ file = exitMessage $ "Couldn't find file: " ++ file
getFile (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
        xs <- listFilesInside (return . not . avoidDir) $ p <\> file
        return [x | x <- xs, drop 1 (takeExtension x) `elem` exts, not $ avoidFile x]
     else do
        isFil <- doesFileExist $ p <\> file
        if isFil then return [p <\> file]
         else do
            res <- getModule p exts file
            case res of
                Just x -> return [x]
                Nothing -> getFile 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 [] = return Nothing
        f (x:xs) = do
            let s = pre <.> x
            b <- doesFileExist s
            if b then return $ Just s else f xs
getModule _ _ _ = return Nothing


getExtensions :: [String] -> (Language, [Extension])
getExtensions args = (lang, foldl f (if null langs then defaultExtensions else []) exts)
    where
        lang = if null langs then baseLanguage defaultParseMode else fromJust $ lookup (last langs) ls
        (langs, exts) = partition (isJust . flip lookup ls) args
        ls = [(show x, x) | x <- knownLanguages]

        f a "Haskell98" = []
        f a ('N':'o':x) | Just x <- readExtension x = delete x a
        f a x | Just x <- readExtension x = x : delete x a
        f a x = UnknownExtension x : delete (UnknownExtension x) a


readExtension :: String -> Maybe Extension
readExtension x = case classifyExtension x of
    UnknownExtension _ -> Nothing
    x -> Just x