module Darcs.Repository.Working
( applyToWorking
, setScriptsExecutable
, setScriptsExecutablePatches
) where
import Control.Monad ( when, unless, filterM )
import System.Directory ( doesFileExist )
import qualified Data.ByteString as B ( readFile
, isPrefixOf
)
import qualified Data.ByteString.Char8 as BC (pack)
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Workaround ( setExecutable )
import Darcs.Util.Tree ( Tree )
import Darcs.Util.Path ( anchorPath )
import qualified Darcs.Util.Tree as Tree
import Darcs.Patch ( RepoPatch, apply, listTouchedFiles )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Prim ( PrimOf )
import Darcs.Patch.Witnesses.Ordered
( FL(..) )
import Darcs.Patch.Dummy ( DummyPatch )
import Darcs.Patch.Inspect ( PatchInspect )
import Darcs.Repository.Format ( RepoProperty( NoWorkingDir ), formatHas )
import Darcs.Repository.Flags ( Verbosity(..) )
import Darcs.Repository.InternalTypes
( Repository
, repoFormat
, repoLocation
, coerceU )
import Darcs.Repository.ApplyPatches ( runTolerantly, runSilently )
import Darcs.Repository.State ( readWorking )
applyToWorking :: (ApplyState p ~ Tree, RepoPatch p)
=> Repository rt p wR wU wT -> Verbosity -> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wT)
applyToWorking :: Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wT)
applyToWorking repo :: Repository rt p wR wU wT
repo verb :: Verbosity
verb patch :: FL (PrimOf p) wU wY
patch =
do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
NoWorkingDir (Repository rt p wR wU wT -> RepoFormat
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository rt p wR wU wT
repo)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (Repository rt p wR wU wT -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p wR wU wT
repo) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
if Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Quiet
then TolerantWrapper SilentIO () -> IO ()
forall a. TolerantWrapper SilentIO a -> IO a
runSilently (TolerantWrapper SilentIO () -> IO ())
-> TolerantWrapper SilentIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wU wY -> TolerantWrapper SilentIO ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply FL (PrimOf p) wU wY
patch
else TolerantWrapper TolerantIO () -> IO ()
forall a. TolerantWrapper TolerantIO a -> IO a
runTolerantly (TolerantWrapper TolerantIO () -> IO ())
-> TolerantWrapper TolerantIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wU wY -> TolerantWrapper TolerantIO ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply FL (PrimOf p) wU wY
patch
Repository rt p wR wY wT -> IO (Repository rt p wR wY wT)
forall (m :: * -> *) a. Monad m => a -> m a
return (Repository rt p wR wY wT -> IO (Repository rt p wR wY wT))
-> Repository rt p wR wY wT -> IO (Repository rt p wR wY wT)
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wT -> Repository rt p wR wY wT
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wU'.
Repository rt p wR wU wT -> Repository rt p wR wU' wT
coerceU Repository rt p wR wU wT
repo
setScriptsExecutable_ :: PatchInspect p => Maybe (p wX wY) -> IO ()
setScriptsExecutable_ :: Maybe (p wX wY) -> IO ()
setScriptsExecutable_ pw :: Maybe (p wX wY)
pw = do
String -> IO ()
debugMessage "Making scripts executable"
Tree IO
tree <- IO (Tree IO)
readWorking
[String]
paths <- case Maybe (p wX wY)
pw of
Just ps :: p wX wY
ps -> (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ p wX wY -> [String]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [String]
listTouchedFiles p wX wY
ps
Nothing -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [ String -> AnchoredPath -> String
anchorPath "." AnchoredPath
p | (p :: AnchoredPath
p, Tree.File _) <- Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
Tree.list Tree IO
tree ]
let setExecutableIfScript :: String -> IO ()
setExecutableIfScript f :: String
f =
do ByteString
contents <- String -> IO ByteString
B.readFile String
f
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> ByteString
BC.pack "#!" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
contents) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
debugMessage ("Making executable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f)
String -> Bool -> IO ()
setExecutable String
f Bool
True
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
setExecutableIfScript [String]
paths
setScriptsExecutable :: IO ()
setScriptsExecutable :: IO ()
setScriptsExecutable = Maybe (FL DummyPatch Any Any) -> IO ()
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
Maybe (p wX wY) -> IO ()
setScriptsExecutable_ (forall a. Maybe a
forall wX wY. Maybe (FL DummyPatch wX wY)
Nothing :: Maybe (FL DummyPatch wX wY))
setScriptsExecutablePatches :: PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches :: p wX wY -> IO ()
setScriptsExecutablePatches = Maybe (p wX wY) -> IO ()
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
Maybe (p wX wY) -> IO ()
setScriptsExecutable_ (Maybe (p wX wY) -> IO ())
-> (p wX wY -> Maybe (p wX wY)) -> p wX wY -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p wX wY -> Maybe (p wX wY)
forall a. a -> Maybe a
Just