--  Copyright (C) 2003-2005 David Roundy
--
--  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 OverloadedStrings #-}

module Darcs.UI.Commands.Optimize ( optimize ) where

import Darcs.Prelude

import Control.Monad ( when, unless, forM_ )
import Data.List ( nub )
import Data.Maybe ( fromJust, isJust )
import System.Directory
    ( listDirectory
    , doesDirectoryExist
    , renameFile
    , createDirectoryIfMissing
    , removeFile
    , getHomeDirectory
    , removeDirectoryRecursive
    )
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.Traverse
    ( diffHashLists
    , listInventoriesRepoDir
    , listPatchesLocalBucketed
    , specialPatches
    )
import Darcs.Repository.Inventory ( peekPristineHash )
import Darcs.Repository.Paths
    ( formatPath
    , hashedInventoryPath
    , inventoriesDir
    , inventoriesDirPath
    , oldCheckpointDirPath
    , oldCurrentDirPath
    , oldInventoryPath
    , oldPristineDirPath
    , oldTentativeInventoryPath
    , patchesDir
    , patchesDirPath
    , pristineDir
    , pristineDirPath
    , tentativePristinePath
    )
import Darcs.Repository.Packs ( createPacks )
import Darcs.Repository.HashedIO ( getHashedFiles )
import Darcs.Repository.Inventory ( getValidHash )
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 ( Doc, formatWords, text, wrapText, ($+$) )
import Darcs.Util.Lock
    ( maybeRelink
    , gzWriteAtomicFilePS
    , writeAtomicFilePS
    , removeFileMayNotExist
    , writeBinFile
    )
import Darcs.Util.File
    ( withCurrentDirectory
    , getRecursiveContents
    , doesDirectoryReallyExist
    )
import Darcs.Util.Exception ( 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, useCache, umask )
import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck
                        , defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags
    ( UpdatePending (..), 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 Darcs.Repository.Hashed
    ( writeTentativeInventory
    , finalizeTentativeChanges
    )
import Darcs.Repository.Pristine
    ( ApplyDir(ApplyNormal)
    , applyToTentativePristineCwd
    )
import Darcs.Repository.State ( readRecorded )

import Darcs.Util.Tree
    ( Tree
    , TreeItem(..)
    , list
    , expand
    , emptyTree
    )
import Darcs.Util.Path( realPath, toFilePath, AbsolutePath )
import Darcs.Util.Tree.Plain( readPlainTree )
import Darcs.Util.Tree.Hashed
    ( writeDarcsHashed
    , decodeDarcsSize
    )

optimizeDescription :: String
optimizeDescription :: FilePath
optimizeDescription = FilePath
"Optimize the repository."

optimizeHelp :: Doc
optimizeHelp :: Doc
optimizeHelp = [FilePath] -> Doc
formatWords
  [ FilePath
"The `darcs optimize` command modifies internal data structures of"
  , FilePath
"the current repository in an attempt to reduce its resource requirements."
  ]
  Doc -> Doc -> Doc
$+$ Doc
"For further details see the descriptions of the subcommands."

optimize :: DarcsCommand
optimize :: DarcsCommand
optimize = SuperCommand {
      commandProgramName :: FilePath
commandProgramName = FilePath
"darcs"
    , commandName :: FilePath
commandName = FilePath
"optimize"
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelp
    , commandDescription :: FilePath
commandDescription = FilePath
optimizeDescription
    , commandPrereq :: [DarcsFlag] -> IO (Either FilePath ())
commandPrereq = [DarcsFlag] -> IO (Either FilePath ())
amInRepository
    , commandSubCommands :: [CommandControl]
commandSubCommands = [  DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeClean,
                              DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeHttp,
                              DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeReorder,
                              DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeEnablePatchIndex,
                              DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeDisablePatchIndex,
                              DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeCompress,
                              DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeUncompress,
                              DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeRelink,
                              DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizePristine,
                              DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeUpgrade,
                              DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeGlobalCache
                           ]
    }

commonBasicOpts :: DarcsOption a (Maybe String -> a)
commonBasicOpts :: forall a. DarcsOption a (Maybe FilePath -> a)
commonBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe FilePath)
forall a. DarcsOption a (Maybe FilePath -> a)
O.repoDir

commonAdvancedOpts :: DarcsOption a (UMask -> a)
commonAdvancedOpts :: forall a. DarcsOption a (UMask -> a)
commonAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
O.umask

