-- Copyright (C) 2002-2004,2007-2008 David Roundy
-- Copyright (C) 2005 Juliusz Chroboczek
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

{-# LANGUAGE ForeignFunctionInterface #-}

module Darcs.Repository.Job
    ( RepoJob(..)
    , IsPrimV1(..)
    , withRepoLock
    , withOldRepoLock
    , withRepoLockCanFail
    , withRepository
    , withRepositoryLocation
    , checkRepoIsNoRebase
    , withUMaskFlag
    ) where

import Darcs.Prelude

import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.V1 ( RepoPatchV1 )
import Darcs.Patch.V2 ( RepoPatchV2 )
import Darcs.Patch.V3 ( RepoPatchV3 )
import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )
import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )
import Darcs.Patch ( 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(..), UpdatePending(..), DryRun(..), UMask (..)
    )
import Darcs.Repository.Format
    ( RepoProperty( Darcs2
                  , Darcs3
                  , RebaseInProgress
                  , RebaseInProgress_2_16
                  , HashedInventory
                  )
    , formatHas
    , writeProblem
    )
import Darcs.Repository.Identify ( identifyRepository )
import Darcs.Repository.Hashed( revertRepositoryChanges )
import Darcs.Repository.InternalTypes
    ( Repository
    , repoFormat
    , repoLocation
    , unsafeCoerceRepoType
    , unsafeCoercePatchType
    )
import Darcs.Repository.Paths ( lockPath )
import Darcs.Repository.Rebase
    ( startRebaseJob
    , rebaseJob
    , maybeDisplaySuspendedStatus
    , checkOldStyleRebaseStatus
    )
import Darcs.Util.Lock ( withLock, withLockCanFail )

import Darcs.Util.Progress ( debugMessage )

import Control.Monad ( when )
import Control.Exception ( bracket_, finally )
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 )

