FixWhitespace.hs

-- | Program to enforce a whitespace policy.

{-# LANGUAGE OverloadedStrings #-}

module Main where

import           Control.Monad                ( unless, when )

import           Data.List.Extra              ( nubOrd )
import qualified Data.Text                    as Text
import qualified Data.Text.IO                 as Text {- Strict IO -}
import           Data.Version                 ( showVersion )

import           System.Console.GetOpt        ( OptDescr(Option), ArgDescr(NoArg, ReqArg), ArgOrder(Permute), getOpt, usageInfo )
import           System.Directory             ( getCurrentDirectory, doesFileExist )
import           System.Environment           ( getArgs, getProgName )
import           System.Exit                  ( die, exitFailure, exitSuccess )
import           System.FilePattern.Directory ( getDirectoryFiles, getDirectoryFilesIgnore )
import           System.IO                    ( IOMode(WriteMode), hPutStr, hPutStrLn, hSetEncoding, stderr, utf8, withFile )

import           Text.Read                    ( readMaybe )

import           Data.Text.FixWhitespace      ( CheckResult(CheckOK, CheckViolation, CheckIOError), checkFile, displayLineError
                                              , TabSize, Verbose, defaultTabSize )

import           ParseConfig                  ( Config(Config), parseConfig )
import qualified Paths_fix_whitespace         as PFW ( version )

-- | Default configuration file.

defaultConfigFile :: String
defaultConfigFile = "fix-whitespace.yaml"

-- Modes.
data Mode
  = Fix    -- ^ Fix whitespace issues.
  | Check  -- ^ Check if there are any whitespace issues.
    deriving (Show, Eq)

data Options = Options
  { optVerbose :: Verbose
  -- ^ Display the location of a file being checked or not.
  , optHelp    :: Bool
  -- ^ Display the help information.
  , optVersion :: Bool
  -- ^ Display the program's version.
  , optMode    :: Mode
  , optConfig  :: FilePath
  -- ^ The location to the configuration file.
  , optTabSize :: String
  -- ^ The number of spaces to expand a tab character to.  @"0"@ for keeping tabs.
  }

defaultOptions :: Options
defaultOptions = Options
  { optVerbose = False
  , optHelp    = False
  , optVersion = False
  , optMode    = Fix
  , optConfig  = defaultConfigFile
  , optTabSize = show defaultTabSize
  }

options :: [OptDescr (Options -> Options)]
options =
  [ Option ['h']     ["help"]
      (NoArg (\opts -> opts { optHelp = True }))
      "Show this help information."
  , Option ['V']     ["version"]
      (NoArg (\opts -> opts { optVersion = True }))
      "Show the program's version."
  , Option ['v']     ["verbose"]
      (NoArg (\opts -> opts { optVerbose = True }))
      (unlines
        [ "Show files as they are being checked."
        , "Display location of detected whitespace violations."
        ])
  , Option ['t']     ["tab"]
      (ReqArg (\ts opts -> opts { optTabSize = ts }) "TABSIZE")
      (unlines
        [ "Expand tab characters to TABSIZE (default: " ++ show defaultTabSize ++ ") many spaces."
        , "Keep tabs if 0 is given as TABSIZE."
        ])
  , Option []        ["config"]
      (ReqArg (\loc opts -> opts { optConfig = loc }) "CONFIG")
      (concat ["Override the project configuration ", defaultConfigFile, "."])
  , Option []        ["check"]
      (NoArg (\opts -> opts { optMode = Check }))
      (unlines
        [ "With --check the program does not change any files,"
        , "it just checks if any files would have been changed."
        , "In the latter case it returns with a non-zero exit code."
        ])
  ]

programOpts :: String -> IO (Options, [String])
programOpts progName = do
  argv <- getArgs
  case getOpt Permute options argv of
      (o, n, []  ) -> return (foldl (flip id) defaultOptions o, n)
      (_, _, errs) -> ioError $ userError $ concat errs ++ "\n" ++ shortUsageHeader progName


shortUsageHeader :: String -> String
shortUsageHeader progName = unwords
  [ "Usage:"
  , progName
  , "[-h|--help] [-v|--verbose] [--check] [--config CONFIG] [-t|--tab TABSIZE] [FILES]"
  ]

usageHeader :: String -> String
usageHeader progName = unlines
  [ shortUsageHeader progName
  , ""
  , "The program does the following"
  , ""
  , "  * Removes trailing whitespace."
  , "  * Removes trailing lines containing nothing but whitespace."
  , "  * Ensures that the file ends in a newline character."
  , "  * Convert tabs to TABSIZE (default: " ++ show defaultTabSize ++ ") spaces, unless TABSIZE is set to 0."
  , ""
  , "for files specified in [FILES] or"
  , ""
  , "\t" ++ defaultConfigFile
  , ""
  , "under the current directory."
  , ""
  , "Available options:"
  ]

usage :: String -> String
usage progName = usageInfo (usageHeader progName) options

main :: IO ()
main = do
  progName <- getProgName
  (opts, nonOpts) <- programOpts progName

  -- check if the user asks for help
  when (optHelp opts) $ putStr (usage progName) >> exitSuccess

  -- check if the user asks for the program's version
  when (optVersion opts) $ putStrLn (showVersion PFW.version) >> exitSuccess

  -- check if the configuration file exists
  configExist <- doesFileExist $ optConfig opts
  unless (configExist || not (null nonOpts)) $ do
    hPutStr stderr $ unlines
      [ unwords [defaultConfigFile, "is not found and there are no files specified as arguments."]
      , ""
      , shortUsageHeader progName
      ]
    exitFailure

  let mode    = optMode    opts
      verbose = optVerbose opts
      config  = optConfig  opts

  tabSize <- maybe (die "Error: Illegal TABSIZE, must be an integer.") return $
    readMaybe $ optTabSize opts

  base <- getCurrentDirectory

  files <- if not $ null nonOpts
    then getDirectoryFiles base nonOpts
    else do
      Config incDirs0 excDirs0 incFiles excFiles <- parseConfig config
      let incDirs = map (++ "/**/") incDirs0
      let excDirs = map (++ "/**/") excDirs0

      -- File patterns to always include
      -- when not matching an excluded file pattern
      let incWhitelistPatterns = concatMap (\d -> map (d ++) incFiles) incDirs
      -- File patterns to always exclude
      let excBlacklistPatterns = map ("**/" ++) excFiles

      -- Files to include when not in an excluded directory
      -- and when not matching an excluded file pattern
      let incPatterns = map ("**/" ++) incFiles
      -- Directory and file patterns to exclude
      let excPatterns = (map (++ "*") excDirs)
                     ++ (map ("**/" ++) excFiles)

      when verbose $ do
        putStrLn "Include whitelist:"
        putStrLn (unlines incWhitelistPatterns)

        putStrLn "Exclude blacklist:"
        putStrLn (unlines excBlacklistPatterns)

        putStrLn "Include:"
        putStrLn (unlines incPatterns)

        putStrLn "Exclude:"
        putStrLn (unlines excPatterns)

      files0 <- getDirectoryFilesIgnore base incWhitelistPatterns excBlacklistPatterns
      files1 <- getDirectoryFilesIgnore base incPatterns excPatterns
      return (nubOrd (files0 ++ files1))

  changes <- mapM (fix mode verbose tabSize) files

  when (or changes && mode == Check) exitFailure

fix :: Mode -> Verbose -> TabSize -> FilePath -> IO Bool
fix mode verbose tabSize f =
  checkFile tabSize verbose f >>= \case

    CheckOK -> do
      when verbose $
        putStrLn $ "[ Checked ] " ++ f
      return False

    CheckViolation s vs ->  do
      hPutStrLn stderr (msg vs)
      when (mode == Fix) $
        withFile f WriteMode $ \h -> do
          hSetEncoding h utf8
          Text.hPutStr h s
      return True

    CheckIOError _e -> do
      hPutStrLn stderr $
        "[ Read error ] " ++ f
      return False

  where
    msg vs
      | mode == Fix =
        "[ Violation fixed ] " ++ f

      | otherwise =
        "[ Violation detected ] " ++ f ++
        (if not verbose then "" else
           ":\n" ++ unlines (map (Text.unpack . displayLineError f) vs))