-- | Git related functions that belong in some other package.

{-# 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)

-- | Do a hard reset of all the files of the repository containing the
-- working directory.
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"

-- | Do a hard reset of all the files of a subdirectory within a git
-- repository.  (Does this every throw an exception?)
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

-- | Determine whether the repository containing the working directory
-- is in a modified state, if so return the messages.
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)