withUMaskFlag :: UMask -> IO a -> IO a
withUMaskFlag :: UMask -> IO a -> IO a
withUMaskFlag UMask
NoUMask = IO a -> IO a
forall a. a -> a
id
withUMaskFlag (YesUMask String
umask) = String -> IO a -> IO a
forall a. String -> IO a -> IO a
withUMask String
umask

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 String
umask 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
< CInt
0) (String -> IO ()
forall a. String -> IO a
throwErrno String
"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

-- |A @RepoJob@ wraps up an action to be performed with a repository. Because repositories
-- can contain different types of patches, such actions typically need to be polymorphic
-- in the kind of patch they work on. @RepoJob@ is used to wrap up the polymorphism,
-- and the various functions that act on a @RepoJob@ are responsible for instantiating
-- the underlying action with the appropriate patch type.
data RepoJob a
    -- = RepoJob (forall p wR wU . RepoPatch p => Repository p wR wU wR -> IO a)
    -- TODO: Unbind Tree from RepoJob, possibly renaming existing RepoJob
    =
    -- |The most common @RepoJob@; the underlying action can accept any patch type that
    -- a darcs repository may use.
      RepoJob (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
               => Repository rt p wR wU wR -> IO a)
    -- |A job that only works on darcs 1 patches
    | V1Job (forall wR wU . Repository ('RepoType 'NoRebase) (RepoPatchV1 V1.Prim) wR wU wR -> IO a)
    -- |A job that only works on darcs 2 patches
    | V2Job (forall rt wR wU . IsRepoType rt => Repository rt (RepoPatchV2 V2.Prim) wR wU wR -> IO a)
    -- |A job that works on any repository where the patch type @p@ has 'PrimOf' @p@ = 'Prim'.
    --
    -- This was added to support darcsden, which inspects the internals of V1 prim patches.
    --
    -- In future this should be replaced with a more abstract inspection API as part of 'PrimPatch'.
    | PrimV1Job (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, IsPrimV1 (PrimOf p))
               => Repository rt p wR wU wR -> IO a)
    -- A job that works on normal darcs repositories, but will want access to the rebase patch if it exists.
    | RebaseAwareJob (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wR -> IO a)
    | RebaseJob (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
    | OldRebaseJob (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
    | StartRebaseJob (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 forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a
job) 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 forall wR wU.
Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
-> IO a
job) 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 forall (rt :: RepoType) wR wU.
IsRepoType rt =>
Repository rt (RepoPatchV2 Prim) wR wU wR -> IO a
job) 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 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) 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 forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a
job) 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
RebaseAwareJob ((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 forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job) 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 (p :: * -> * -> *) wR wU.
 (RepoPatch p, ApplyState p ~ Tree) =>
 Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> RepoJob a
forall a.
(forall (p :: * -> * -> *) wR wU.
 (RepoPatch p, ApplyState p ~ Tree) =>
 Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> RepoJob a
RebaseJob ((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 (OldRebaseJob forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job) 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 (p :: * -> * -> *) wR wU.
 (RepoPatch p, ApplyState p ~ Tree) =>
 Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> RepoJob a
forall a.
(forall (p :: * -> * -> *) wR wU.
 (RepoPatch p, ApplyState p ~ Tree) =>
 Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> RepoJob a
OldRebaseJob ((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 forall (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'IsRebase) p wR wU wR -> IO a
job) 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 (p :: * -> * -> *) wR wU.
 (RepoPatch p, ApplyState p ~ Tree) =>
 Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> RepoJob a
forall a.
(forall (p :: * -> * -> *) wR wU.
 (RepoPatch p, ApplyState p ~ Tree) =>
 Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> RepoJob a
StartRebaseJob ((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)

-- | apply a given RepoJob to a repository in the current working directory
withRepository :: UseCache -> RepoJob a -> IO a
withRepository :: UseCache -> RepoJob a -> IO a
withRepository UseCache
useCache = UseCache -> String -> RepoJob a -> IO a
forall a. UseCache -> String -> RepoJob a -> IO a
withRepositoryLocation UseCache
useCache String
"."

-- | This is just an internal type to Darcs.Repository.Job for
-- calling runJob in a strongly-typed way
data RepoPatchType p where
  RepoV1 :: RepoPatchType (RepoPatchV1 V1.Prim)
  RepoV2 :: RepoPatchType (RepoPatchV2 V2.Prim)
  RepoV3 :: RepoPatchType (RepoPatchV3 V2.Prim)

-- | This type allows us to check multiple patch types against the
-- constraints required by most repository jobs
data IsTree p where
  IsTree :: (ApplyState p ~ Tree) => IsTree p

checkTree :: RepoPatchType p -> IsTree p
checkTree :: RepoPatchType p -> IsTree p
checkTree RepoPatchType p
RepoV1 = IsTree p
forall (p :: * -> * -> *). (ApplyState p ~ Tree) => IsTree p
IsTree
checkTree RepoPatchType p
RepoV2 = IsTree p
forall (p :: * -> * -> *). (ApplyState p ~ Tree) => IsTree p
IsTree
checkTree RepoPatchType p
RepoV3 = 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

-- | This type allows us to check multiple patch types against the
-- constraints required by 'PrimV1Job'
data UsesPrimV1 p where
  UsesPrimV1 :: (ApplyState p ~ Tree, IsPrimV1 (PrimOf p)) => UsesPrimV1 p

checkPrimV1 :: RepoPatchType p -> UsesPrimV1 p
checkPrimV1 :: RepoPatchType p -> UsesPrimV1 p
checkPrimV1 RepoPatchType p
RepoV1 = UsesPrimV1 p
forall (p :: * -> * -> *).
(ApplyState p ~ Tree, IsPrimV1 (PrimOf p)) =>
UsesPrimV1 p
UsesPrimV1
checkPrimV1 RepoPatchType p
RepoV2 = UsesPrimV1 p
forall (p :: * -> * -> *).
(ApplyState p ~ Tree, IsPrimV1 (PrimOf p)) =>
UsesPrimV1 p
UsesPrimV1
checkPrimV1 RepoPatchType p
RepoV3 = UsesPrimV1 p
forall (p :: * -> * -> *).
(ApplyState p ~ Tree, IsPrimV1 (PrimOf p)) =>
UsesPrimV1 p
UsesPrimV1

-- | apply a given RepoJob to a repository in a given url
withRepositoryLocation :: UseCache -> String -> RepoJob a -> IO a
withRepositoryLocation :: UseCache -> String -> RepoJob a -> IO a
withRepositoryLocation UseCache
useCache String
url 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
                RepoJob a
_ -> Bool
False

        -- in order to pass SRepoType and RepoPatchType at different types, we need a polymorphic
        -- function that we call in two different ways, rather than directly varying the argument.
        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 SRebaseType rebaseType
isRebase =
          if RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs3 RepoFormat
rf
          then RepoPatchType (RepoPatchV3 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 (RepoPatchV3 Prim)
RepoV3 (SRebaseType rebaseType -> SRepoType ('RepoType rebaseType)
forall (rebaseType :: RebaseType).
SRebaseType rebaseType -> SRepoType ('RepoType rebaseType)
SRepoType SRebaseType rebaseType
isRebase)
          else
            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 Bool -> Bool -> Bool
|| RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
RebaseInProgress_2_16 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 RepoPatchType p
patchType (SRepoType SRebaseType rebaseType
isRebase) Repository rtDummy pDummy wR wU wR
repo RepoJob a
repojob = do

  -- The actual type the repository should have is only known when
  -- when this function is called, so we need to "cast" it to its proper type
  let
    therepo :: Repository rt p wR wU wR
therepo = Repository rt pDummy wR wU wR -> Repository rt p wR wU wR
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT
       (p' :: * -> * -> *).
Repository rt p wR wU wT -> Repository rt p' wR wU wT
unsafeCoercePatchType (Repository rtDummy pDummy wR wU wR -> Repository rt pDummy wR wU wR
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT
       (rt' :: RepoType).
Repository rt p wR wU wT -> Repository rt' p wR wU wT
unsafeCoerceRepoType Repository rtDummy pDummy wR wU wR
repo) :: Repository rt p wR wU wR

    patchTypeString :: String
    patchTypeString :: String
patchTypeString =
      case RepoPatchType p
patchType of
        RepoPatchType p
RepoV3 -> String
"darcs-3"
        RepoPatchType p
RepoV2 -> String
"darcs-2"
        RepoPatchType p
RepoV1 -> String
"darcs-1"

    repoAttributes :: [String]
    repoAttributes :: [String]
repoAttributes =
      case SRebaseType rebaseType
isRebase of
        SRebaseType rebaseType
SIsRebase -> [String
"rebase"]
        SRebaseType rebaseType
SNoRebase -> []

    repoAttributesString :: String
    repoAttributesString :: String
repoAttributesString =
      case [String]
repoAttributes of
        [] -> String
""
        [String]
_ -> String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"+" [String]
repoAttributes

  String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"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]
++
                 String
" 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 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 p
IsTree -> do
          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 ()
checkOldStyleRebaseStatus SRebaseType rebaseType
isRebase Repository rt p wR wU wR
Repository ('RepoType rebaseType) p wR wU wR
therepo
          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 ()
maybeDisplaySuspendedStatus SRebaseType rebaseType
isRebase Repository rt p wR wU wR
Repository ('RepoType rebaseType) p wR wU wR
therepo

    PrimV1Job 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 p
UsesPrimV1 -> do
          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 ()
checkOldStyleRebaseStatus SRebaseType rebaseType
isRebase Repository rt p wR wU wR
Repository ('RepoType rebaseType) p wR wU wR
therepo
          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 ()
maybeDisplaySuspendedStatus SRebaseType rebaseType
isRebase Repository rt p wR wU wR
Repository ('RepoType rebaseType) p wR wU wR
therepo

    V2Job 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
        (RepoPatchType p
RepoV2, SRebaseType rebaseType
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
        (RepoPatchType p
RepoV2, SRebaseType rebaseType
SIsRebase) ->
          String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"This command is not supported while a rebase is in progress."
        (RepoPatchType p
RepoV1, SRebaseType rebaseType
_        ) ->
          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
$    String
"This repository contains darcs v1 patches,"
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but the command requires darcs v2 patches."
        (RepoPatchType p
RepoV3, SRebaseType rebaseType
_        ) ->
          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
$    String
"This repository contains darcs v3 patches,"
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but the command requires darcs v2 patches."

    V1Job forall wR wU.
Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
-> IO a
job ->
      case (RepoPatchType p
patchType, SRebaseType rebaseType
isRebase) of
        (RepoPatchType p
RepoV1, SRebaseType rebaseType
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
        (RepoPatchType p
RepoV1, SRebaseType rebaseType
SIsRebase) ->
          String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"This command is not supported while a rebase is in progress."
        (RepoPatchType p
RepoV2, SRebaseType rebaseType
_        ) ->
          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
$    String
"This repository contains darcs v2 patches,"
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but the command requires darcs v1 patches."
        (RepoPatchType p
RepoV3, SRebaseType rebaseType
_        ) ->
          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
$    String
"This repository contains darcs v3 patches,"
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but the command requires darcs v1 patches."

    RebaseAwareJob 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 p
IsTree, SRebaseType rebaseType
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 p
IsTree, SRebaseType rebaseType
SIsRebase) -> do
          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 ()
checkOldStyleRebaseStatus SRebaseType rebaseType
isRebase Repository rt p wR wU wR
Repository ('RepoType rebaseType) p wR wU wR
therepo
          (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR -> 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 -> 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

    RebaseJob 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
        (IsTree p
_     , SRebaseType rebaseType
SNoRebase) -> String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No rebase in progress. Try 'darcs rebase suspend' first."
        (IsTree p
IsTree, SRebaseType rebaseType
SIsRebase) -> do
          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 ()
checkOldStyleRebaseStatus SRebaseType rebaseType
isRebase Repository rt p wR wU wR
Repository ('RepoType rebaseType) p wR wU wR
therepo
          (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR -> 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 -> 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

    OldRebaseJob 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
        (IsTree p
_     , SRebaseType rebaseType
SNoRebase) -> String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No rebase in progress."
        (IsTree p
IsTree, SRebaseType rebaseType
SIsRebase) -> do
          -- no checkOldStyleRebaseStatus, this is for 'rebase upgrade'
          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
            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 ()
maybeDisplaySuspendedStatus SRebaseType rebaseType
isRebase Repository rt p wR wU wR
Repository ('RepoType rebaseType) p wR wU wR
therepo

    StartRebaseJob 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
        (IsTree p
_     , SRebaseType rebaseType
SNoRebase) -> String -> IO a
forall a. HasCallStack => String -> a
error String
"impossible case"
        (IsTree p
IsTree, SRebaseType rebaseType
SIsRebase) -> do
          -- no checkOldStyleRebaseStatus, startRebaseJob does that
          (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
-> Repository ('RepoType 'IsRebase) p wR wU wR -> 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 -> 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

-- | Apply a given RepoJob to a repository in the current working directory.
-- However, before doing the job, take the repo lock and initializes a repo
-- transaction, unless this is a dry-run.
withRepoLock :: DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock :: DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
YesDryRun UseCache
useCache UpdatePending
_ UMask
_ 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
$ \Repository rt p wR wU wR -> IO a
job Repository rt p wR wU wR
repository -> Repository rt p wR wU wR -> IO a
job Repository rt p wR wU wR
repository
withRepoLock DryRun
NoDryRun UseCache
useCache UpdatePending
upe UMask
um RepoJob a
repojob =
  String -> IO a -> IO a
forall a. String -> IO a -> IO a
withLock String
lockPath (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
    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
$ \Repository rt p wR wU wR -> IO a
job 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)
      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
$ Repository rt p wR wU wR
-> UpdatePending -> IO (Repository rt p wR wU wR)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT
-> UpdatePending -> IO (Repository rt p wR wU wR)
revertRepositoryChanges Repository rt p wR wU wR
repository UpdatePending
upe IO (Repository rt p wR wU wR)
-> (Repository rt p wR wU wR -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Repository rt p wR wU wR -> IO a
job

-- | run a lock-taking job in an old-fashion repository.
--   only used by `darcs optimize upgrade`.
withOldRepoLock :: RepoJob a -> IO a
withOldRepoLock :: RepoJob a -> IO a
withOldRepoLock 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
$ \Repository rt p wR wU wR -> IO a
job Repository rt p wR wU wR
repository ->
    String -> IO a -> IO a
forall a. String -> IO a -> IO a
withLock String
lockPath (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

-- | Apply a given RepoJob to a repository in the current working directory,
-- taking a lock. If lock not takeable, do nothing. If old-fashioned
-- repository, do nothing. The job must not touch pending or pending.tentative,
-- because there is no call to revertRepositoryChanges. This entry point is
-- currently only used for attemptCreatePatchIndex.
withRepoLockCanFail :: UseCache -> RepoJob () -> IO ()
withRepoLockCanFail :: UseCache -> RepoJob () -> IO ()
withRepoLockCanFail UseCache
useCache RepoJob ()
repojob = do
  Either () ()
eitherDone <-
    String -> IO () -> IO (Either () ())
forall a. String -> IO a -> IO (Either () a)
withLockCanFail String
lockPath (IO () -> IO (Either () ())) -> IO () -> IO (Either () ())
forall a b. (a -> b) -> a -> b
$
      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
$ \Repository rt p wR wU wR -> IO ()
job Repository rt p wR wU wR
repository -> do
        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
        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
          Repository rt p wR wU wR -> IO ()
job Repository rt p wR wU wR
repository
        else
          String -> IO ()
debugMessage
            String
"Not doing the job because this is an old-fashioned repository."
  case Either () ()
eitherDone of
    Left  ()
_ -> String -> IO ()
debugMessage String
"Lock could not be obtained, not doing the job."
    Right ()
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | If the 'RepoType' of the given repo indicates that we have 'NoRebase',
-- then 'Just' the repo with the refined type, else 'Nothing'.
-- NB The amount of types we have to import to make this simple check is ridiculous!
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 Repository rt p wR wU wT
repo =
  case SRepoType rt
forall (rt :: RepoType). IsRepoType rt => SRepoType rt
singletonRepoType :: SRepoType rt of
    SRepoType SRebaseType rebaseType
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 SRebaseType rebaseType
SIsRebase -> Maybe (Repository ('RepoType 'NoRebase) p wR wU wT)
forall a. Maybe a
Nothing