common :: DarcsCommand
common :: DarcsCommand
common = DarcsCommand
    { commandProgramName :: FilePath
commandProgramName = FilePath
"darcs"
    , commandExtraArgs :: Int
commandExtraArgs = Int
0
    , commandExtraArgHelp :: [FilePath]
commandExtraArgHelp = []
    , commandPrereq :: [DarcsFlag] -> IO (Either FilePath ())
commandPrereq =  [DarcsFlag] -> IO (Either FilePath ())
amInHashedRepository
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [FilePath] -> IO [FilePath]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [FilePath] -> IO [FilePath]
nodefaults
    , commandName :: FilePath
commandName = FilePath
forall a. HasCallStack => a
undefined
    , commandHelp :: Doc
commandHelp = Doc
forall a. HasCallStack => a
undefined
    , commandDescription :: FilePath
commandDescription = FilePath
forall a. HasCallStack => a
undefined
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand =  (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
forall a. HasCallStack => a
undefined
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [FilePath] -> IO [FilePath]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [FilePath] -> IO [FilePath]
noArgs
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
forall a. DarcsOption a (UMask -> a)
commonAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec DarcsOptDescr DarcsFlag Any (Maybe FilePath -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (Maybe FilePath -> Any)
forall a. DarcsOption a (Maybe FilePath -> a)
commonBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe FilePath
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe FilePath
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
DarcsOption
  a
  (Maybe FilePath
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
commonOpts
    , commandCheckOptions :: [DarcsFlag] -> [FilePath]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe FilePath
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
-> [DarcsFlag] -> [FilePath]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [FilePath]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe FilePath
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall {a}.
DarcsOption
  a
  (Maybe FilePath
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
commonOpts
    }
  where
    commonOpts :: DarcsOption
  a
  (Maybe FilePath
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
commonOpts = DarcsOption
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe FilePath
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a. DarcsOption a (Maybe FilePath -> a)
commonBasicOpts DarcsOption
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe FilePath
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (Maybe FilePath
      -> Maybe StdCmdAction
      -> Verbosity
      -> UMask
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
forall a. DarcsOption a (UMask -> a)
commonAdvancedOpts


optimizeClean :: DarcsCommand
optimizeClean :: DarcsCommand
optimizeClean = DarcsCommand
common
    { commandName :: FilePath
commandName = FilePath
"clean"
    , commandDescription :: FilePath
commandDescription = FilePath
"garbage collect pristine, inventories and patches"
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelpClean
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeCleanCmd
    }

optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeCleanCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [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 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 -- garbage collect pristine.hashed, inventories and patches directories
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done cleaning repository!"

optimizeUpgrade :: DarcsCommand
optimizeUpgrade :: DarcsCommand
optimizeUpgrade = DarcsCommand
common
    { commandName :: FilePath
commandName = FilePath
"upgrade"
    , commandHelp :: Doc
commandHelp = Int -> FilePath -> Doc
wrapText Int
80
        FilePath
"Convert old-fashioned repositories to the current default hashed format."
    , commandDescription :: FilePath
commandDescription = FilePath
"upgrade repository to latest compatible format"
    , commandPrereq :: [DarcsFlag] -> IO (Either FilePath ())
commandPrereq = [DarcsFlag] -> IO (Either FilePath ())
amInRepository
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeUpgradeCmd
    }

optimizeHttp :: DarcsCommand
optimizeHttp :: DarcsCommand
optimizeHttp = DarcsCommand
common
    { commandName :: FilePath
commandName = FilePath
"http"
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelpHttp
    , commandDescription :: FilePath
commandDescription = FilePath
"optimize repository for getting over network"
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeHttpCmd
    }

optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeHttpCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [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 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 -- garbage collect pristine.hashed, inventories and patches directories
      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 Doc
"Done creating packs!"

optimizePristine :: DarcsCommand
optimizePristine :: DarcsCommand
optimizePristine = DarcsCommand
common
    { commandName :: FilePath
commandName = FilePath
"pristine"
    , commandHelp :: Doc
commandHelp = Int -> FilePath -> Doc
wrapText Int
80 (FilePath -> Doc) -> FilePath -> Doc
forall a b. (a -> b) -> a -> b
$
        FilePath
"This command updates the format of `"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
pristineDirPathFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
        FilePath
"`, which was different\nbefore darcs 2.3.1."
    , commandDescription :: FilePath
commandDescription = FilePath
"optimize hashed pristine layout"
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizePristineCmd
    }

optimizePristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizePristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizePristineCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [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 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 -- garbage collect pristine.hashed, inventories and patches directories
      [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 Doc
"Done optimizing pristine!"

optimizeCompress :: DarcsCommand
optimizeCompress :: DarcsCommand
optimizeCompress = DarcsCommand
common
    { commandName :: FilePath
commandName = FilePath
"compress"
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelpCompression
    , commandDescription :: FilePath
commandDescription = FilePath
"compress patches and inventories"
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeCompressCmd
    }

optimizeUncompress :: DarcsCommand
optimizeUncompress :: DarcsCommand
optimizeUncompress = DarcsCommand
common
    { commandName :: FilePath
commandName = FilePath
"uncompress"
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelpCompression
    , commandDescription :: FilePath
commandDescription = FilePath
"uncompress patches and inventories"
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeUncompressCmd
    }

optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeCompressCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [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 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 -- garbage collect pristine.hashed, inventories and patches directories
      Compression -> [DarcsFlag] -> IO ()
optimizeCompression Compression
O.GzipCompression [DarcsFlag]
opts
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done optimizing by compression!"

optimizeUncompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUncompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeUncompressCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [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 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 -- garbage collect pristine.hashed, inventories and patches directories
      Compression -> [DarcsFlag] -> IO ()
optimizeCompression Compression
O.NoCompression [DarcsFlag]
opts
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done optimizing by uncompression!"

optimizeCompression :: O.Compression -> [DarcsFlag] -> IO ()
optimizeCompression :: Compression -> [DarcsFlag] -> IO ()
optimizeCompression Compression
compression [DarcsFlag]
opts = do
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Optimizing (un)compression of patches..."
    FilePath -> IO ()
do_compress FilePath
patchesDirPath
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Optimizing (un)compression of inventories..."
    FilePath -> IO ()
do_compress FilePath
inventoriesDirPath
    where
      do_compress :: FilePath -> IO ()
do_compress FilePath
f = do
        Bool
isd <- FilePath -> IO Bool
doesDirectoryExist FilePath
f
        if Bool
isd
          then FilePath -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory FilePath
f (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                 [FilePath]
fs <- (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FilePath]
specialPatches) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectory FilePath
"."
                 (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
do_compress [FilePath]
fs
          else FilePath -> IO ByteString
gzReadFilePS FilePath
f IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
               case Compression
compression of
                 Compression
O.GzipCompression -> FilePath -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
gzWriteAtomicFilePS FilePath
f
                 Compression
O.NoCompression -> FilePath -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS FilePath
f

optimizeEnablePatchIndex :: DarcsCommand
optimizeEnablePatchIndex :: DarcsCommand
optimizeEnablePatchIndex = DarcsCommand
common
    { commandName :: FilePath
commandName = FilePath
"enable-patch-index"
    , commandHelp :: Doc
commandHelp = [FilePath] -> Doc
formatWords
        [ FilePath
"Build the patch index, an internal data structure that accelerates"
        , FilePath
"commands that need to know what patches touch a given file. Such as"
        , FilePath
"annotate and log."
        ]
    , commandDescription :: FilePath
commandDescription = FilePath
"Enable patch index"
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeEnablePatchIndexCmd
    }

optimizeDisablePatchIndex :: DarcsCommand
optimizeDisablePatchIndex :: DarcsCommand
optimizeDisablePatchIndex = DarcsCommand
common
    { commandName :: FilePath
commandName = FilePath
"disable-patch-index"
    , commandHelp :: Doc
commandHelp = Int -> FilePath -> Doc
wrapText Int
80
        FilePath
"Delete and stop maintaining the patch index from the repository."
    , commandDescription :: FilePath
commandDescription = FilePath
"Disable patch index"
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeDisablePatchIndexCmd
    }

optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeEnablePatchIndexCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [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 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 Doc
"Done enabling patch index!"

optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeDisablePatchIndexCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [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 rt p wR wU wR
repo -> do
      FilePath -> IO ()
deletePatchIndex (Repository rt p wR wU wR -> FilePath
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> FilePath
repoLocation Repository rt p wR wU wR
repo)
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done disabling patch index!"

optimizeReorder :: DarcsCommand
optimizeReorder :: DarcsCommand
optimizeReorder = DarcsCommand
common
    { commandName :: FilePath
commandName = FilePath
"reorder"
    , commandHelp :: Doc
commandHelp = [FilePath] -> Doc
formatWords
        [ FilePath
"This command moves recent patches (those not included in"
        , FilePath
"the latest tag) to the \"front\", reducing the amount that a typical"
        , FilePath
"remote command needs to download.  It should also reduce the CPU time"
        , FilePath
"needed for some operations."
        ]
    , commandDescription :: FilePath
commandDescription = FilePath
"reorder the patches in the repository"
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeReorderCmd
    }

optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeReorderCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [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 rt p wR wU wR
repository -> do
      Repository rt p wR wU wR -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> Compression -> IO ()
reorderInventory Repository rt p wR wU wR
repository (PrimOptSpec DarcsOptDescr DarcsFlag a Compression
PrimDarcsOption Compression
O.compress PrimDarcsOption Compression -> [DarcsFlag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done reordering!"

optimizeRelink :: DarcsCommand
optimizeRelink :: DarcsCommand
optimizeRelink = DarcsCommand
common
    { commandName :: FilePath
commandName = FilePath
"relink"
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelpRelink 
    , commandDescription :: FilePath
commandDescription = FilePath
"relink random internal data to a sibling"
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeRelinkCmd
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
forall a. DarcsOption a (UMask -> a)
commonAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe FilePath -> [AbsolutePath] -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe FilePath -> [AbsolutePath] -> Any)
forall {a}.
OptSpec
  DarcsOptDescr DarcsFlag a (Maybe FilePath -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe FilePath
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe FilePath
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
DarcsOption
  a
  (Maybe FilePath
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
optimizeRelinkOpts
    , commandCheckOptions :: [DarcsFlag] -> [FilePath]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe FilePath
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
-> [DarcsFlag] -> [FilePath]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [FilePath]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe FilePath
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall {a}.
DarcsOption
  a
  (Maybe FilePath
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
optimizeRelinkOpts
    }
  where
    optimizeRelinkBasicOpts :: OptSpec
  DarcsOptDescr DarcsFlag a (Maybe FilePath -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts = DarcsOption
  ([AbsolutePath] -> a) (Maybe FilePath -> [AbsolutePath] -> a)
forall a. DarcsOption a (Maybe FilePath -> a)
commonBasicOpts DarcsOption
  ([AbsolutePath] -> a) (Maybe FilePath -> [AbsolutePath] -> a)
-> OptSpec DarcsOptDescr DarcsFlag a ([AbsolutePath] -> a)
-> OptSpec
     DarcsOptDescr DarcsFlag a (Maybe FilePath -> [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 FilePath
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
optimizeRelinkOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe FilePath
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall {a}.
OptSpec
  DarcsOptDescr DarcsFlag a (Maybe FilePath -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe FilePath
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (Maybe FilePath
      -> [AbsolutePath]
      -> Maybe StdCmdAction
      -> Verbosity
      -> UMask
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
forall a. DarcsOption a (UMask -> a)
commonAdvancedOpts

optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeRelinkCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [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 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 -- garbage collect pristine.hashed, inventories and patches directories
      [DarcsFlag] -> IO ()
doRelink [DarcsFlag]
opts
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done relinking!"

optimizeHelpHttp :: Doc
optimizeHelpHttp :: Doc
optimizeHelpHttp = [FilePath] -> Doc
formatWords
  [ FilePath
"Using this option creates 'repository packs' that can dramatically"
  , FilePath
"speed up performance when a user does a `darcs clone` of the repository"
  , FilePath
"over HTTP. To make use of packs, the clients must have a darcs of at"
  , FilePath
"least version 2.10."
  ]

optimizeHelpClean :: Doc
optimizeHelpClean :: Doc
optimizeHelpClean = [FilePath] -> Doc
formatWords
  [ FilePath
"Darcs normally does not delete hashed files that are no longer"
  , FilePath
"referenced by the current repository state. This command can be"
  , FilePath
"use to get rid of these files to save some disk space."
  ]

optimizeHelpCompression :: Doc
optimizeHelpCompression :: Doc
optimizeHelpCompression =
  [FilePath] -> Doc
formatWords
  [ FilePath
"By default patches are compressed with zlib (RFC 1951) to reduce"
  , FilePath
"storage (and download) size.  In exceptional circumstances, it may be"
  , FilePath
"preferable to avoid compression.  In this case the `--dont-compress`"
  , FilePath
"option can be used (e.g. with `darcs record`) to avoid compression."
  ]
  Doc -> Doc -> Doc
$+$ [FilePath] -> Doc
formatWords
  [ FilePath
"The `darcs optimize uncompress` and `darcs optimize compress`"
  , FilePath
"commands can be used to ensure existing patches in the current"
  , FilePath
"repository are respectively uncompressed or compressed."
  ]

optimizeHelpRelink :: Doc
optimizeHelpRelink :: Doc
optimizeHelpRelink = 
  [FilePath] -> Doc
formatWords
  [ FilePath
"The `darcs optimize relink` command hard-links patches that the"
  , FilePath
"current repository has in common with its peers.  Peers are those"
  , FilePath
"repositories listed in `_darcs/prefs/sources`, or defined with the"
  , FilePath
"`--sibling` option (which can be used multiple times)."
  ]
  Doc -> Doc -> Doc
$+$ [FilePath] -> Doc
formatWords
  [ FilePath
"Darcs uses hard-links automatically, so this command is rarely needed."
  , FilePath
"It is most useful if you used `cp -r` instead of `darcs clone` to copy a"
  , FilePath
"repository, or if you pulled the same patch from a remote repository"
  , FilePath
"into multiple local repositories."
  ]

doOptimizePristine :: [DarcsFlag] -> Repository rt p wR wU wT -> IO ()
doOptimizePristine :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
[DarcsFlag] -> Repository rt p wR wU wT -> IO ()
doOptimizePristine [DarcsFlag]
opts Repository rt p wR wU wT
repo = do
    ByteString
inv <- FilePath -> IO ByteString
BC.readFile FilePath
hashedInventoryPath
    let linesInv :: [ByteString]
linesInv = Char -> ByteString -> [ByteString]
BC.split Char
'\n' ByteString
inv
    case [ByteString]
linesInv of
      [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (ByteString
pris_line:[ByteString]
_) ->
          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 Int
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 Doc
"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 a b. IO a -> (a -> IO b) -> IO b
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 [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 PrimOptSpec DarcsOptDescr DarcsFlag a [AbsolutePath]
PrimDarcsOption [AbsolutePath]
O.siblings [DarcsFlag]
opts
       [FilePath]
defrepolist <- FilePath -> IO [FilePath]
getPreflist FilePath
"defaultrepo"
       let siblings :: [FilePath]
siblings = (AbsolutePath -> FilePath) -> [AbsolutePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map AbsolutePath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath [AbsolutePath]
some_siblings [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
defrepolist
       if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
siblings
          then [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"No siblings -- no relinking done."
          else do FilePath -> IO ()
debugMessage FilePath
"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
=<< FilePath -> IO (Tree IO)
readPlainTree FilePath
patchesDirPath
                  let patches :: [FilePath]
patches = [ AnchoredPath -> FilePath
realPath AnchoredPath
p | (AnchoredPath
p, File Blob IO
_) <- Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
patch_tree ]
                  [FilePath] -> [FilePath] -> FilePath -> IO ()
maybeRelinkFiles [FilePath]
siblings [FilePath]
patches FilePath
patchesDirPath
                  FilePath -> IO ()
debugMessage FilePath
"Done relinking."

maybeRelinkFiles :: [String] -> [String] -> String -> IO ()
maybeRelinkFiles :: [FilePath] -> [FilePath] -> FilePath -> IO ()
maybeRelinkFiles [FilePath]
src [FilePath]
dst FilePath
dir =
    (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([FilePath] -> FilePath -> IO ()
maybeRelinkFile [FilePath]
src (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath
dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)) [FilePath]
dst

maybeRelinkFile :: [String] -> String -> IO ()
maybeRelinkFile :: [FilePath] -> FilePath -> IO ()
maybeRelinkFile [] FilePath
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeRelinkFile (FilePath
h:[FilePath]
t) FilePath
f =
    do Bool
done <- FilePath -> FilePath -> IO Bool
maybeRelink (FilePath
h FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f) FilePath
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
$
           [FilePath] -> FilePath -> IO ()
maybeRelinkFile [FilePath]
t FilePath
f

-- Only 'optimize' commands that works on old-fashionned repositories
optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeUpgradeCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ = do
  RepoFormat
rf <- FilePath -> IO RepoFormat
identifyRepoFormat FilePath
"."
  FilePath -> IO ()
debugMessage FilePath
"Found our format"
  if RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rf
     then [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"No action taken because this repository already is hashed."
     else do [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"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 Repository rt p wR wU wR -> IO ()
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 :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO ()
actuallyUpgradeFormat Repository rt p wR wU wT
repository = do
  -- convert patches/inventory
  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 :: FilePath
k = FilePath
"Hashing patch"
  FilePath -> IO ()
beginTedious FilePath
k
  FilePath -> Int -> IO ()
tediousSize FilePath
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' = FilePath -> PatchSet rt p Origin wR -> PatchSet rt p Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
FilePath -> PatchSet rt p wStart wX -> PatchSet rt p wStart wX
progressPatchSet FilePath
k PatchSet rt p Origin wR
patches
  -- darcs optimize subcommands do not support
  -- the --no-cache option, so use default
  Cache
cache <- UseCache -> FilePath -> IO Cache
getCaches UseCache
YesUseCache FilePath
"."
  let compressDefault :: Compression
compressDefault = PrimOptSpec DarcsOptDescr DarcsFlag a Compression
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 ()
writeTentativeInventory Cache
cache Compression
compressDefault PatchSet rt p Origin wR
patches'
  FilePath -> IO ()
endTedious FilePath
k
  -- convert pristine by applying patches
  -- the faster alternative would be to copy pristine, but the apply method
  -- is more reliable
  -- TODO we should do both and then comapre them
  let patchesToApply :: FL (PatchInfoAnd rt p) Origin wR
patchesToApply = FilePath
-> FL (PatchInfoAnd rt p) Origin wR
-> FL (PatchInfoAnd rt p) Origin wR
forall (a :: * -> * -> *) wX wY.
FilePath -> FL a wX wY -> FL a wX wY
progressFL FilePath
"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 -> FilePath -> IO ()
createDirectoryIfMissing Bool
False (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
darcsdir FilePath -> FilePath -> FilePath
</> HashedDir -> FilePath
hashedDir HashedDir
HashedPristineDir
  -- We ignore the returned root hash, we don't use it.
  Hash
_ <- Tree IO -> FilePath -> IO Hash
writeDarcsHashed Tree IO
forall (m :: * -> *). Tree m
emptyTree (FilePath -> IO Hash) -> FilePath -> IO Hash
forall a b. (a -> b) -> a -> b
$ FilePath
darcsdir FilePath -> FilePath -> FilePath
</> HashedDir -> FilePath
hashedDir HashedDir
HashedPristineDir
  FilePath -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeBinFile FilePath
tentativePristinePath ByteString
""
  [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 (ApplyDir -> FL (PatchInfoAnd rt p) wW wZ -> IO ()
forall (p :: * -> * -> *) wX wY.
(ApplyState p ~ Tree, Apply p) =>
ApplyDir -> p wX wY -> IO ()
applyToTentativePristineCwd ApplyDir
ApplyNormal) (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 Int
100 FL (PatchInfoAnd rt p) Origin wR
patchesToApply
  -- now make it official
  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 ()
finalizeTentativeChanges Repository rt p wR wU wT
repository Compression
compressDefault
  RepoFormat -> FilePath -> IO ()
writeRepoFormat (PatchFormat -> WithWorkingDir -> RepoFormat
createRepoFormat PatchFormat
PatchFormat1 WithWorkingDir
WithWorkingDir) FilePath
formatPath
  -- clean out old-fashioned junk
  FilePath -> IO ()
debugMessage FilePath
"Cleaning out old-fashioned repository files..."
  FilePath -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist FilePath
oldInventoryPath
  FilePath -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist FilePath
oldTentativeInventoryPath
  FilePath -> IO ()
removeDirectoryRecursive FilePath
oldPristineDirPath
    IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` FilePath -> IO ()
removeDirectoryRecursive FilePath
oldCurrentDirPath
  FilePath -> IO ()
forall p. FilePathLike p => p -> IO ()
rmGzsIn FilePath
patchesDirPath
  FilePath -> IO ()
forall p. FilePathLike p => p -> IO ()
rmGzsIn FilePath
inventoriesDirPath
  Bool
hasCheckPoints <- FilePath -> IO Bool
doesDirectoryExist FilePath
oldCheckpointDirPath
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasCheckPoints (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryRecursive FilePath
oldCheckpointDirPath
 where
  rmGzsIn :: p -> IO ()
rmGzsIn 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
      [FilePath]
gzs <- (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".gz") (FilePath -> Bool) -> (FilePath -> FilePath) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeExtension) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO [FilePath]
listDirectory FilePath
"."
      (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
removeFile [FilePath]
gzs

optimizeBucketed :: [DarcsFlag] -> IO ()
optimizeBucketed :: [DarcsFlag] -> IO ()
optimizeBucketed [DarcsFlag]
opts = do
  [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Migrating global cache to bucketed format."
  Maybe FilePath
gCacheDir <- IO (Maybe FilePath)
globalCacheDir

  case Maybe FilePath
gCacheDir of
    Maybe FilePath
Nothing -> FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"New global cache doesn't exist."
    Just FilePath
gCacheDir' -> do
      let gCachePristineDir :: FilePath
gCachePristineDir = [FilePath] -> FilePath
joinPath [FilePath
gCacheDir', FilePath
pristineDir]
          gCacheInventoriesDir :: FilePath
gCacheInventoriesDir = [FilePath] -> FilePath
joinPath [FilePath
gCacheDir', FilePath
inventoriesDir]
          gCachePatchesDir :: FilePath
gCachePatchesDir = [FilePath] -> FilePath
joinPath [FilePath
gCacheDir', FilePath
patchesDir]
      FilePath -> IO ()
debugMessage FilePath
"Making bucketed cache from new cache."
      FilePath -> FilePath -> IO ()
toBucketed FilePath
gCachePristineDir FilePath
gCachePristineDir
      FilePath -> FilePath -> IO ()
toBucketed FilePath
gCacheInventoriesDir FilePath
gCacheInventoriesDir
      FilePath -> FilePath -> IO ()
toBucketed FilePath
gCachePatchesDir FilePath
gCachePatchesDir
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done making bucketed cache!"
  where
    toBucketed :: FilePath -> FilePath -> IO ()
    toBucketed :: FilePath -> FilePath -> IO ()
toBucketed FilePath
src FilePath
dest = do
      Bool
srcExist <- FilePath -> IO Bool
doesDirectoryExist FilePath
src
      if Bool
srcExist
        then  do
                FilePath -> IO ()
debugMessage (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Making " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
src FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" bucketed in " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dest
                [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
subDirSet ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
subDir ->
                  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath
dest FilePath -> FilePath -> FilePath
</> FilePath
subDir)
                [FilePath]
fileNames <- FilePath -> IO [FilePath]
listDirectory FilePath
src
                [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
fileNames ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
                  Bool
exists <- FilePath -> IO Bool
doesDirectoryReallyExist (FilePath
src FilePath -> FilePath -> FilePath
</> FilePath
file)
                  if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
exists
                    then FilePath -> FilePath -> FilePath -> IO ()
renameFile' FilePath
src FilePath
dest FilePath
file
                    else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
          FilePath -> IO ()
debugMessage (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
src FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" didn't exist, doing nothing."
          () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    renameFile' :: FilePath -> FilePath -> FilePath -> IO ()
    renameFile' :: FilePath -> FilePath -> FilePath -> IO ()
renameFile' FilePath
s FilePath
d FilePath
f = FilePath -> FilePath -> IO ()
renameFile (FilePath
s FilePath -> FilePath -> FilePath
</> FilePath
f) ([FilePath] -> FilePath
joinPath [FilePath
d, FilePath -> FilePath
bucketFolder FilePath
f, FilePath
f])

    subDirSet :: [String]
    subDirSet :: [FilePath]
subDirSet = (Int -> FilePath) -> [Int] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Int -> FilePath
toStrHex [Int
0..Int
255]

    toStrHex :: Int -> String
    toStrHex :: Int -> FilePath
toStrHex = FilePath -> Int -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%02x"


optimizeGlobalCache :: DarcsCommand
optimizeGlobalCache :: DarcsCommand
optimizeGlobalCache = DarcsCommand
common
    { commandName :: FilePath
commandName = FilePath
"cache"
    , commandExtraArgs :: Int
commandExtraArgs            = -Int
1
    , commandExtraArgHelp :: [FilePath]
commandExtraArgHelp         = [ FilePath
"<DIRECTORY> ..." ]
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelpGlobalCache
    , commandDescription :: FilePath
commandDescription = FilePath
"garbage collect global cache"
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeGlobalCacheCmd
    , commandPrereq :: [DarcsFlag] -> IO (Either FilePath ())
commandPrereq = \[DarcsFlag]
_ -> Either FilePath () -> IO (Either FilePath ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath () -> IO (Either FilePath ()))
-> Either FilePath () -> IO (Either FilePath ())
forall a b. (a -> b) -> a -> b
$ () -> Either FilePath ()
forall a b. b -> Either a b
Right ()
    }

optimizeHelpGlobalCache :: Doc
optimizeHelpGlobalCache :: Doc
optimizeHelpGlobalCache = [FilePath] -> Doc
formatWords
  [ FilePath
"This command deletes obsolete files within the global cache."
  , FilePath
"It takes one or more directories as arguments, and recursively"
  , FilePath
"searches all repositories within these directories. Then it deletes"
  , FilePath
"all files in the global cache not belonging to these repositories."
  , FilePath
"When no directory is given, it searches repositories in the user's"
  , FilePath
"home directory."
  ]
  Doc -> Doc -> Doc
$+$ [FilePath] -> Doc
formatWords
  [ FilePath
"It also automatically migrates the global cache to the (default)"
  , FilePath
"bucketed format."
  ]

optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeGlobalCacheCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
args = do
  [DarcsFlag] -> IO ()
optimizeBucketed [DarcsFlag]
opts
  FilePath
home <- IO FilePath
getHomeDirectory
  let args' :: [FilePath]
args' = if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
args then [FilePath
home] else [FilePath]
args
  [FilePath] -> [DarcsFlag] -> IO ()
cleanGlobalCache [FilePath]
args' [DarcsFlag]
opts
  [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done cleaning global cache!"

cleanGlobalCache :: [String] -> [DarcsFlag] -> IO ()
cleanGlobalCache :: [FilePath] -> [DarcsFlag] -> IO ()
cleanGlobalCache [FilePath]
dirs [DarcsFlag]
opts = do
  [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"\nLooking for repositories in the following directories:"
  [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc
text (FilePath -> Doc) -> FilePath -> Doc
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [FilePath]
dirs
  Maybe FilePath
gCacheDir' <- IO (Maybe FilePath)
globalCacheDir
  [[FilePath]]
repoPaths'  <- (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM FilePath -> IO [FilePath]
findAllReposInDir [FilePath]
dirs

  [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Finished listing repositories."

  let repoPaths :: [FilePath]
repoPaths         = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath]]
repoPaths'
      gCache :: FilePath
gCache            = Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
fromJust Maybe FilePath
gCacheDir'
      gCacheInvDir :: FilePath
gCacheInvDir      = FilePath
gCache FilePath -> FilePath -> FilePath
</> FilePath
inventoriesDir
      gCachePatchesDir :: FilePath
gCachePatchesDir  = FilePath
gCache FilePath -> FilePath -> FilePath
</> FilePath
patchesDir
      gCachePristineDir :: FilePath
gCachePristineDir = FilePath
gCache FilePath -> FilePath -> FilePath
</> FilePath
pristineDir

  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
gCacheInvDir
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
gCachePatchesDir
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
gCachePristineDir

  (FilePath -> IO [FilePath]) -> FilePath -> [FilePath] -> IO ()
forall {t :: * -> *} {a}.
Traversable t =>
(a -> IO [FilePath]) -> FilePath -> t a -> IO ()
remove FilePath -> IO [FilePath]
listInventoriesRepoDir FilePath
gCacheInvDir [FilePath]
repoPaths
  (FilePath -> IO [FilePath]) -> FilePath -> [FilePath] -> IO ()
forall {t :: * -> *} {a}.
Traversable t =>
(a -> IO [FilePath]) -> FilePath -> t a -> IO ()
remove (FilePath -> FilePath -> IO [FilePath]
listPatchesLocalBucketed FilePath
gCache (FilePath -> IO [FilePath])
-> (FilePath -> FilePath) -> FilePath -> IO [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath
</> FilePath
darcsdir)) FilePath
gCachePatchesDir [FilePath]
repoPaths
  (FilePath -> IO [FilePath]) -> FilePath -> [FilePath] -> IO ()
forall {t :: * -> *} {a}.
Traversable t =>
(a -> IO [FilePath]) -> FilePath -> t a -> IO ()
remove FilePath -> IO [FilePath]
getPristine FilePath
gCachePristineDir [FilePath]
repoPaths

  where
  remove :: (a -> IO [FilePath]) -> FilePath -> t a -> IO ()
remove a -> IO [FilePath]
fGetFiles FilePath
cacheSubDir t a
repoPaths = do
    t [FilePath]
s1 <- (a -> IO [FilePath]) -> t a -> IO (t [FilePath])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM a -> IO [FilePath]
fGetFiles t a
repoPaths
    [FilePath]
s2 <- FilePath -> IO [FilePath]
getRecursiveContents FilePath
cacheSubDir
    FilePath -> [FilePath] -> [FilePath] -> IO ()
remove' FilePath
cacheSubDir [FilePath]
s2 (t [FilePath] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [FilePath]
s1)

  remove' :: String -> [String] -> [String] -> IO ()
  remove' :: FilePath -> [FilePath] -> [FilePath] -> IO ()
remove' FilePath
dir [FilePath]
s1 [FilePath]
s2 =
    (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\FilePath
hashedFile ->
      FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
bucketFolder FilePath
hashedFile FilePath -> FilePath -> FilePath
</> FilePath
hashedFile))
      ([FilePath] -> [FilePath] -> [FilePath]
diffHashLists [FilePath]
s1 [FilePath]
s2)

  getPristine :: String -> IO [String]
  getPristine :: FilePath -> IO [FilePath]
getPristine FilePath
repoDir = do
    ByteString
i <- FilePath -> IO ByteString
gzReadFilePS (FilePath
repoDir FilePath -> FilePath -> FilePath
</> FilePath
hashedInventoryPath)
    FilePath -> [FilePath] -> IO [FilePath]
getHashedFiles (FilePath
repoDir FilePath -> FilePath -> FilePath
</> FilePath
pristineDirPath) [PristineHash -> FilePath
forall a. ValidHash a => a -> FilePath
getValidHash (PristineHash -> FilePath) -> PristineHash -> FilePath
forall a b. (a -> b) -> a -> b
$ ByteString -> PristineHash
peekPristineHash ByteString
i]