fourmolu-0.20.0.0: app/Main.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Main (main) where

import Control.Concurrent (MVar, newMVar, withMVar)
import Control.Exception (throwIO)
import Control.Monad
import Data.Bool (bool)
import Data.List (intercalate, isSuffixOf, sort)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import Data.Set qualified as Set
import Data.Text.IO.Utf8 qualified as T.Utf8
import Data.Version (showVersion)
import Data.Yaml qualified as Yaml
import Distribution.ModuleName (ModuleName)
import Distribution.Types.PackageName (PackageName)
import Language.Haskell.TH.Env (envQ)
import Options.Applicative
import Ormolu
import Ormolu.Config
import Ormolu.Diff.Text (diffText, printTextDiff)
import Ormolu.Fixity
import Ormolu.Parser (manualExts)
import Ormolu.Terminal
import Ormolu.Utils (showOutputable)
import Ormolu.Utils.Fixity
import Paths_fourmolu (version)
import System.Console.Terminal.Size qualified as Terminal
import System.Directory
import System.Exit (ExitCode (..), exitWith)
import System.FilePath qualified as FP
import System.IO (hPutStrLn, stderr)
import UnliftIO.Async (pooledMapConcurrently)

-- | Entry point of the program.
main :: IO ()
main = do
  opts@Opts {..} <- runParser optsParserInfo
  -- We use this to guard writes to stdout in order to avoid
  -- garbled output from concurrent formatting processes.
  outputLock <- newMVar ()

  cfg <- resolveConfig opts

  let formatOne' =
        formatOne
          optConfigFileOpts
          optMode
          optSourceType
          cfg
          outputLock

  exitCode <- case optInputFiles of
    [] -> formatOne' Nothing
    ["-"] -> formatOne' Nothing
    inputs -> do
      let selectFailure = \case
            ExitSuccess -> Nothing
            ExitFailure n -> Just n
      files <- Set.toAscList . Set.fromList . concat <$> mapM getHaskellFiles inputs
      errorCodes <-
        mapMaybe selectFailure
          <$> pooledMapConcurrently (formatOne' . Just) files
      return $
        if null errorCodes
          then ExitSuccess
          else
            ExitFailure $
              if all (== 100) errorCodes
                then 100
                else 102

  exitWith exitCode
  where
    runParser p = do
      termWidth <- maybe 100 Terminal.width <$> Terminal.size
      customExecParser (prefs $ helpIndent 35 <> columns termWidth) p

-- | Build the full config, by adding 'PrinterOpts' from a file, if found.
resolveConfig :: Opts -> IO (Config RegionIndices)
resolveConfig opts@(Opts {optConfig = cliConfig, optPrinterOpts = cliPrinterOpts}) = do
  fourmoluConfig <-
    findConfigFile' >>= \case
      Left ConfigNotFound {searchDirs} -> do
        outputDebug . unlines $
          ("No " ++ show configFileName ++ " found in any of:")
            : map ("  " ++) searchDirs
        pure emptyConfig
      Right configPath ->
        Yaml.decodeFileEither configPath >>= \case
          Left e -> do
            outputError . unlines $
              [ "Failed to load " <> configPath <> ":",
                Yaml.prettyPrintParseException e
              ]
            exitWith $ ExitFailure 400
          Right cfg -> do
            outputInfo $ "Loaded config from: " <> configPath
            outputDebug $ unwords ["*** CONFIG FILE ***", show cfg]
            pure cfg

  return $
    cliConfig
      { cfgPrinterOpts =
          resolvePrinterOpts
            [ cfgFilePrinterOpts fourmoluConfig,
              cliPrinterOpts
            ],
        cfgFixityOverrides =
          FixityOverrides . mconcat . map unFixityOverrides $
            [ cfgFixityOverrides cliConfig,
              cfgFileFixities fourmoluConfig
            ],
        cfgModuleReexports =
          ModuleReexports . mconcat . map unModuleReexports $
            [ cfgModuleReexports cliConfig,
              cfgFileReexports fourmoluConfig
            ]
      }
  where
    findConfigFile' = do
      cwd <- getCurrentDirectory
      case optInputFiles opts of
        _ | Just configPath <- optConfigFilePath opts -> pure $ Right configPath
        [] -> findConfigFile cwd
        ["-"] -> findConfigFile cwd
        file : _ -> findConfigFile $ FP.takeDirectory file

    output = hPutStrLn stderr
    outputError = output
    outputInfo = unless (optQuiet opts) . output
    outputDebug = when (cfgDebug cliConfig) . output

getHaskellFiles :: FilePath -> IO [FilePath]
getHaskellFiles input = do
  isDir <- doesDirectoryExist input
  if isDir
    then filter (".hs" `isSuffixOf`) <$> listDirectoryRecursive input
    else return [input] -- plain file
  where
    listDirectoryRecursive fp
      -- automatically ignore files in certain hardcoded directories
      -- TODO: make configurable?
      | FP.takeFileName fp `elem` [".stack-work", "dist", "dist-newstyle"] = pure []
      | otherwise = fmap concat . mapM (go . (fp FP.</>)) =<< listDirectory fp
      where
        go child = do
          isDir <- doesDirectoryExist child
          if isDir
            then listDirectoryRecursive child
            else pure [child]

-- | Format a single input.
formatOne ::
  -- | How to use .cabal files
  ConfigFileOpts ->
  -- | Mode of operation
  Mode ->
  -- | The 'SourceType' requested by the user
  Maybe SourceType ->
  -- | Configuration
  Config RegionIndices ->
  -- | Lock for writing to output handles
  MVar () ->
  -- | File to format or stdin as 'Nothing'
  Maybe FilePath ->
  IO ExitCode
formatOne ConfigFileOpts {..} mode reqSourceType rawConfig outputLock mpath =
  withPrettyOrmoluExceptions (cfgColorMode rawConfig) $ do
    let getCabalInfoForSourceFile' sourceFile = do
          cabalSearchResult <- getCabalInfoForSourceFile sourceFile
          let debugEnabled = cfgDebug rawConfig
          case cabalSearchResult of
            CabalNotFound -> do
              when debugEnabled $
                withMVar outputLock $ \_ ->
                  hPutStrLn stderr $
                    "Could not find a .cabal file for " <> sourceFile
              return Nothing
            CabalDidNotMention cabalInfo -> do
              when debugEnabled $ do
                relativeCabalFile <-
                  makeRelativeToCurrentDirectory (ciCabalFilePath cabalInfo)
                withMVar outputLock $ \_ ->
                  hPutStrLn stderr $
                    "Found .cabal file "
                      <> relativeCabalFile
                      <> ", but it did not mention "
                      <> sourceFile
              return (Just cabalInfo)
            CabalFound cabalInfo -> return (Just cabalInfo)
        getDotOrmoluForSourceFile' sourceFile = do
          if optDoNotUseDotOrmolu
            then return Nothing
            else Just <$> getDotOrmoluForSourceFile sourceFile
    case FP.normalise <$> mpath of
      -- input source = STDIN
      Nothing -> do
        mcabalInfo <- case (optStdinInputFile, optDoNotUseCabal) of
          (_, True) -> return Nothing
          (Nothing, False) -> throwIO OrmoluMissingStdinInputFile
          (Just inputFile, False) -> getCabalInfoForSourceFile' inputFile
        mdotOrmolu <- case optStdinInputFile of
          Nothing -> return Nothing
          Just inputFile -> getDotOrmoluForSourceFile' inputFile
        config <- patchConfig Nothing mcabalInfo mdotOrmolu
        case mode of
          Stdout -> do
            output <- ormoluStdin config
            withMVar outputLock $ \_ ->
              T.Utf8.putStr output
            return ExitSuccess
          InPlace -> do
            hPutStrLn
              stderr
              "In place editing is not supported when input comes from stdin."
            -- 101 is different from all the other exit codes we already use.
            return (ExitFailure 101)
          Check -> do
            -- ormoluStdin is not used because we need the originalInput
            originalInput <- T.Utf8.getContents
            let stdinRepr = "<stdin>"
            formattedInput <-
              ormolu config stdinRepr originalInput
            handleDiff originalInput formattedInput stdinRepr
      -- input source = a file
      Just inputFile -> do
        mcabalInfo <-
          if optDoNotUseCabal
            then return Nothing
            else getCabalInfoForSourceFile' inputFile
        mdotOrmolu <- getDotOrmoluForSourceFile' inputFile
        config <-
          patchConfig
            (Just (detectSourceType inputFile))
            mcabalInfo
            mdotOrmolu
        case mode of
          Stdout -> do
            output <- ormoluFile config inputFile
            withMVar outputLock $ \_ ->
              T.Utf8.putStr output
            return ExitSuccess
          InPlace -> do
            -- ormoluFile is not used because we need originalInput
            originalInput <- T.Utf8.readFile inputFile
            formattedInput <-
              ormolu config inputFile originalInput
            when (formattedInput /= originalInput) $
              T.Utf8.writeFile inputFile formattedInput
            return ExitSuccess
          Check -> do
            -- ormoluFile is not used because we need originalInput
            originalInput <- T.Utf8.readFile inputFile
            formattedInput <-
              ormolu config inputFile originalInput
            handleDiff originalInput formattedInput inputFile
  where
    patchConfig mdetectedSourceType mcabalInfo mdotOrmolu = do
      let sourceType =
            fromMaybe
              ModuleSource
              (reqSourceType <|> mdetectedSourceType)
      return $
        refineConfig
          sourceType
          mcabalInfo
          (Just (cfgFixityOverrides rawConfig))
          (Just (cfgModuleReexports rawConfig))
          ( rawConfig
              { cfgFixityOverrides = maybe defaultFixityOverrides fst mdotOrmolu,
                cfgModuleReexports = maybe defaultModuleReexports snd mdotOrmolu
              }
          )
    handleDiff originalInput formattedInput fileRepr =
      case diffText originalInput formattedInput fileRepr of
        Nothing -> return ExitSuccess
        Just diff -> do
          runTerm (printTextDiff diff) (cfgColorMode rawConfig) stderr
          -- 100 is different to all the other exit code that are emitted
          -- either from an 'OrmoluException' or from 'error' and
          -- 'notImplemented'.
          return (ExitFailure 100)

----------------------------------------------------------------------------
-- Command line options parsing

-- | All command line options.
data Opts = Opts
  { -- | Mode of operation
    optMode :: !Mode,
    -- | Whether to make the output quieter
    optQuiet :: !Bool,
    -- | Ormolu 'Config'
    optConfig :: !(Config RegionIndices),
    -- | Ormolu 'Config'
    optConfigFilePath :: !(Maybe FilePath),
    -- | Fourmolu 'PrinterOpts',
    optPrinterOpts :: PrinterOptsPartial,
    -- | Options related to info extracted from files
    optConfigFileOpts :: ConfigFileOpts,
    -- | Source type option, where 'Nothing' means autodetection
    optSourceType :: !(Maybe SourceType),
    -- | Haskell source files to format or stdin (when the list is empty)
    optInputFiles :: ![FilePath]
  }

-- | Mode of operation.
data Mode
  = -- | Output formatted source code to stdout
    Stdout
  | -- | Overwrite original file
    InPlace
  | -- | Exit with non-zero status code if
    -- source is not already formatted
    Check
  deriving (Eq, Show, Bounded, Enum)

-- | Options related to configuration stored in the file system.
data ConfigFileOpts = ConfigFileOpts
  { -- | DO NOT extract default-extensions and dependencies from .cabal files
    optDoNotUseCabal :: Bool,
    -- | DO NOT look for @.ormolu@ files
    optDoNotUseDotOrmolu :: Bool,
    -- | Optional path to a file which will be used to find a .cabal file
    -- when using input from stdin
    optStdinInputFile :: Maybe FilePath
  }
  deriving (Show)

optsParserInfo :: ParserInfo Opts
optsParserInfo =
  info (helper <*> ver <*> exts <*> printDefaults <*> optsParser) . mconcat $
    [fullDesc]
  where
    ver :: Parser (a -> a)
    ver =
      infoOption verStr . mconcat $
        [ long "version",
          short 'v',
          help "Print version of the program"
        ]
    verStr =
      intercalate
        "\n"
        [ unwords $
            ["fourmolu", showVersion version]
              <> maybeToList $$(envQ @String "FOURMOLU_REV"),
          "using ghc-lib-parser " ++ VERSION_ghc_lib_parser
        ]
    exts :: Parser (a -> a)
    exts =
      infoOption displayExts . mconcat $
        [ long "manual-exts",
          help "Display extensions that need to be enabled manually"
        ]
    displayExts = unlines $ sort (showOutputable <$> manualExts)

    printDefaults :: Parser (a -> a)
    printDefaults =
      infoOption defaultPrinterOptsYaml . mconcat $
        [ long "print-defaults",
          help "Print default configuration options that can be used in fourmolu.yaml"
        ]

optsParser :: Parser Opts
optsParser =
  Opts
    <$> ( (fmap (bool Stdout InPlace) . switch . mconcat)
            [ short 'i',
              help "A shortcut for --mode inplace"
            ]
            <|> (option parseMode . mconcat)
              [ long "mode",
                short 'm',
                metavar "MODE",
                value Stdout,
                help "Mode of operation: 'stdout' (the default), 'inplace', or 'check'"
              ]
        )
    <*> (switch . mconcat)
      [ long "quiet",
        short 'q',
        help "Make output quieter"
      ]
    <*> configParser
    <*> (optional . strOption . mconcat)
      [ metavar "CONFIG_FILE",
        long "config",
        help "Path to the config file to use. If not specified, tries to discover one automatically."
      ]
    <*> printerOptsParser
    <*> configFileOptsParser
    <*> sourceTypeParser
    <*> (many . strArgument . mconcat)
      [ metavar "FILE",
        help "Haskell source files to format or stdin (the default)"
      ]

configFileOptsParser :: Parser ConfigFileOpts
configFileOptsParser =
  ConfigFileOpts
    <$> (switch . mconcat)
      [ long "no-cabal",
        help "Do not extract default-extensions and dependencies from .cabal files"
      ]
    <*> pure True -- Fourmolu: Don't add the '--no-dot-ormolu' flag, hardcode to never looking for .ormolu files
    <*> (optional . strOption . mconcat)
      [ long "stdin-input-file",
        help "Path which will be used to find the .cabal file when using input from stdin"
      ]

configParser :: Parser (Config RegionIndices)
configParser =
  Config
    <$> (fmap (fmap DynOption) . many . strOption . mconcat)
      [ long "ghc-opt",
        short 'o',
        metavar "OPT",
        help "GHC options to enable (e.g. language extensions)"
      ]
    <*> ( fmap (FixityOverrides . Map.fromList . mconcat)
            . many
            . option parseFixityDeclaration
            . mconcat
        )
      [ long "fixity",
        short 'f',
        metavar "FIXITY",
        help "Fixity declaration to use (an override)"
      ]
    <*> ( fmap (ModuleReexports . Map.fromListWith (<>) . mconcat . pure)
            . many
            . option parseModuleReexportDeclaration
            . mconcat
        )
      [ long "reexport",
        short 'r',
        metavar "REEXPORT",
        help "Module re-export that Fourmolu should know about"
      ]
    <*> (fmap Set.fromList . many . strOption . mconcat)
      [ long "package",
        short 'p',
        metavar "PACKAGE",
        help "Explicitly specified dependency (for operator fixity/precedence only)"
      ]
    <*> (switch . mconcat)
      [ long "unsafe",
        short 'u',
        help "Do formatting faster but without automatic detection of defects"
      ]
    <*> (switch . mconcat)
      [ long "debug",
        short 'd',
        help "Output information useful for debugging"
      ]
    <*> (switch . mconcat)
      [ long "check-idempotence",
        short 'c',
        help "Fail if formatting is not idempotent"
      ]
    -- We cannot parse the source type here, because we might need to do
    -- autodetection based on the input file extension (not available here)
    -- before storing the resolved value in the config struct.
    <*> pure ModuleSource
    <*> (option parseColorMode . mconcat)
      [ long "color",
        metavar "WHEN",
        value Auto,
        help "Colorize the output; WHEN can be 'never', 'always', or 'auto' (the default)"
      ]
    <*> ( RegionIndices
            <$> (optional . option auto . mconcat)
              [ long "start-line",
                metavar "START",
                help "Start line of the region to format (starts from 1)"
              ]
            <*> (optional . option auto . mconcat)
              [ long "end-line",
                metavar "END",
                help "End line of the region to format (inclusive)"
              ]
        )
    <*> pure defaultPrinterOpts -- unused; overwritten in resolveConfig
    <*> (fmap Set.fromList . many . strOption . mconcat)
      [ long "local-modules",
        metavar "LOCAL_MODULES",
        help "Modules Fourmolu should consider as local by the current Cabal package"
      ]

sourceTypeParser :: Parser (Maybe SourceType)
sourceTypeParser =
  (option parseSourceType . mconcat)
    [ long "source-type",
      short 't',
      metavar "TYPE",
      value Nothing,
      help "Set the type of source; TYPE can be 'module', 'sig', or 'auto' (the default)"
    ]

printerOptsParser :: Parser PrinterOptsPartial
printerOptsParser = parsePrinterOptsCLI mkOption
  where
    mkOption name helpText placeholder =
      option (Just <$> eitherReader parsePrinterOptType) . mconcat $
        [ long name,
          help helpText,
          metavar placeholder,
          value Nothing
        ]

----------------------------------------------------------------------------
-- Helpers

-- | Parse 'Mode'.
parseMode :: ReadM Mode
parseMode = eitherReader $ \case
  "stdout" -> Right Stdout
  "inplace" -> Right InPlace
  "check" -> Right Check
  s -> Left $ "unknown mode: " ++ s

-- | Parse a fixity declaration.
parseFixityDeclaration :: ReadM [(OpName, FixityInfo)]
parseFixityDeclaration = eitherReader parseFixityDeclarationStr

-- | Parse a module reexport declaration.
parseModuleReexportDeclaration ::
  ReadM (ModuleName, NonEmpty (Maybe PackageName, ModuleName))
parseModuleReexportDeclaration = eitherReader parseModuleReexportDeclarationStr

-- | Parse 'ColorMode'.
parseColorMode :: ReadM ColorMode
parseColorMode = eitherReader $ \case
  "never" -> Right Never
  "always" -> Right Always
  "auto" -> Right Auto
  s -> Left $ "unknown color mode: " ++ s

-- | Parse the 'SourceType'. 'Nothing' means that autodetection based on
-- file extension is requested.
parseSourceType :: ReadM (Maybe SourceType)
parseSourceType = eitherReader $ \case
  "module" -> Right (Just ModuleSource)
  "sig" -> Right (Just SignatureSource)
  "auto" -> Right Nothing
  s -> Left $ "unknown source type: " ++ s