{-# LANGUAGE ForeignFunctionInterface #-}
module Darcs.Repository.Job
( RepoJob(..)
, IsPrimV1(..)
, withRepoLock
, withOldRepoLock
, withRepoLockCanFail
, withRepository
, withRepositoryLocation
, checkRepoIsNoRebase
, withUMaskFlag
) where
import Prelude ()
import Darcs.Prelude
import Darcs.Util.Global ( darcsdir )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.V1 ( RepoPatchV1 )
import Darcs.Patch.V2 ( RepoPatchV2 )
import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )
import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )
import Darcs.Patch.Prim ( PrimOf )
import Darcs.Patch.Prim.V1 ( Prim )
import Darcs.Patch.RepoPatch ( RepoPatch )
import Darcs.Patch.RepoType
( RepoType(..), SRepoType(..), IsRepoType
, RebaseType(..), SRebaseType(..), IsRebaseType
, singletonRepoType
)
import Darcs.Repository.Flags
( UseCache(..), UpdateWorking(..), DryRun(..), UMask (..)
)
import Darcs.Repository.Format
( RepoProperty( Darcs2
, RebaseInProgress
, HashedInventory
)
, formatHas
, writeProblem
)
import Darcs.Repository.Identify ( identifyRepository )
import Darcs.Repository.Hashed( revertRepositoryChanges )
import Darcs.Repository.InternalTypes
( Repository
, repoFormat
, repoLocation
)
import Darcs.Repository.Rebase
( RebaseJobFlags
, startRebaseJob
, rebaseJob
)
import qualified Darcs.Repository.Rebase as Rebase ( maybeDisplaySuspendedStatus )
import Darcs.Util.Lock ( withLock, withLockCanFail )
import Darcs.Util.Progress ( debugMessage )
import Control.Monad ( when )
import Control.Exception ( bracket_, finally )
import Data.Coerce ( coerce )
import Data.List ( intercalate )
import Foreign.C.String ( CString, withCString )
import Foreign.C.Error ( throwErrno )
import Foreign.C.Types ( CInt(..) )
import Darcs.Util.Tree ( Tree )
getUMask :: UMask -> Maybe String
getUMask :: UMask -> Maybe String
getUMask (YesUMask s :: String
s) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
getUMask NoUMask = Maybe String
forall a. Maybe a
Nothing
withUMaskFlag :: UMask -> IO a -> IO a
withUMaskFlag :: UMask -> IO a -> IO a
withUMaskFlag = (IO a -> IO a)
-> (String -> IO a -> IO a) -> Maybe String -> IO a -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO a -> IO a
forall a. a -> a
id String -> IO a -> IO a
forall a. String -> IO a -> IO a
withUMask (Maybe String -> IO a -> IO a)
-> (UMask -> Maybe String) -> UMask -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UMask -> Maybe String
getUMask
foreign import ccall unsafe "umask.h set_umask" set_umask
:: CString -> IO CInt
foreign import ccall unsafe "umask.h reset_umask" reset_umask
:: CInt -> IO CInt
withUMask :: String
-> IO a
-> IO a
withUMask :: String -> IO a -> IO a
withUMask umask :: String
umask job :: IO a
job =
do CInt
rc <- String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString String
umask CString -> IO CInt
set_umask
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (String -> IO ()
forall a. String -> IO a
throwErrno "Couldn't set umask")
IO () -> IO CInt -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
(() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
(CInt -> IO CInt
reset_umask CInt
rc)
IO a
job
data RepoJob a
=
RepoJob (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR -> IO a)
| V1Job (forall wR wU . Repository ('RepoType 'NoRebase) (RepoPatchV1 V1.Prim) wR wU wR -> IO a)
| V2Job (forall rt wR wU . IsRepoType rt => Repository rt (RepoPatchV2 V2.Prim) wR wU wR -> IO a)
| PrimV1Job (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, IsPrimV1 (PrimOf p))
=> Repository rt p wR wU wR -> IO a)
| RebaseAwareJob RebaseJobFlags (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wR -> IO a)
| RebaseJob RebaseJobFlags (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
| StartRebaseJob RebaseJobFlags (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
onRepoJob :: RepoJob a
-> (forall rt p wR wU . (RepoPatch p, ApplyState p ~ Tree) => (Repository rt p wR wU wR -> IO a) -> Repository rt p wR wU wR -> IO a)
-> RepoJob a
onRepoJob :: RepoJob a
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a)
-> RepoJob a
onRepoJob (RepoJob job :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a
job) f :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f = (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f Repository rt p wR wU wR -> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a
job)
onRepoJob (V1Job job :: forall wR wU.
Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
-> IO a
job) f :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f = (forall wR wU.
Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
-> IO a)
-> RepoJob a
forall a.
(forall wR wU.
Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
-> IO a)
-> RepoJob a
V1Job ((Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
-> IO a)
-> Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
-> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
-> IO a
forall wR wU.
Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
-> IO a
job)
onRepoJob (V2Job job :: forall (rt :: RepoType) wR wU.
IsRepoType rt =>
Repository rt (RepoPatchV2 Prim) wR wU wR -> IO a
job) f :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f = (forall (rt :: RepoType) wR wU.
IsRepoType rt =>
Repository rt (RepoPatchV2 Prim) wR wU wR -> IO a)
-> RepoJob a
forall a.
(forall (rt :: RepoType) wR wU.
IsRepoType rt =>
Repository rt (RepoPatchV2 Prim) wR wU wR -> IO a)
-> RepoJob a
V2Job ((Repository rt (RepoPatchV2 Prim) wR wU wR -> IO a)
-> Repository rt (RepoPatchV2 Prim) wR wU wR -> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f Repository rt (RepoPatchV2 Prim) wR wU wR -> IO a
forall (rt :: RepoType) wR wU.
IsRepoType rt =>
Repository rt (RepoPatchV2 Prim) wR wU wR -> IO a
job)
onRepoJob (PrimV1Job job :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree,
IsPrimV1 (PrimOf p)) =>
Repository rt p wR wU wR -> IO a
job) f :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f = (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree,
IsPrimV1 (PrimOf p)) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree,
IsPrimV1 (PrimOf p)) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
PrimV1Job ((Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f Repository rt p wR wU wR -> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree,
IsPrimV1 (PrimOf p)) =>
Repository rt p wR wU wR -> IO a
job)
onRepoJob (RebaseAwareJob flags :: RebaseJobFlags
flags job :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a
job) f :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f = RebaseJobFlags
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
forall a.
RebaseJobFlags
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RebaseAwareJob RebaseJobFlags
flags ((Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f Repository rt p wR wU wR -> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a
job)
onRepoJob (RebaseJob flags :: RebaseJobFlags
flags job :: forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job) f :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f = RebaseJobFlags
-> (forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> RepoJob a
forall a.
RebaseJobFlags
-> (forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> RepoJob a
RebaseJob RebaseJobFlags
flags ((Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job)
onRepoJob (StartRebaseJob flags :: RebaseJobFlags
flags job :: forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job) f :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f = RebaseJobFlags
-> (forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> RepoJob a
forall a.
RebaseJobFlags
-> (forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> RepoJob a
StartRebaseJob RebaseJobFlags
flags ((Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a
f Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job)
withRepository :: UseCache -> RepoJob a -> IO a
withRepository :: UseCache -> RepoJob a -> IO a
withRepository useCache :: UseCache
useCache = UseCache -> String -> RepoJob a -> IO a
forall a. UseCache -> String -> RepoJob a -> IO a
withRepositoryLocation UseCache
useCache "."
data RepoPatchType p where
RepoV1 :: RepoPatchType (RepoPatchV1 V1.Prim)
RepoV2 :: RepoPatchType (RepoPatchV2 V2.Prim)
data IsTree p where
IsTree :: (ApplyState p ~ Tree) => IsTree p
checkTree :: RepoPatchType p -> IsTree p
checkTree :: RepoPatchType p -> IsTree p
checkTree RepoV1 = IsTree p
forall (p :: * -> * -> *). (ApplyState p ~ Tree) => IsTree p
IsTree
checkTree RepoV2 = IsTree p
forall (p :: * -> * -> *). (ApplyState p ~ Tree) => IsTree p
IsTree
class ApplyState p ~ Tree => IsPrimV1 p where
toPrimV1 :: p wX wY -> Prim wX wY
instance IsPrimV1 V1.Prim where
toPrimV1 :: Prim wX wY -> Prim wX wY
toPrimV1 = Prim wX wY -> Prim wX wY
forall wX wY. Prim wX wY -> Prim wX wY
V1.unPrim
instance IsPrimV1 V2.Prim where
toPrimV1 :: Prim wX wY -> Prim wX wY
toPrimV1 = Prim wX wY -> Prim wX wY
forall wX wY. Prim wX wY -> Prim wX wY
V2.unPrim
data UsesPrimV1 p where
UsesPrimV1 :: (ApplyState p ~ Tree, IsPrimV1 (PrimOf p)) => UsesPrimV1 p
checkPrimV1 :: RepoPatchType p -> UsesPrimV1 p
checkPrimV1 :: RepoPatchType p -> UsesPrimV1 p
checkPrimV1 RepoV1 = UsesPrimV1 p
forall (p :: * -> * -> *).
(ApplyState p ~ Tree, IsPrimV1 (PrimOf p)) =>
UsesPrimV1 p
UsesPrimV1
checkPrimV1 RepoV2 = UsesPrimV1 p
forall (p :: * -> * -> *).
(ApplyState p ~ Tree, IsPrimV1 (PrimOf p)) =>
UsesPrimV1 p
UsesPrimV1
withRepositoryLocation :: UseCache -> String -> RepoJob a -> IO a
withRepositoryLocation :: UseCache -> String -> RepoJob a -> IO a
withRepositoryLocation useCache :: UseCache
useCache url :: String
url repojob :: RepoJob a
repojob = do
Repository Any Any Any Any Any
repo <- UseCache -> String -> IO (Repository Any Any Any Any Any)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
UseCache -> String -> IO (Repository rt p wR wU wT)
identifyRepository UseCache
useCache String
url
let
rf :: RepoFormat
rf = Repository Any Any Any Any Any -> RepoFormat
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository Any Any Any Any Any
repo
startRebase :: Bool
startRebase =
case RepoJob a
repojob of
StartRebaseJob {} -> Bool
True
_ -> Bool
False
runJob1
:: IsRebaseType rebaseType
=> SRebaseType rebaseType -> Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a
runJob1 :: SRebaseType rebaseType
-> Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a
runJob1 isRebase :: SRebaseType rebaseType
isRebase =
if RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs2 RepoFormat
rf
then RepoPatchType (RepoPatchV2 Prim)
-> SRepoType ('RepoType rebaseType)
-> Repository rtDummy pDummy wR wU wR
-> RepoJob a
-> IO a
forall (rt :: RepoType) (p :: * -> * -> *) (rtDummy :: RepoType)
(pDummy :: * -> * -> *) wR wU a.
(IsRepoType rt, RepoPatch p) =>
RepoPatchType p
-> SRepoType rt
-> Repository rtDummy pDummy wR wU wR
-> RepoJob a
-> IO a
runJob RepoPatchType (RepoPatchV2 Prim)
RepoV2 (SRebaseType rebaseType -> SRepoType ('RepoType rebaseType)
forall (rebaseType :: RebaseType).
SRebaseType rebaseType -> SRepoType ('RepoType rebaseType)
SRepoType SRebaseType rebaseType
isRebase)
else RepoPatchType (RepoPatchV1 Prim)
-> SRepoType ('RepoType rebaseType)
-> Repository rtDummy pDummy wR wU wR
-> RepoJob a
-> IO a
forall (rt :: RepoType) (p :: * -> * -> *) (rtDummy :: RepoType)
(pDummy :: * -> * -> *) wR wU a.
(IsRepoType rt, RepoPatch p) =>
RepoPatchType p
-> SRepoType rt
-> Repository rtDummy pDummy wR wU wR
-> RepoJob a
-> IO a
runJob RepoPatchType (RepoPatchV1 Prim)
RepoV1 (SRebaseType rebaseType -> SRepoType ('RepoType rebaseType)
forall (rebaseType :: RebaseType).
SRebaseType rebaseType -> SRepoType ('RepoType rebaseType)
SRepoType SRebaseType rebaseType
isRebase)
runJob2 :: Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a
runJob2 :: Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a
runJob2 =
if Bool
startRebase Bool -> Bool -> Bool
|| RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
RebaseInProgress RepoFormat
rf
then SRebaseType 'IsRebase
-> Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a
forall (rebaseType :: RebaseType) (rtDummy :: RepoType)
(pDummy :: * -> * -> *) wR wU a.
IsRebaseType rebaseType =>
SRebaseType rebaseType
-> Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a
runJob1 SRebaseType 'IsRebase
SIsRebase
else SRebaseType 'NoRebase
-> Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a
forall (rebaseType :: RebaseType) (rtDummy :: RepoType)
(pDummy :: * -> * -> *) wR wU a.
IsRebaseType rebaseType =>
SRebaseType rebaseType
-> Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a
runJob1 SRebaseType 'NoRebase
SNoRebase
Repository Any Any Any Any Any -> RepoJob a -> IO a
forall (rtDummy :: RepoType) (pDummy :: * -> * -> *) wR wU a.
Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a
runJob2 Repository Any Any Any Any Any
repo RepoJob a
repojob
runJob
:: forall rt p rtDummy pDummy wR wU a
. (IsRepoType rt, RepoPatch p)
=> RepoPatchType p
-> SRepoType rt
-> Repository rtDummy pDummy wR wU wR
-> RepoJob a
-> IO a
runJob :: RepoPatchType p
-> SRepoType rt
-> Repository rtDummy pDummy wR wU wR
-> RepoJob a
-> IO a
runJob patchType :: RepoPatchType p
patchType (SRepoType isRebase :: SRebaseType rebaseType
isRebase) repo :: Repository rtDummy pDummy wR wU wR
repo repojob :: RepoJob a
repojob = do
let
therepo :: Repository rt p wR wU wR
therepo = Repository rtDummy pDummy wR wU wR -> Repository rt p wR wU wR
forall a b. Coercible a b => a -> b
coerce Repository rtDummy pDummy wR wU wR
repo :: Repository rt p wR wU wR
patchTypeString :: String
patchTypeString :: String
patchTypeString =
case RepoPatchType p
patchType of
RepoV2 -> "darcs-2"
RepoV1 -> "darcs-1"
repoAttributes :: [String]
repoAttributes :: [String]
repoAttributes =
case SRebaseType rebaseType
isRebase of
SIsRebase -> ["rebase"]
SNoRebase -> []
repoAttributesString :: String
repoAttributesString :: String
repoAttributesString =
case [String]
repoAttributes of
[] -> ""
_ -> " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "+" [String]
repoAttributes
String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Identified " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
patchTypeString String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
repoAttributesString String -> String -> String
forall a. [a] -> [a] -> [a]
++
" repo: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Repository rtDummy pDummy wR wU wR -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rtDummy pDummy wR wU wR
repo
case RepoJob a
repojob of
RepoJob job :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a
job ->
case RepoPatchType p -> IsTree p
forall (p :: * -> * -> *). RepoPatchType p -> IsTree p
checkTree RepoPatchType p
patchType of
IsTree ->
Repository rt p wR wU wR -> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a
job Repository rt p wR wU wR
therepo
IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally`
SRebaseType rebaseType
-> Repository ('RepoType rebaseType) p wR wU wR -> IO ()
forall (p :: * -> * -> *) (rebaseType :: RebaseType) wR wU.
RepoPatch p =>
SRebaseType rebaseType
-> Repository ('RepoType rebaseType) p wR wU wR -> IO ()
Rebase.maybeDisplaySuspendedStatus SRebaseType rebaseType
isRebase Repository rt p wR wU wR
Repository ('RepoType rebaseType) p wR wU wR
therepo
PrimV1Job job :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree,
IsPrimV1 (PrimOf p)) =>
Repository rt p wR wU wR -> IO a
job ->
case RepoPatchType p -> UsesPrimV1 p
forall (p :: * -> * -> *). RepoPatchType p -> UsesPrimV1 p
checkPrimV1 RepoPatchType p
patchType of
UsesPrimV1 -> do
Repository rt p wR wU wR -> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree,
IsPrimV1 (PrimOf p)) =>
Repository rt p wR wU wR -> IO a
job Repository rt p wR wU wR
therepo
IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally`
SRebaseType rebaseType
-> Repository ('RepoType rebaseType) p wR wU wR -> IO ()
forall (p :: * -> * -> *) (rebaseType :: RebaseType) wR wU.
RepoPatch p =>
SRebaseType rebaseType
-> Repository ('RepoType rebaseType) p wR wU wR -> IO ()
Rebase.maybeDisplaySuspendedStatus SRebaseType rebaseType
isRebase Repository rt p wR wU wR
Repository ('RepoType rebaseType) p wR wU wR
therepo
V2Job job :: forall (rt :: RepoType) wR wU.
IsRepoType rt =>
Repository rt (RepoPatchV2 Prim) wR wU wR -> IO a
job ->
case (RepoPatchType p
patchType, SRebaseType rebaseType
isRebase) of
(RepoV2, SNoRebase) -> Repository rt (RepoPatchV2 Prim) wR wU wR -> IO a
forall (rt :: RepoType) wR wU.
IsRepoType rt =>
Repository rt (RepoPatchV2 Prim) wR wU wR -> IO a
job Repository rt p wR wU wR
Repository rt (RepoPatchV2 Prim) wR wU wR
therepo
(RepoV1, _ ) ->
String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ "This repository contains darcs v1 patches,"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " but the command requires darcs v2 patches."
(RepoV2, SIsRebase) ->
String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "This command is not supported while a rebase is in progress."
V1Job job :: forall wR wU.
Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
-> IO a
job ->
case (RepoPatchType p
patchType, SRebaseType rebaseType
isRebase) of
(RepoV1, SNoRebase) -> Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
-> IO a
forall wR wU.
Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
-> IO a
job Repository rt p wR wU wR
Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
therepo
(RepoV2, _ ) ->
String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ "This repository contains darcs v2 patches,"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " but the command requires darcs v1 patches."
(RepoV1, SIsRebase) ->
String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "This command is not supported while a rebase is in progress."
RebaseAwareJob flags :: RebaseJobFlags
flags job :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a
job ->
case (RepoPatchType p -> IsTree p
forall (p :: * -> * -> *). RepoPatchType p -> IsTree p
checkTree RepoPatchType p
patchType, SRebaseType rebaseType
isRebase) of
(IsTree, SNoRebase) -> Repository rt p wR wU wR -> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a
job Repository rt p wR wU wR
therepo
(IsTree, SIsRebase) -> (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO a
forall (p :: * -> * -> *) wR wU a.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO a
rebaseJob Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a
job Repository rt p wR wU wR
Repository ('RepoType 'IsRebase) p wR wU wR
therepo RebaseJobFlags
flags
RebaseJob flags :: RebaseJobFlags
flags job :: forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job ->
case (RepoPatchType p -> IsTree p
forall (p :: * -> * -> *). RepoPatchType p -> IsTree p
checkTree RepoPatchType p
patchType, SRebaseType rebaseType
isRebase) of
(_ , SNoRebase) -> String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "No rebase in progress. Try 'darcs rebase suspend' first."
(IsTree, SIsRebase) -> (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO a
forall (p :: * -> * -> *) wR wU a.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO a
rebaseJob Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job Repository rt p wR wU wR
Repository ('RepoType 'IsRebase) p wR wU wR
therepo RebaseJobFlags
flags
StartRebaseJob flags :: RebaseJobFlags
flags job :: forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job ->
case (RepoPatchType p -> IsTree p
forall (p :: * -> * -> *). RepoPatchType p -> IsTree p
checkTree RepoPatchType p
patchType, SRebaseType rebaseType
isRebase) of
(_ , SNoRebase) -> IO a
forall a. a
impossible
(IsTree, SIsRebase) -> (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO a
forall (p :: * -> * -> *) wR wU a.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR
-> RebaseJobFlags
-> IO a
startRebaseJob Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job Repository rt p wR wU wR
Repository ('RepoType 'IsRebase) p wR wU wR
therepo RebaseJobFlags
flags
withRepoLock :: DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock :: DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock dry :: DryRun
dry useCache :: UseCache
useCache uw :: UpdateWorking
uw um :: UMask
um repojob :: RepoJob a
repojob =
UseCache -> RepoJob a -> IO a
forall a. UseCache -> RepoJob a -> IO a
withRepository UseCache
useCache (RepoJob a -> IO a) -> RepoJob a -> IO a
forall a b. (a -> b) -> a -> b
$ RepoJob a
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a)
-> RepoJob a
forall a.
RepoJob a
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a)
-> RepoJob a
onRepoJob RepoJob a
repojob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a)
-> RepoJob a)
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a)
-> RepoJob a
forall a b. (a -> b) -> a -> b
$ \job :: Repository rt p wR wU wR -> IO a
job repository :: Repository rt p wR wU wR
repository ->
do IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Maybe String -> IO ()) -> Maybe String -> IO ()
forall a b. (a -> b) -> a -> b
$ RepoFormat -> Maybe String
writeProblem (Repository rt p wR wU wR -> RepoFormat
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository rt p wR wU wR
repository)
let name :: String
name = "./"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
darcsdirString -> String -> String
forall a. [a] -> [a] -> [a]
++"/lock"
UMask -> IO a -> IO a
forall a. UMask -> IO a -> IO a
withUMaskFlag UMask
um (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
if DryRun
dry DryRun -> DryRun -> Bool
forall a. Eq a => a -> a -> Bool
== DryRun
YesDryRun
then Repository rt p wR wU wR -> IO a
job Repository rt p wR wU wR
repository
else String -> IO a -> IO a
forall a. String -> IO a -> IO a
withLock String
name (Repository rt p wR wU wR -> UpdateWorking -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> UpdateWorking -> IO ()
revertRepositoryChanges Repository rt p wR wU wR
repository UpdateWorking
uw IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Repository rt p wR wU wR -> IO a
job Repository rt p wR wU wR
repository)
withOldRepoLock :: RepoJob a -> IO a
withOldRepoLock :: RepoJob a -> IO a
withOldRepoLock repojob :: RepoJob a
repojob =
UseCache -> RepoJob a -> IO a
forall a. UseCache -> RepoJob a -> IO a
withRepository UseCache
NoUseCache (RepoJob a -> IO a) -> RepoJob a -> IO a
forall a b. (a -> b) -> a -> b
$ RepoJob a
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a)
-> RepoJob a
forall a.
RepoJob a
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a)
-> RepoJob a
onRepoJob RepoJob a
repojob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a)
-> RepoJob a)
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a)
-> RepoJob a
forall a b. (a -> b) -> a -> b
$ \job :: Repository rt p wR wU wR -> IO a
job repository :: Repository rt p wR wU wR
repository ->
do let name :: String
name = "./"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
darcsdirString -> String -> String
forall a. [a] -> [a] -> [a]
++"/lock"
String -> IO a -> IO a
forall a. String -> IO a -> IO a
withLock String
name (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wR -> IO a
job Repository rt p wR wU wR
repository
withRepoLockCanFail :: UseCache -> RepoJob () -> IO ()
withRepoLockCanFail :: UseCache -> RepoJob () -> IO ()
withRepoLockCanFail useCache :: UseCache
useCache repojob :: RepoJob ()
repojob =
UseCache -> RepoJob () -> IO ()
forall a. UseCache -> RepoJob a -> IO a
withRepository UseCache
useCache (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ RepoJob ()
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO ())
-> Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
RepoJob a
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO a)
-> Repository rt p wR wU wR -> IO a)
-> RepoJob a
onRepoJob RepoJob ()
repojob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO ())
-> Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(Repository rt p wR wU wR -> IO ())
-> Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \job :: Repository rt p wR wU wR -> IO ()
job repository :: Repository rt p wR wU wR
repository ->
let rf :: RepoFormat
rf = Repository rt p wR wU wR -> RepoFormat
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository rt p wR wU wR
repository in
if RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rf then do
IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Maybe String -> IO ()) -> Maybe String -> IO ()
forall a b. (a -> b) -> a -> b
$ RepoFormat -> Maybe String
writeProblem RepoFormat
rf
let name :: String
name = "./"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
darcsdirString -> String -> String
forall a. [a] -> [a] -> [a]
++"/lock"
Either () ()
eitherDone <- String -> IO () -> IO (Either () ())
forall a. String -> IO a -> IO (Either () a)
withLockCanFail String
name (Repository rt p wR wU wR -> IO ()
job Repository rt p wR wU wR
repository)
case Either () ()
eitherDone of
Left _ -> String -> IO ()
debugMessage "Lock could not be obtained, not doing the job."
Right _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else String -> IO ()
debugMessage "Not doing the job because this is an old-fashioned repository."
checkRepoIsNoRebase :: forall rt p wR wU wT. IsRepoType rt
=> Repository rt p wR wU wT
-> Maybe (Repository ('RepoType 'NoRebase) p wR wU wT)
checkRepoIsNoRebase :: Repository rt p wR wU wT
-> Maybe (Repository ('RepoType 'NoRebase) p wR wU wT)
checkRepoIsNoRebase repo :: Repository rt p wR wU wT
repo =
case SRepoType rt
forall (rt :: RepoType). IsRepoType rt => SRepoType rt
singletonRepoType :: SRepoType rt of
SRepoType SNoRebase -> Repository rt p wR wU wT -> Maybe (Repository rt p wR wU wT)
forall a. a -> Maybe a
Just Repository rt p wR wU wT
repo
SRepoType SIsRebase -> Maybe (Repository ('RepoType 'NoRebase) p wR wU wT)
forall a. Maybe a
Nothing