{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.Optimize ( optimize ) where
import Prelude ()
import Darcs.Prelude
import Control.Monad ( when, unless, forM_ )
import Data.List ( nub )
import Data.Maybe ( fromJust, isJust )
import System.Directory
( getDirectoryContents
, doesDirectoryExist
, renameFile
, createDirectoryIfMissing
, removeFile
, getHomeDirectory
)
import qualified Data.ByteString.Char8 as BC
import Darcs.UI.Commands ( DarcsCommand(..), nodefaults
, amInHashedRepository, amInRepository, putInfo
, normalCommand, withStdOpts )
import Darcs.UI.Completion ( noArgs )
import Darcs.Repository.Prefs ( getPreflist, getCaches, globalCacheDir )
import Darcs.Repository
( Repository
, repoLocation
, withRepoLock
, RepoJob(..)
, readRepo
, reorderInventory
, cleanRepository
, replacePristine
)
import Darcs.Repository.Job ( withOldRepoLock )
import Darcs.Repository.Identify ( findAllReposInDir )
import Darcs.Repository.Hashed ( inventoriesDir, patchesDir, pristineDir,
hashedInventory,
listInventoriesRepoDir,
listPatchesLocalBucketed, diffHashLists, peekPristineHash )
import Darcs.Repository.Packs ( createPacks )
import Darcs.Repository.Pending ( pendingName )
import Darcs.Repository.HashedIO ( getHashedFiles )
import Darcs.Patch.Witnesses.Ordered
( mapFL
, bunchFL
, lengthRL
)
import Darcs.Patch ( IsRepoType, RepoPatch )
import Darcs.Patch.Set
( patchSet2RL
, patchSet2FL
, progressPatchSet
)
import Darcs.Patch.Apply( ApplyState )
import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.Printer ( text )
import Darcs.Util.Lock
( maybeRelink
, gzWriteAtomicFilePS
, writeAtomicFilePS
, rmRecursive
, removeFileMayNotExist
, writeBinFile
)
import Darcs.Util.File
( withCurrentDirectory
, getRecursiveContents
, doesDirectoryReallyExist
)
import Darcs.UI.External ( catchall )
import Darcs.Util.Progress
( beginTedious
, endTedious
, tediousSize
, debugMessage
)
import Darcs.Util.Global ( darcsdir )
import System.FilePath.Posix
( takeExtension
, (</>)
, joinPath
)
import Text.Printf ( printf )
import Darcs.UI.Flags
( DarcsFlag, verbosity, useCache, umask )
import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise
, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags
( UpdateWorking (..), DryRun ( NoDryRun ), UseCache (..), UMask (..)
, WithWorkingDir(WithWorkingDir), PatchFormat(PatchFormat1) )
import Darcs.Patch.Progress ( progressFL )
import Darcs.Repository.Cache ( hashedDir, bucketFolder,
HashedDir(HashedPristineDir) )
import Darcs.Repository.Format
( identifyRepoFormat
, createRepoFormat
, writeRepoFormat
, formatHas
, RepoProperty ( HashedInventory )
)
import Darcs.Repository.PatchIndex
import qualified Darcs.Repository.Hashed as HashedRepo
import Darcs.Repository.State ( readRecorded )
import Darcs.Util.Tree
( Tree
, TreeItem(..)
, list
, expand
, emptyTree
)
import Darcs.Util.Path( anchorPath, toFilePath, AbsolutePath )
import Darcs.Util.Tree.Plain( readPlainTree )
import Darcs.Util.Tree.Hashed
( writeDarcsHashed
, decodeDarcsSize
)
optimizeDescription :: String
optimizeDescription :: String
optimizeDescription = "Optimize the repository."
optimizeHelp :: String
optimizeHelp :: String
optimizeHelp =
"The `darcs optimize` command modifies the current repository in an\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"attempt to reduce its resource requirements."
optimize :: DarcsCommand [DarcsFlag]
optimize :: DarcsCommand [DarcsFlag]
optimize = SuperCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> ([DarcsFlag] -> IO (Either String ()))
-> [CommandControl]
-> DarcsCommand parsedFlags
SuperCommand {
commandProgramName :: String
commandProgramName = "darcs"
, commandName :: String
commandName = "optimize"
, commandHelp :: String
commandHelp = String
optimizeHelp
, commandDescription :: String
commandDescription = String
optimizeDescription
, commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInRepository
, commandSubCommands :: [CommandControl]
commandSubCommands = [ DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
optimizeClean,
DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
optimizeHttp,
DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
optimizeReorder,
DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
optimizeEnablePatchIndex,
DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
optimizeDisablePatchIndex,
DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
optimizeCompress,
DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
optimizeUncompress,
DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
optimizeRelink,
DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
optimizePristine,
DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
optimizeUpgrade,
DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
optimizeGlobalCache
]
}
commonBasicOpts :: DarcsOption a (Maybe String -> UMask -> a)
commonBasicOpts :: DarcsOption a (Maybe String -> UMask -> a)
commonBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag (UMask -> a) (Maybe String)
PrimDarcsOption (Maybe String)
O.repoDir PrimOptSpec DarcsOptDescr DarcsFlag (UMask -> a) (Maybe String)
-> OptSpec DarcsOptDescr DarcsFlag a (UMask -> a)
-> DarcsOption a (Maybe String -> UMask -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (UMask -> a)
PrimDarcsOption UMask
O.umask
commonAdvancedOpts :: DarcsOption a a
commonAdvancedOpts :: DarcsOption a a
commonAdvancedOpts = DarcsOption a a
forall (d :: * -> *) f a. OptSpec d f a a
oid
common :: DarcsCommand [DarcsFlag]
common :: DarcsCommand [DarcsFlag]
common = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
-> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
{ commandProgramName :: String
commandProgramName = "darcs"
, commandExtraArgs :: Int
commandExtraArgs = 0
, commandExtraArgHelp :: [String]
commandExtraArgHelp = []
, commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
, commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
, commandName :: String
commandName = String
forall a. HasCallStack => a
undefined
, commandHelp :: String
commandHelp = String
forall a. HasCallStack => a
undefined
, commandDescription :: String
commandDescription = String
forall a. HasCallStack => a
undefined
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
forall a. HasCallStack => a
undefined
, commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any Any
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any Any
forall a. DarcsOption a a
commonAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec DarcsOptDescr DarcsFlag Any (Maybe String -> UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (Maybe String -> UMask -> Any)
forall a. DarcsOption a (Maybe String -> UMask -> a)
commonBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Maybe String
-> UMask
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Maybe String
-> UMask
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(Maybe String
-> UMask
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
commonOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
(Maybe String
-> UMask
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
DarcsOptDescr
DarcsFlag
Any
(Maybe String
-> UMask
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> Any)
forall a.
DarcsOption
a
(Maybe String
-> UMask
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
commonOpts
, commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Maybe String
-> UMask
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Maybe String
-> UMask
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(Maybe String
-> UMask
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
commonOpts
}
where
commonOpts :: DarcsOption
a
(Maybe String
-> UMask
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
commonOpts = DarcsOption
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
(Maybe String
-> UMask
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
forall a. DarcsOption a (Maybe String -> UMask -> a)
commonBasicOpts DarcsOption
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
(Maybe String
-> UMask
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
-> DarcsOption
(UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
-> DarcsOption
a
(Maybe String
-> UMask
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
forall b c a.
DarcsOption
(Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
(UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
forall a. DarcsOption a a
commonAdvancedOpts
optimizeClean :: DarcsCommand [DarcsFlag]
optimizeClean :: DarcsCommand [DarcsFlag]
optimizeClean = DarcsCommand [DarcsFlag]
common
{ commandName :: String
commandName = "clean"
, commandHelp :: String
commandHelp = "This command deletes obsolete files within the repository."
, commandDescription :: String
commandDescription = "garbage collect pristine, inventories and patches"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCleanCmd
}
optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCleanCmd _ opts :: [DarcsFlag]
opts _ =
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
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 ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
Repository rt p wR wU wR -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wR
repository
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Done cleaning repository!"
optimizeUpgrade :: DarcsCommand [DarcsFlag]
optimizeUpgrade :: DarcsCommand [DarcsFlag]
optimizeUpgrade = DarcsCommand [DarcsFlag]
common
{ commandName :: String
commandName = "upgrade"
, commandHelp :: String
commandHelp = "Convert old-fashioned repositories to the current default hashed format."
, commandDescription :: String
commandDescription = "upgrade repository to latest compatible format"
, commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInRepository
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUpgradeCmd
}
optimizeHttp :: DarcsCommand [DarcsFlag]
optimizeHttp :: DarcsCommand [DarcsFlag]
optimizeHttp = DarcsCommand [DarcsFlag]
common
{ commandName :: String
commandName = "http"
, commandHelp :: String
commandHelp = String
optimizeHelpHttp
, commandDescription :: String
commandDescription = "optimize repository for getting over network"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeHttpCmd
}
optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeHttpCmd _ opts :: [DarcsFlag]
opts _ =
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
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 ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
Repository rt p wR wU wR -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wR
repository
Repository rt p wR wU wR -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO ()
createPacks Repository rt p wR wU wR
repository
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Done creating packs!"
optimizePristine :: DarcsCommand [DarcsFlag]
optimizePristine :: DarcsCommand [DarcsFlag]
optimizePristine = DarcsCommand [DarcsFlag]
common
{ commandName :: String
commandName = "pristine"
, commandHelp :: String
commandHelp = "This command updates the format of `_darcs/pristine.hashed/`, which was different\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "before darcs 2.3.1."
, commandDescription :: String
commandDescription = "optimize hashed pristine layout"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizePristineCmd
}
optimizePristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizePristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizePristineCmd _ opts :: [DarcsFlag]
opts _ =
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
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 ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
Repository rt p wR wU wR -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wR
repository
[DarcsFlag] -> Repository rt p wR wU wR -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
[DarcsFlag] -> Repository rt p wR wU wT -> IO ()
doOptimizePristine [DarcsFlag]
opts Repository rt p wR wU wR
repository
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Done optimizing pristine!"
optimizeCompress :: DarcsCommand [DarcsFlag]
optimizeCompress :: DarcsCommand [DarcsFlag]
optimizeCompress = DarcsCommand [DarcsFlag]
common
{ commandName :: String
commandName = "compress"
, commandHelp :: String
commandHelp = String
optimizeHelpCompression
, commandDescription :: String
commandDescription = "compress patches and inventories"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCompressCmd
}
optimizeUncompress :: DarcsCommand [DarcsFlag]
optimizeUncompress :: DarcsCommand [DarcsFlag]
optimizeUncompress = DarcsCommand [DarcsFlag]
common
{ commandName :: String
commandName = "uncompress"
, commandHelp :: String
commandHelp = String
optimizeHelpCompression
, commandDescription :: String
commandDescription = "uncompress patches and inventories"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUncompressCmd
}
optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCompressCmd _ opts :: [DarcsFlag]
opts _ =
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
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 ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
Repository rt p wR wU wR -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wR
repository
Compression -> [DarcsFlag] -> IO ()
optimizeCompression Compression
O.GzipCompression [DarcsFlag]
opts
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Done optimizing by compression!"
optimizeUncompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUncompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUncompressCmd _ opts :: [DarcsFlag]
opts _ =
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
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 ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
Repository rt p wR wU wR -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wR
repository
Compression -> [DarcsFlag] -> IO ()
optimizeCompression Compression
O.NoCompression [DarcsFlag]
opts
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Done optimizing by uncompression!"
optimizeCompression :: O.Compression -> [DarcsFlag] -> IO ()
optimizeCompression :: Compression -> [DarcsFlag] -> IO ()
optimizeCompression compression :: Compression
compression opts :: [DarcsFlag]
opts = do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Optimizing (un)compression of patches..."
String -> IO ()
do_compress (String
darcsdir String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/patches")
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Optimizing (un)compression of inventories..."
String -> IO ()
do_compress (String
darcsdir String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/inventories")
where
do_compress :: String -> IO ()
do_compress f :: String
f = do
Bool
isd <- String -> IO Bool
doesDirectoryExist String
f
if Bool
isd
then String -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory String
f (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[String]
fs <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
notdot ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO [String]
getDirectoryContents "."
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
do_compress [String]
fs
else String -> IO ByteString
gzReadFilePS String
f IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
case Compression
compression of
O.GzipCompression -> String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
gzWriteAtomicFilePS String
f
O.NoCompression -> String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS String
f
notdot :: String -> Bool
notdot ('.':_) = Bool
False
notdot _ = Bool
True
optimizeEnablePatchIndex :: DarcsCommand [DarcsFlag]
optimizeEnablePatchIndex :: DarcsCommand [DarcsFlag]
optimizeEnablePatchIndex = DarcsCommand [DarcsFlag]
common
{ commandName :: String
commandName = "enable-patch-index"
, commandHelp :: String
commandHelp = "Build the patch index, an internal data structure that accelerates\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "commands that need to know what patches touch a given file. Such as\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "annotate and log."
, commandDescription :: String
commandDescription = "Enable patch index"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeEnablePatchIndexCmd
}
optimizeDisablePatchIndex :: DarcsCommand [DarcsFlag]
optimizeDisablePatchIndex :: DarcsCommand [DarcsFlag]
optimizeDisablePatchIndex = DarcsCommand [DarcsFlag]
common
{ commandName :: String
commandName = "disable-patch-index"
, commandHelp :: String
commandHelp = "Delete and stop maintaining the patch index from the repository."
, commandDescription :: String
commandDescription = "Disable patch index"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeDisablePatchIndexCmd
}
optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeEnablePatchIndexCmd _ opts :: [DarcsFlag]
opts _ =
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
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 ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
PatchSet rt p Origin wR
ps <- Repository rt p wR wU wR -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
repository
Repository rt p wR wU wR -> PatchSet rt p Origin wR -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO ()
createOrUpdatePatchIndexDisk Repository rt p wR wU wR
repository PatchSet rt p Origin wR
ps
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Done enabling patch index!"
optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeDisablePatchIndexCmd _ opts :: [DarcsFlag]
opts _ =
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
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 ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repo :: Repository rt p wR wU wR
repo -> do
String -> IO ()
deletePatchIndex (Repository rt p wR wU wR -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p wR wU wR
repo)
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Done disabling patch index!"
optimizeReorder :: DarcsCommand [DarcsFlag]
optimizeReorder :: DarcsCommand [DarcsFlag]
optimizeReorder = DarcsCommand [DarcsFlag]
common
{ commandName :: String
commandName = "reorder"
, commandHelp :: String
commandHelp = "This command moves recent patches (those not included in\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"the latest tag) to the \"front\", reducing the amount that a typical\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"remote command needs to download. It should also reduce the CPU time\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"needed for some operations."
, commandDescription :: String
commandDescription = "reorder the patches in the repository"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeReorderCmd
}
optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeReorderCmd _ opts :: [DarcsFlag]
opts _ =
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
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 ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
Repository rt p wR wU wR
-> Compression -> UpdateWorking -> Verbosity -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> Compression -> UpdateWorking -> Verbosity -> IO ()
reorderInventory Repository rt p wR wU wR
repository (PrimDarcsOption Compression
O.compress PrimDarcsOption Compression -> [DarcsFlag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Done reordering!"
optimizeRelink :: DarcsCommand [DarcsFlag]
optimizeRelink :: DarcsCommand [DarcsFlag]
optimizeRelink = DarcsCommand [DarcsFlag]
common
{ commandName :: String
commandName = "relink"
, commandHelp :: String
commandHelp = String
optimizeHelpRelink
, commandDescription :: String
commandDescription = "relink random internal data to a sibling"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeRelinkCmd
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any Any
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any Any
forall a. DarcsOption a a
commonAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
(Maybe String -> UMask -> [AbsolutePath] -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
DarcsOptDescr
DarcsFlag
Any
(Maybe String -> UMask -> [AbsolutePath] -> Any)
forall a.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe String -> UMask -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Maybe String
-> UMask
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Maybe String
-> UMask
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(Maybe String
-> UMask
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
optimizeRelinkOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
(Maybe String
-> UMask
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
DarcsOptDescr
DarcsFlag
Any
(Maybe String
-> UMask
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> Any)
forall a.
DarcsOption
a
(Maybe String
-> UMask
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
optimizeRelinkOpts
, commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Maybe String
-> UMask
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(Maybe String
-> UMask
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(Maybe String
-> UMask
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
optimizeRelinkOpts
}
where
optimizeRelinkBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe String -> UMask -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts = DarcsOption
([AbsolutePath] -> a)
(Maybe String -> UMask -> [AbsolutePath] -> a)
forall a. DarcsOption a (Maybe String -> UMask -> a)
commonBasicOpts DarcsOption
([AbsolutePath] -> a)
(Maybe String -> UMask -> [AbsolutePath] -> a)
-> OptSpec DarcsOptDescr DarcsFlag a ([AbsolutePath] -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe String -> UMask -> [AbsolutePath] -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a ([AbsolutePath] -> a)
PrimDarcsOption [AbsolutePath]
O.siblings
optimizeRelinkOpts :: DarcsOption
a
(Maybe String
-> UMask
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
optimizeRelinkOpts = OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
(Maybe String
-> UMask
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
forall a.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe String -> UMask -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
(Maybe String
-> UMask
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
-> DarcsOption
(UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
-> DarcsOption
a
(Maybe String
-> UMask
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
forall b c a.
DarcsOption
(Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
(UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
forall a. DarcsOption a a
commonAdvancedOpts
optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeRelinkCmd _ opts :: [DarcsFlag]
opts _ =
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
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 ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
Repository rt p wR wU wR -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wR
repository
[DarcsFlag] -> IO ()
doRelink [DarcsFlag]
opts
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Done relinking!"
optimizeHelpHttp :: String
optimizeHelpHttp :: String
optimizeHelpHttp = [String] -> String
unlines
[ "Using this option creates 'repository packs' that could dramatically"
, "speed up performance when a user does a `darcs clone` of the repository"
, "over HTTP. To make use of packs, the clients must have a darcs of at"
, "least version 2.10."
]
optimizeHelpCompression :: String
optimizeHelpCompression :: String
optimizeHelpCompression =
"By default patches are compressed with zlib (RFC 1951) to reduce\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"storage (and download) size. In exceptional circumstances, it may be\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"preferable to avoid compression. In this case the `--dont-compress`\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"option can be used (e.g. with `darcs record`) to avoid compression.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"The `darcs optimize uncompress` and `darcs optimize compress`\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"commands can be used to ensure existing patches in the current\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"repository are respectively uncompressed or compressed."
optimizeHelpRelink :: String
optimizeHelpRelink :: String
optimizeHelpRelink =
"The `darcs optimize relink` command hard-links patches that the\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"current repository has in common with its peers. Peers are those\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"repositories listed in `_darcs/prefs/sources`, or defined with the\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"`--sibling` option (which can be used multiple times).\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"Darcs uses hard-links automatically, so this command is rarely needed.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"It is most useful if you used `cp -r` instead of `darcs clone` to copy a\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"repository, or if you pulled the same patch from a remote repository\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"into multiple local repositories."
doOptimizePristine :: [DarcsFlag] -> Repository rt p wR wU wT -> IO ()
doOptimizePristine :: [DarcsFlag] -> Repository rt p wR wU wT -> IO ()
doOptimizePristine opts :: [DarcsFlag]
opts repo :: Repository rt p wR wU wT
repo = do
ByteString
inv <- String -> IO ByteString
BC.readFile (String
darcsdir String -> String -> String
</> "hashed_inventory")
let linesInv :: [ByteString]
linesInv = Char -> ByteString -> [ByteString]
BC.split '\n' ByteString
inv
case [ByteString]
linesInv of
[] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(pris_line :: ByteString
pris_line:_) ->
let size :: Maybe Int
size = ByteString -> Maybe Int
decodeDarcsSize (ByteString -> Maybe Int) -> ByteString -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BC.drop 9 ByteString
pris_line
in Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
size) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Optimizing hashed pristine..."
Repository rt p wR wU wT -> IO (Tree IO)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wT
repo IO (Tree IO) -> (Tree IO -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Repository rt p wR wU wT -> Tree IO -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Tree IO -> IO ()
replacePristine Repository rt p wR wU wT
repo
Repository rt p wR wU wT -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wT
repo
doRelink :: [DarcsFlag] -> IO ()
doRelink :: [DarcsFlag] -> IO ()
doRelink opts :: [DarcsFlag]
opts =
do let some_siblings :: [AbsolutePath]
some_siblings = PrimDarcsOption [AbsolutePath] -> [DarcsFlag] -> [AbsolutePath]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption [AbsolutePath]
O.siblings [DarcsFlag]
opts
[String]
defrepolist <- String -> IO [String]
getPreflist "defaultrepo"
let siblings :: [String]
siblings = (AbsolutePath -> String) -> [AbsolutePath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath [AbsolutePath]
some_siblings [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
defrepolist
if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
siblings
then [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "No siblings -- no relinking done."
else do String -> IO ()
debugMessage "Relinking patches..."
Tree IO
patch_tree <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand (Tree IO -> IO (Tree IO)) -> IO (Tree IO) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Tree IO)
readPlainTree (String
darcsdir String -> String -> String
</> "patches")
let patches :: [String]
patches = [ String -> AnchoredPath -> String
anchorPath "" AnchoredPath
p | (p :: AnchoredPath
p, File _) <- Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
patch_tree ]
[String] -> [String] -> String -> IO ()
maybeRelinkFiles [String]
siblings [String]
patches (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
darcsdir String -> String -> String
</> "patches"
String -> IO ()
debugMessage "Done relinking."
maybeRelinkFiles :: [String] -> [String] -> String -> IO ()
maybeRelinkFiles :: [String] -> [String] -> String -> IO ()
maybeRelinkFiles src :: [String]
src dst :: [String]
dst dir :: String
dir =
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([String] -> String -> IO ()
maybeRelinkFile [String]
src (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/") String -> String -> String
forall a. [a] -> [a] -> [a]
++)) [String]
dst
maybeRelinkFile :: [String] -> String -> IO ()
maybeRelinkFile :: [String] -> String -> IO ()
maybeRelinkFile [] _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeRelinkFile (h :: String
h:t :: [String]
t) f :: String
f =
do Bool
done <- String -> String -> IO Bool
maybeRelink (String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f) String
f
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
done (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[String] -> String -> IO ()
maybeRelinkFile [String]
t String
f
optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUpgradeCmd _ opts :: [DarcsFlag]
opts _ = do
RepoFormat
rf <- String -> IO RepoFormat
identifyRepoFormat "."
String -> IO ()
debugMessage "Found our format"
if RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rf
then [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "No action taken because this repository already is hashed."
else do [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Upgrading to hashed..."
RepoJob () -> IO ()
forall a. RepoJob a -> IO a
withOldRepoLock (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
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 forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO ()
actuallyUpgradeFormat
actuallyUpgradeFormat
:: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT -> IO ()
actuallyUpgradeFormat :: Repository rt p wR wU wT -> IO ()
actuallyUpgradeFormat repository :: Repository rt p wR wU wT
repository = do
PatchSet rt p Origin wR
patches <- Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
repository
let k :: String
k = "Hashing patch"
String -> IO ()
beginTedious String
k
String -> Int -> IO ()
tediousSize String
k (RL (PatchInfoAnd rt p) Origin wR -> Int
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL (RL (PatchInfoAnd rt p) Origin wR -> Int)
-> RL (PatchInfoAnd rt p) Origin wR -> Int
forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wR -> RL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL PatchSet rt p Origin wR
patches)
let patches' :: PatchSet rt p Origin wR
patches' = String -> PatchSet rt p Origin wR -> PatchSet rt p Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
String -> PatchSet rt p wStart wX -> PatchSet rt p wStart wX
progressPatchSet String
k PatchSet rt p Origin wR
patches
Cache
cache <- UseCache -> String -> IO Cache
getCaches UseCache
YesUseCache "."
let compressDefault :: Compression
compressDefault = PrimDarcsOption Compression
O.compress PrimDarcsOption Compression -> [DarcsFlag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? []
Cache -> Compression -> PatchSet rt p Origin wR -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX.
RepoPatch p =>
Cache -> Compression -> PatchSet rt p Origin wX -> IO ()
HashedRepo.writeTentativeInventory Cache
cache Compression
compressDefault PatchSet rt p Origin wR
patches'
String -> IO ()
endTedious String
k
let patchesToApply :: FL (PatchInfoAnd rt p) Origin wR
patchesToApply = String
-> FL (PatchInfoAnd rt p) Origin wR
-> FL (PatchInfoAnd rt p) Origin wR
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL "Applying patch" (FL (PatchInfoAnd rt p) Origin wR
-> FL (PatchInfoAnd rt p) Origin wR)
-> FL (PatchInfoAnd rt p) Origin wR
-> FL (PatchInfoAnd rt p) Origin wR
forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wR -> FL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet rt p Origin wR
patches'
Bool -> String -> IO ()
createDirectoryIfMissing Bool
False (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
darcsdir String -> String -> String
</> HashedDir -> String
hashedDir HashedDir
HashedPristineDir
Hash
_ <- Tree IO -> String -> IO Hash
writeDarcsHashed Tree IO
forall (m :: * -> *). Tree m
emptyTree (String -> IO Hash) -> String -> IO Hash
forall a b. (a -> b) -> a -> b
$ String
darcsdir String -> String -> String
</> HashedDir -> String
hashedDir HashedDir
HashedPristineDir
String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeBinFile (String
darcsdirString -> String -> String
forall a. [a] -> [a] -> [a]
++"/tentative_pristine") ""
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall wW wZ. FL (PatchInfoAnd rt p) wW wZ -> IO ())
-> FL (FL (PatchInfoAnd rt p)) Origin wR -> [IO ()]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wW wZ. FL (PatchInfoAnd rt p) wW wZ -> IO ()
forall (p :: * -> * -> *) wX wY.
(ApplyState p ~ Tree, Apply p) =>
p wX wY -> IO ()
HashedRepo.applyToTentativePristineCwd (FL (FL (PatchInfoAnd rt p)) Origin wR -> [IO ()])
-> FL (FL (PatchInfoAnd rt p)) Origin wR -> [IO ()]
forall a b. (a -> b) -> a -> b
$ Int
-> FL (PatchInfoAnd rt p) Origin wR
-> FL (FL (PatchInfoAnd rt p)) Origin wR
forall (a :: * -> * -> *) wX wY.
Int -> FL a wX wY -> FL (FL a) wX wY
bunchFL 100 FL (PatchInfoAnd rt p) Origin wR
patchesToApply
Repository rt p wR wU wT -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> Compression -> IO ()
HashedRepo.finalizeTentativeChanges Repository rt p wR wU wT
repository Compression
compressDefault
RepoFormat -> String -> IO ()
writeRepoFormat (PatchFormat -> WithWorkingDir -> RepoFormat
createRepoFormat PatchFormat
PatchFormat1 WithWorkingDir
WithWorkingDir) (String
darcsdir String -> String -> String
</> "format")
String -> IO ()
debugMessage "Cleaning out old-fashioned repository files..."
String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
darcsdir String -> String -> String
</> "inventory"
String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
darcsdir String -> String -> String
</> "tentative_inventory"
String -> IO ()
rmRecursive (String
darcsdir String -> String -> String
</> "pristine") IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` String -> IO ()
rmRecursive (String
darcsdir String -> String -> String
</> "current")
String -> IO ()
forall p. FilePathLike p => p -> IO ()
rmGzsIn (String
darcsdir String -> String -> String
</> "patches")
String -> IO ()
forall p. FilePathLike p => p -> IO ()
rmGzsIn (String
darcsdir String -> String -> String
</> "inventories")
let checkpointDir :: String
checkpointDir = String
darcsdir String -> String -> String
</> "checkpoints"
Bool
hasCheckPoints <- String -> IO Bool
doesDirectoryExist String
checkpointDir
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasCheckPoints (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
rmRecursive String
checkpointDir
String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist (String
pendingName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".tentative")
String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist String
pendingName
where
rmGzsIn :: p -> IO ()
rmGzsIn dir :: p
dir =
p -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory p
dir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[String]
gzs <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ".gz") (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO [String]
getDirectoryContents "."
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
removeFile [String]
gzs
optimizeBucketed :: [DarcsFlag] -> IO ()
optimizeBucketed :: [DarcsFlag] -> IO ()
optimizeBucketed opts :: [DarcsFlag]
opts = do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Migrating global cache to bucketed format."
Maybe String
gCacheDir <- IO (Maybe String)
globalCacheDir
case Maybe String
gCacheDir of
Nothing -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "New global cache doesn't exist."
Just gCacheDir' :: String
gCacheDir' -> do
let gCachePristineDir :: String
gCachePristineDir = [String] -> String
joinPath [String
gCacheDir', String
pristineDir]
gCacheInventoriesDir :: String
gCacheInventoriesDir = [String] -> String
joinPath [String
gCacheDir', String
inventoriesDir]
gCachePatchesDir :: String
gCachePatchesDir = [String] -> String
joinPath [String
gCacheDir', String
patchesDir]
String -> IO ()
debugMessage "Making bucketed cache from new cache."
String -> String -> IO ()
toBucketed String
gCachePristineDir String
gCachePristineDir
String -> String -> IO ()
toBucketed String
gCacheInventoriesDir String
gCacheInventoriesDir
String -> String -> IO ()
toBucketed String
gCachePatchesDir String
gCachePatchesDir
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Done making bucketed cache!"
where
toBucketed :: FilePath -> FilePath -> IO ()
toBucketed :: String -> String -> IO ()
toBucketed src :: String
src dest :: String
dest = do
Bool
srcExist <- String -> IO Bool
doesDirectoryExist String
src
if Bool
srcExist
then do
String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Making " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ " bucketed in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dest
[String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
subDirSet ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \subDir :: String
subDir ->
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String
dest String -> String -> String
</> String
subDir)
[String]
fileNames <- String -> IO [String]
getDirectoryContents String
src
[String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
fileNames ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \file :: String
file -> do
Bool
exists <- String -> IO Bool
doesDirectoryReallyExist (String
src String -> String -> String
</> String
file)
if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
exists
then String -> String -> String -> IO ()
renameFile' String
src String
dest String
file
else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ " didn't exist, doing nothing."
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
renameFile' :: FilePath -> FilePath -> FilePath -> IO ()
renameFile' :: String -> String -> String -> IO ()
renameFile' s :: String
s d :: String
d f :: String
f = String -> String -> IO ()
renameFile (String
s String -> String -> String
</> String
f) ([String] -> String
joinPath [String
d, String -> String
bucketFolder String
f, String
f])
subDirSet :: [String]
subDirSet :: [String]
subDirSet = (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
toStrHex [0..255]
toStrHex :: Int -> String
toStrHex :: Int -> String
toStrHex = String -> Int -> String
forall r. PrintfType r => String -> r
printf "%02x"
optimizeGlobalCache :: DarcsCommand [DarcsFlag]
optimizeGlobalCache :: DarcsCommand [DarcsFlag]
optimizeGlobalCache = DarcsCommand [DarcsFlag]
common
{ commandName :: String
commandName = "cache"
, commandExtraArgs :: Int
commandExtraArgs = -1
, commandExtraArgHelp :: [String]
commandExtraArgHelp = [ "<DIRECTORY> ..." ]
, commandHelp :: String
commandHelp = String
optimizeHelpGlobalCache
, commandDescription :: String
commandDescription = "garbage collect global cache"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeGlobalCacheCmd
, commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = \_ -> Either String () -> IO (Either String ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ () -> Either String ()
forall a b. b -> Either a b
Right ()
}
optimizeHelpGlobalCache :: String
optimizeHelpGlobalCache :: String
optimizeHelpGlobalCache = [String] -> String
unlines
[ "This command deletes obsolete files within the global cache."
, "It takes one or more directories as arguments, and recursively"
, "searches all repositories within these directories. Then it deletes"
, "all files in the global cache not belonging to these repositories."
, "When no directory is given, it searches repositories in the user's"
, "home directory."
, ""
, "It also automatically migrates the global cache to the (default)"
, "bucketed format."
]
optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeGlobalCacheCmd _ opts :: [DarcsFlag]
opts args :: [String]
args = do
[DarcsFlag] -> IO ()
optimizeBucketed [DarcsFlag]
opts
String
home <- IO String
getHomeDirectory
let args' :: [String]
args' = if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args then [String
home] else [String]
args
[String] -> [DarcsFlag] -> IO ()
cleanGlobalCache [String]
args' [DarcsFlag]
opts
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Done cleaning global cache!"
cleanGlobalCache :: [String] -> [DarcsFlag] -> IO ()
cleanGlobalCache :: [String] -> [DarcsFlag] -> IO ()
cleanGlobalCache dirs :: [String]
dirs opts :: [DarcsFlag]
opts = do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "\nLooking for repositories in the following directories:"
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
dirs
Maybe String
gCacheDir' <- IO (Maybe String)
globalCacheDir
[[String]]
repoPaths' <- (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
findAllReposInDir [String]
dirs
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Finished listing repositories."
let repoPaths :: [String]
repoPaths = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
repoPaths'
gCache :: String
gCache = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
gCacheDir'
gCacheInvDir :: String
gCacheInvDir = String
gCache String -> String -> String
</> String
inventoriesDir
gCachePatchesDir :: String
gCachePatchesDir = String
gCache String -> String -> String
</> String
patchesDir
gCachePristineDir :: String
gCachePristineDir = String
gCache String -> String -> String
</> String
pristineDir
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
gCacheInvDir
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
gCachePatchesDir
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
gCachePristineDir
(String -> IO [String]) -> String -> [String] -> IO ()
forall (t :: * -> *) a.
Traversable t =>
(a -> IO [String]) -> String -> t a -> IO ()
remove String -> IO [String]
listInventoriesRepoDir String
gCacheInvDir [String]
repoPaths
(String -> IO [String]) -> String -> [String] -> IO ()
forall (t :: * -> *) a.
Traversable t =>
(a -> IO [String]) -> String -> t a -> IO ()
remove (String -> String -> IO [String]
listPatchesLocalBucketed String
gCache (String -> IO [String])
-> (String -> String) -> String -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
</> String
darcsdir)) String
gCachePatchesDir [String]
repoPaths
(String -> IO [String]) -> String -> [String] -> IO ()
forall (t :: * -> *) a.
Traversable t =>
(a -> IO [String]) -> String -> t a -> IO ()
remove String -> IO [String]
getPristine String
gCachePristineDir [String]
repoPaths
where
remove :: (a -> IO [String]) -> String -> t a -> IO ()
remove fGetFiles :: a -> IO [String]
fGetFiles cacheSubDir :: String
cacheSubDir repoPaths :: t a
repoPaths = do
t [String]
s1 <- (a -> IO [String]) -> t a -> IO (t [String])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> IO [String]
fGetFiles t a
repoPaths
[String]
s2 <- String -> IO [String]
getRecursiveContents String
cacheSubDir
String -> [String] -> [String] -> IO ()
remove' String
cacheSubDir [String]
s2 (t [String] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [String]
s1)
remove' :: String -> [String] -> [String] -> IO ()
remove' :: String -> [String] -> [String] -> IO ()
remove' dir :: String
dir s1 :: [String]
s1 s2 :: [String]
s2 =
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\hashedFile :: String
hashedFile ->
String
dir String -> String -> String
</> String -> String
bucketFolder String
hashedFile String -> String -> String
</> String
hashedFile))
([String] -> [String] -> [String]
diffHashLists [String]
s1 [String]
s2)
getPristine :: String -> IO [String]
getPristine :: String -> IO [String]
getPristine darcsDir :: String
darcsDir = do
ByteString
i <- String -> IO ByteString
gzReadFilePS (String
darcsDir String -> String -> String
</> String
darcsdir String -> String -> String
</> String
hashedInventory)
String -> [String] -> IO [String]
getHashedFiles (String
darcsDir String -> String -> String
</> String
darcsdir String -> String -> String
</> String
pristineDir) [ByteString -> String
peekPristineHash ByteString
i]