module Git.Fmt (
Options(..), Chatty(..), Mode(..),
handle,
) where
import Control.Monad.Catch (MonadMask)
import Control.Monad.Extra
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Parallel (MonadParallel)
import qualified Control.Monad.Parallel as Parallel
import Control.Monad.Reader
import Data.List.Extra (chunksOf, linesBy, lower, nub, replace)
import qualified Data.Text as T
import Data.Yaml (prettyPrintParseException)
import Data.Yaml.Include (decodeFileEither)
import Git.Fmt.Config as Config
import Git.Fmt.Process
import Prelude hiding (read)
import System.Directory.Extra hiding (withCurrentDirectory)
import System.Directory.Extra'
import System.Exit
import System.FilePath
import System.IO.Temp
import System.IO.Extra'
data Options = Options {
optChatty :: Chatty,
optNull :: Bool,
optMode :: Mode,
argPaths :: [FilePath]
}
deriving (Eq, Show)
data Chatty = Default | Quiet | Verbose
deriving (Eq, Show)
data Mode = Normal | DryRun
deriving (Eq, Show)
handle :: (MonadIO m, MonadLogger m, MonadMask m, MonadParallel m) => Options -> m ()
handle options = findTopLevelGitDirectory >>= \dir -> withCurrentDirectory (init dir) $ do
filePaths <- fmap (nub . concat) $ paths >>= mapM
(\path -> ifM (liftIO $ doesDirectoryExist path)
(liftIO $ listFilesRecursive path)
(return [path])
)
unlessM (liftIO $ doesFileExist Config.fileName) $ panic (Config.fileName ++ ": not found")
config <- liftIO (decodeFileEither Config.fileName) >>= \ethr -> case ethr of
Left error -> panic $ Config.fileName ++ ": error\n" ++ prettyPrintParseException error
Right config -> return config
let supportedFilePaths = filter (supported config . T.pack . drop 1 . lower . takeExtension) filePaths
flip runReaderT config . withSystemTempDirectory "git-fmt" $ \tmpDir ->
Parallel.sequence_ . map sequence . nChunks 8 . flip map supportedFilePaths $ \filePath -> ifM (liftIO $ doesFileExist filePath)
(fmt options filePath (tmpDir </> filePath))
($(logWarn) $ T.pack (filePath ++ ": not found"))
where
paths
| null (argPaths options) = linesBy (== '\0') <$> runProcess_ "git" ["ls-files", "-z"]
| optNull options = return $ concatMap (linesBy (== '\0')) (argPaths options)
| otherwise = return $ argPaths options
nChunks n xs = chunksOf (maximum [1, length xs `div` n]) xs
fmt :: (MonadIO m, MonadLogger m, MonadReader Config m) => Options -> FilePath -> FilePath -> m ()
fmt options filePath tmpFilePath = do
config <- ask
let program = unsafeProgramFor config (T.pack . drop 1 $ takeExtension filePath)
(exitCode, _, stderr) <- runProgram program filePath tmpFilePath
if exitCode == ExitSuccess
then diff options filePath tmpFilePath
else $(logWarn) (T.pack $ filePath ++ ": error") >>
$(logDebug) (T.pack stderr)
diff :: (MonadIO m, MonadLogger m) => Options -> FilePath -> FilePath -> m ()
diff options filePath tmpFilePath = do
(exitCode, _, stderr) <- runProcess "diff" [filePath, tmpFilePath]
case exitCode of
ExitSuccess -> $(logDebug) $ T.pack (filePath ++ ": pretty")
ExitFailure 1 -> action filePath tmpFilePath
_ -> $(logWarn) $ T.pack stderr
where
action = case optMode options of
Normal -> normal
DryRun -> dryRun
normal :: (MonadIO m, MonadLogger m) => FilePath -> FilePath -> m ()
normal filePath tmpFilePath = do
$(logInfo) $ T.pack (filePath ++ ": prettified")
liftIO $ renameFile tmpFilePath filePath
dryRun :: (MonadIO m, MonadLogger m) => FilePath -> FilePath -> m ()
dryRun filePath _ = $(logInfo) $ T.pack (filePath ++ ": ugly")
findTopLevelGitDirectory :: (MonadIO m, MonadLogger m) => m String
findTopLevelGitDirectory = do
(exitCode, stdout, _) <- runProcess "git" ["rev-parse", "--show-toplevel"]
if exitCode == ExitSuccess
then return stdout
else panic ".git/: not found"
runProgram :: (MonadIO m, MonadLogger m) => Program -> FilePath -> FilePath -> m (ExitCode, String, String)
runProgram program inputFilePath tmpFilePath = do
liftIO $ createDirectoryIfMissing True (takeDirectory tmpFilePath)
runCommand $ foldr (uncurry replace) (T.unpack $ command program) [
("{{input}}", inputFilePath),
("{{output}}", tmpFilePath)
]