-- | 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, String
_out, String
_err) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"git" [String
"reset", String
"--hard"] String
""
  case ExitCode
code of
    ExitCode
ExitSuccess -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ExitFailure Int
_n -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"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 :: String -> IO ()
gitResetSubdir String
dir = do
  (String -> [String] -> String -> IO String
readProcess String
"git" [String
"checkout", String
"--", String
dir] String
"" IO String -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
   String -> [String] -> String -> IO String
readProcess String
"git" [String
"clean", String
"-f", String
dir] String
"" IO String -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
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 -> String -> IO ()
hPutStrLn Handle
stderr (String
"gitResetSubdir " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e) IO () -> IO () -> IO ()
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 String)
gitUnclean = do
  String
here <- IO String
getCurrentDirectory
  Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"here: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
here)
  (ExitCode
code, String
out, String
_err) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"git" [String
"status", String
"--porcelain"] String
""
  case ExitCode
code of
    ExitFailure Int
_ -> String -> IO (Maybe String)
forall a. HasCallStack => String -> a
error String
"gitCheckClean failure"
    ExitCode
ExitSuccess | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all String -> Bool
unmodified (String -> [String]
lines String
out) -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
    ExitCode
ExitSuccess -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
out
    where
      unmodified :: String -> Bool
unmodified (Char
a : Char
b : String
_) = Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
a String
"?! " Bool -> Bool -> Bool
&& Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
b String
"?! "
      unmodified String
_ = Bool
False

gitIsClean :: IO Bool
gitIsClean :: IO Bool
gitIsClean = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
False) (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe String)
gitUnclean

withCleanRepo :: IO a -> IO a
withCleanRepo :: IO a -> IO a
withCleanRepo IO a
action = do
  IO (Maybe String)
gitUnclean IO (Maybe String) -> (Maybe String -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> (String -> IO a) -> Maybe String -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO a
action (\String
s -> String -> IO a
forall a. HasCallStack => String -> a
error (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"withCleanRepo: please commit or revert changes:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)