{-# LANGUAGE ScopedTypeVariables #-}
module System.Git
( gitResetHard
, gitResetSubdir
, gitUnclean
, gitIsClean
, withCleanRepo
) where
import Control.Exception (catch, SomeException, throw)
import System.Directory (getCurrentDirectory)
import System.Exit (ExitCode(ExitSuccess, ExitFailure))
import System.IO (hPutStrLn, stderr)
import System.Process (readProcessWithExitCode, readProcess)
gitResetHard :: IO ()
gitResetHard :: IO ()
gitResetHard = do
(ExitCode
code, FilePath
_out, FilePath
_err) <- FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode FilePath
"git" [FilePath
"reset", FilePath
"--hard"] FilePath
""
case ExitCode
code of
ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ExitFailure Int
_n -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"gitResetHard"
gitResetSubdir :: FilePath -> IO ()
gitResetSubdir :: FilePath -> IO ()
gitResetSubdir FilePath
dir = do
(FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"git" [FilePath
"checkout", FilePath
"--", FilePath
dir] FilePath
"" IO FilePath -> IO FilePath -> IO FilePath
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"git" [FilePath
"clean", FilePath
"-f", FilePath
dir] FilePath
"" IO FilePath -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"gitResetSubdir " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" failed: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> IO ()
forall a e. Exception e => e -> a
throw SomeException
e
gitUnclean :: IO (Maybe String)
gitUnclean :: IO (Maybe FilePath)
gitUnclean = do
FilePath
here <- IO FilePath
getCurrentDirectory
Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"here: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
here)
(ExitCode
code, FilePath
out, FilePath
_err) <- FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode FilePath
"git" [FilePath
"status", FilePath
"--porcelain"] FilePath
""
case ExitCode
code of
ExitFailure Int
_ -> FilePath -> IO (Maybe FilePath)
forall a. HasCallStack => FilePath -> a
error FilePath
"gitCheckClean failure"
ExitCode
ExitSuccess | (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all FilePath -> Bool
unmodified (FilePath -> [FilePath]
lines FilePath
out) -> Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
ExitCode
ExitSuccess -> Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
out
where
unmodified :: FilePath -> Bool
unmodified (Char
a : Char
b : FilePath
_) = Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
a FilePath
"?! " Bool -> Bool -> Bool
&& Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
b FilePath
"?! "
unmodified FilePath
_ = Bool
False
gitIsClean :: IO Bool
gitIsClean :: IO Bool
gitIsClean = Bool -> (FilePath -> Bool) -> Maybe FilePath -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> FilePath -> Bool
forall a b. a -> b -> a
const Bool
False) (Maybe FilePath -> Bool) -> IO (Maybe FilePath) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe FilePath)
gitUnclean
withCleanRepo :: IO a -> IO a
withCleanRepo :: forall a. IO a -> IO a
withCleanRepo IO a
action = do
IO (Maybe FilePath)
gitUnclean IO (Maybe FilePath) -> (Maybe FilePath -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> (FilePath -> IO a) -> Maybe FilePath -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO a
action (\FilePath
s -> FilePath -> IO a
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath
"withCleanRepo: please commit or revert changes:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s)