content: {-# LANGUAGE ImportQualifiedPost #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
  
  module HLint(hlint, readAllSettings) where
  
  import Control.Applicative
  import Control.Monad.Extra
  import Control.Exception.Extra
  import Control.Concurrent.Extra
  import System.Console.CmdArgs.Verbosity
  import GHC.Util.DynFlags
  import Data.List.Extra
  import GHC.Conc
  import System.Directory
  import System.Exit
  import System.IO.Extra
  import System.Time.Extra
  import Data.Tuple.Extra
  import Data.Bifunctor (bimap)
  import Prelude
  
  import CmdLine
  import Config.Read
  import Config.Type
  import Config.Compute
  import Report
  import Summary
  import Idea
  import Apply
  import Test.All
  import Hint.All
  import Refact
  import Timing
  import Parallel
  import GHC.All
  import CC
  import EmbedData
  
  import SARIF qualified
  
  -- | This function takes a list of command line arguments, and returns the given hints.
  --   To see a list of arguments type @hlint --help@ at the console.
  --   This function writes to the stdout/stderr streams, unless @--quiet@ is specified.
  --
  --   As an example:
  --
  -- > do hints <- hlint ["src", "--ignore=Use map","--quiet"]
  -- >    when (length hints > 3) $ error "Too many hints!"
  --
  --   /Warning:/ The flags provided by HLint are relatively stable, but do not have the same
  --   API stability guarantees as the rest of the strongly-typed API. Do not run this function
  --   on your server with untrusted input.
  hlint :: [String] -> IO [Idea]
  hlint args = do
      startTimings
      cmd <- getCmd args
      timedIO "Initialise" "global flags" initGlobalDynFlags
      if cmdTest cmd then
          hlintTest cmd >> pure []
       else do
          (time, xs) <- duration $ hlintMain args cmd
          when (cmdTiming cmd) $ do
              printTimings
              putStrLn $ "Took " ++ showDuration time
          pure $ if cmdNoExitCode cmd then [] else xs
  
  hlintTest :: Cmd -> IO ()
  hlintTest cmd@CmdMain{..} = do
      failed <- test cmd (\args -> do errs <- hlint args; unless (null errs) $ exitWith $ ExitFailure 1) cmdDataDir cmdGivenHints
      when (failed > 0) exitFailure
  
  cmdParseFlags :: Cmd -> ParseFlags
  cmdParseFlags cmd = parseFlagsSetLanguage (cmdExtensions cmd) $ defaultParseFlags{cppFlags=cmdCpp cmd}
  
  withVerbosity :: Verbosity -> IO a -> IO a
  withVerbosity new act = do
      old <- getVerbosity
      (setVerbosity new >> act) `finally` setVerbosity old
  
  hlintMain :: [String] -> Cmd -> IO [Idea]
  hlintMain args cmd@CmdMain{..}
      | cmdDefault = do
          ideas <- if null cmdFiles then pure [] else withVerbosity Quiet $
              runHlintMain args cmd{cmdJson=False,cmdSerialise=False,cmdRefactor=False} Nothing
          let bad = group $ sort $ map ideaHint ideas
          if null bad then putStr defaultYaml else do
              let group1:groups = splitOn ["",""] $ lines defaultYaml
              let group2 = "# Warnings currently triggered by your code" :
                           ["- ignore: {name: " ++ show x ++ "} # "
                           ++ if null tl then "1 hint" else show (length xs) ++ " hints"
                           | xs@(x : tl) <- bad
                           ]
  
              putStr $ unlines $ intercalate ["",""] $ group1:group2:groups
          pure []
      | cmdGenerateMdSummary /= [] = do
          forM_ cmdGenerateMdSummary $ \file -> timedIO "Summary" file $ do
              whenNormal $ putStrLn $ "Writing Markdown summary to " ++ file ++ " ..."
              summary <- generateMdSummary . snd =<< readAllSettings args cmd
              writeFileBinary file summary
          pure []
      | cmdGenerateJsonSummary /= [] = do
          forM_ cmdGenerateJsonSummary $ \file -> timedIO "Summary" file $ do
              whenNormal $ putStrLn $ "Writing JSON summary to " ++ file ++ " ..."
              summary <- generateJsonSummary . snd =<< readAllSettings args cmd
              writeFileBinary file summary
          pure []
      | cmdGenerateExhaustiveConf /= [] = do
          forM_ cmdGenerateExhaustiveConf $ \severity ->
              let file = show severity ++ "-all.yaml"
               in timedIO "Exhaustive config file" file $ do
                  whenNormal $ putStrLn $ "Writing " ++ show severity ++ "-all list to " ++ file ++ " ..."
                  exhaustiveConfig <- generateExhaustiveConfig severity . snd =<< readAllSettings args cmd
                  writeFileBinary file exhaustiveConfig
          pure []
      | null cmdFiles && not (null cmdFindHints) = do
          hints <- concatMapM (resolveFile cmd Nothing) cmdFindHints
          mapM_ (putStrLn . fst <=< computeSettings (cmdParseFlags cmd)) hints >> pure []
      | null cmdFiles =
          exitWithHelp
      | cmdRefactor =
          withTempFile $ runHlintMain args cmd . Just
      | otherwise =
          runHlintMain args cmd Nothing
  
  runHlintMain :: [String] -> Cmd -> Maybe FilePath -> IO [Idea]
  runHlintMain args cmd tmpFile = do
      (cmd, settings) <- readAllSettings args cmd
      runHints args settings =<< resolveFiles cmd tmpFile
  
  resolveFiles :: Cmd -> Maybe FilePath -> IO Cmd
  resolveFiles cmd@CmdMain{..} tmpFile = do
      -- if the first file is named 'lint' and there is no 'lint' file
      -- then someone is probably invoking the older hlint multi-mode command
      -- so skip it
      cmdFiles <- if not $ ["lint"] `isPrefixOf` cmdFiles then pure cmdFiles else do
          b <- doesDirectoryExist "lint"
          pure $ if b then cmdFiles else drop1 cmdFiles
  
      files <- concatMapM (resolveFile cmd tmpFile) cmdFiles
      if null files
          then error "No files found"
          else pure cmd { cmdFiles = files }
  
  readAllSettings :: [String] -> Cmd -> IO (Cmd, [Setting])
  readAllSettings args1 cmd@CmdMain{..} = do
      files <- cmdHintFiles cmd
      settings1 <-
          readFilesConfig $
          files
          ++ [("CommandLine.yaml",Just (enableGroup x)) | x <- cmdWithGroups]
      let args2 = [x | SettingArgument x <- settings1]
      cmd@CmdMain{..} <- if null args2 then pure cmd else getCmd $ args2 ++ args1 -- command line arguments are passed last
      settings2 <- concatMapM (fmap snd . computeSettings (cmdParseFlags cmd)) cmdFindHints
      let settings3 = [SettingClassify $ Classify Ignore x "" "" | x <- cmdIgnore]
      cmdThreads <- if cmdThreads == 0 then getNumProcessors else pure cmdThreads
      cmd <- pure CmdMain {..}
      pure (cmd, settings1 ++ settings2 ++ settings3)
      where
          enableGroup groupName =
              unlines
              ["- group:"
              ,"    name: " ++ groupName
              ,"    enabled: true"
              ]
  
  runHints :: [String] -> [Setting] -> Cmd -> IO [Idea]
  runHints args settings cmd@CmdMain{..} =
      withNumCapabilities cmdThreads $ do
          let outStrLn = whenNormal . putStrLn
          ideas <- filterIdeas <$> getIdeas cmd settings
          if cmdJson then
              putStrLn $ showIdeasJson ideas
           else if cmdCC then
              mapM_ (printIssue . fromIdea) ideas
           else if cmdSARIF then
              SARIF.printIdeas ideas
           else if cmdSerialise then do
              hSetBuffering stdout NoBuffering
              print $ map (show &&& ideaRefactoring) ideas
           else if cmdRefactor then
              handleRefactoring ideas cmdFiles cmd
           else do
              usecolour <- cmdUseColour cmd
              let showItem = if usecolour then showIdeaANSI else show
              mapM_ (outStrLn . showItem) ideas
              handleReporting ideas cmd
          pure ideas
    where
      filteredSeverities
          | cmdShowAll = []
          | cmdIgnoreSuggestions = [Ignore, Suggestion]
          | otherwise = [Ignore]
      filterIdeas = filter (\i -> ideaSeverity i `notElem` filteredSeverities)
  
  getIdeas :: Cmd -> [Setting] -> IO [Idea]
  getIdeas cmd@CmdMain{..} settings = do
      settings <- pure $ settings ++ map (Builtin . fst) builtinHints
      let flags = cmdParseFlags cmd
      ideas <- if cmdCross
          then applyHintFiles flags settings cmdFiles
          else concat <$> parallel cmdThreads [evaluateList =<< applyHintFile flags settings x Nothing | x <- cmdFiles]
      pure $ if not (null cmdOnly)
          then [i | i <- ideas, ideaHint i `elem` cmdOnly]
          else ideas
  
  -- #746: run refactor even if no hint, which ensures consistent output
  -- whether there are hints or not.
  handleRefactoring :: [Idea] -> [String] -> Cmd -> IO ()
  handleRefactoring ideas files cmd@CmdMain{..} = do
      -- Ensure that we can find the executable
      path <- checkRefactor (if cmdWithRefactor == "" then Nothing else Just cmdWithRefactor)
      forM_ cmdFiles $ \file -> do
          -- writeFile "hlint.refact"
          let fileIdeas = filter (\i -> file == ideaFile i) ideas
          let hints =  show $ map (show &&& ideaRefactoring) fileIdeas
          withTempFile $ \f -> do
              writeFile f hints
              let ParseFlags{enabledExtensions, disabledExtensions} = cmdParseFlags cmd
              exitCode <- runRefactoring path file f enabledExtensions disabledExtensions cmdRefactorOptions
  
              case exitCode of
                ExitSuccess   -> pure ()
                ExitFailure _ -> exitWith exitCode
  
  handleReporting :: [Idea] -> Cmd -> IO ()
  handleReporting showideas cmd@CmdMain{..} = do
      let outStrLn = whenNormal . putStrLn
      forM_ cmdReports $ \x -> do
          outStrLn $ "Writing report to " ++ x ++ " ..."
          writeReport cmdDataDir x showideas
      unless cmdNoSummary $ do
          let (nbErrors, nbHints) = bimap length length $ partition (\idea -> ideaSeverity idea == Error) showideas
          when (nbErrors > 0) (outStrLn $ formatOutput nbErrors "error")
          unless (nbErrors > 0 && nbHints == 0) (outStrLn $ formatOutput nbHints "hint")
  
      where
          formatOutput :: Int -> String -> String
          formatOutput number name =
              if number == 0 then "No " ++ name ++ "s" else show number ++ " " ++ name ++ ['s' | number/=1]
  
  evaluateList :: [a] -> IO [a]
  evaluateList xs = do
      evaluate $ length xs
      pure xs
  