--  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 :: String
optimizeDescription = String
"Optimize the repository."

optimizeHelp :: Doc
optimizeHelp :: Doc
optimizeHelp = [String] -> Doc
formatWords
  [ String
"The `darcs optimize` command modifies internal data structures of"
  , String
"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 :: String
-> String
-> Doc
-> String
-> ([DarcsFlag] -> IO (Either String ()))
-> [CommandControl]
-> DarcsCommand
SuperCommand {
      commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"optimize"
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelp
    , commandDescription :: String
commandDescription = String
optimizeDescription
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
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 :: DarcsOption a (Maybe String -> a)
commonBasicOpts = DarcsOption a (Maybe String -> a)
PrimDarcsOption (Maybe String)
O.repoDir

commonAdvancedOpts :: DarcsOption a (UMask -> a)
commonAdvancedOpts :: DarcsOption a (UMask -> a)
commonAdvancedOpts = DarcsOption a (UMask -> a)
PrimDarcsOption UMask
O.umask

common :: DarcsCommand
common :: DarcsCommand
common = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> DarcsCommand
DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandExtraArgs :: Int
commandExtraArgs = Int
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 :: Doc
commandHelp = Doc
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 (UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
PrimDarcsOption UMask
commonAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec DarcsOptDescr DarcsFlag Any (Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (Maybe String -> Any)
PrimDarcsOption (Maybe String)
commonBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> 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 String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
commonOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
commonOpts
    }
  where
    commonOpts :: DarcsOption
  a
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
commonOpts = DarcsOption
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
PrimDarcsOption (Maybe String)
commonBasicOpts DarcsOption
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> 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 String
      -> 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)
PrimDarcsOption UMask
commonAdvancedOpts


optimizeClean :: DarcsCommand
optimizeClean :: DarcsCommand
optimizeClean = DarcsCommand
common
    { commandName :: String
commandName = String
"clean"
    , commandDescription :: String
commandDescription = String
"garbage collect pristine, inventories and patches"
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelpClean
    , 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 (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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) UpdatePending
YesUpdatePending (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 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 :: String
commandName = String
"upgrade"
    , commandHelp :: Doc
commandHelp = Int -> String -> Doc
wrapText Int
80
        String
"Convert old-fashioned repositories to the current default hashed format."
    , commandDescription :: String
commandDescription = String
"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
optimizeHttp :: DarcsCommand
optimizeHttp = DarcsCommand
common
    { commandName :: String
commandName = String
"http"
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelpHttp
    , commandDescription :: String
commandDescription = String
"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 (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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) UpdatePending
YesUpdatePending (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 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 :: String
commandName = String
"pristine"
    , commandHelp :: Doc
commandHelp = Int -> String -> Doc
wrapText Int
80 (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
        String
"This command updates the format of `"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
pristineDirPathString -> String -> String
forall a. [a] -> [a] -> [a]
++
        String
"`, which was different\nbefore darcs 2.3.1."
    , commandDescription :: String
commandDescription = String
"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 (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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) UpdatePending
YesUpdatePending (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 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 :: String
commandName = String
"compress"
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelpCompression
    , commandDescription :: String
commandDescription = String
"compress patches and inventories"
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCompressCmd
    }

optimizeUncompress :: DarcsCommand
optimizeUncompress :: DarcsCommand
optimizeUncompress = DarcsCommand
common
    { commandName :: String
commandName = String
"uncompress"
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelpCompression
    , commandDescription :: String
commandDescription = String
"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 (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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) UpdatePending
YesUpdatePending (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 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] -> [String] -> IO ()
optimizeUncompressCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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) UpdatePending
YesUpdatePending (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 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..."
    String -> IO ()
do_compress String
patchesDirPath
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Optimizing (un)compression of inventories..."
    String -> IO ()
do_compress String
inventoriesDirPath
    where
      do_compress :: String -> IO ()
do_compress 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 -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
specialPatches) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
"."
                 (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
                 Compression
O.GzipCompression -> String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
gzWriteAtomicFilePS String
f
                 Compression
O.NoCompression -> String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS String
f

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

optimizeDisablePatchIndex :: DarcsCommand
optimizeDisablePatchIndex :: DarcsCommand
optimizeDisablePatchIndex = DarcsCommand
common
    { commandName :: String
commandName = String
"disable-patch-index"
    , commandHelp :: Doc
commandHelp = Int -> String -> Doc
wrapText Int
80
        String
"Delete and stop maintaining the patch index from the repository."
    , commandDescription :: String
commandDescription = String
"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 (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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) UpdatePending
YesUpdatePending (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 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] -> [String] -> IO ()
optimizeDisablePatchIndexCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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) UpdatePending
YesUpdatePending (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 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 Doc
"Done disabling patch index!"

optimizeReorder :: DarcsCommand
optimizeReorder :: DarcsCommand
optimizeReorder = DarcsCommand
common
    { commandName :: String
commandName = String
"reorder"
    , commandHelp :: Doc
commandHelp = [String] -> Doc
formatWords
        [ String
"This command moves recent patches (those not included in"
        , String
"the latest tag) to the \"front\", reducing the amount that a typical"
        , String
"remote command needs to download.  It should also reduce the CPU time"
        , String
"needed for some operations."
        ]
    , commandDescription :: String
commandDescription = String
"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 (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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) UpdatePending
YesUpdatePending (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 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 (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 :: String
commandName = String
"relink"
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelpRelink 
    , commandDescription :: String
commandDescription = String
"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 (UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
PrimDarcsOption UMask
commonAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr DarcsFlag Any (Maybe String -> [AbsolutePath] -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr DarcsFlag Any (Maybe String -> [AbsolutePath] -> Any)
forall a.
OptSpec
  DarcsOptDescr DarcsFlag a (Maybe String -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> [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 String
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
optimizeRelinkOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
optimizeRelinkOpts
    }
  where
    optimizeRelinkBasicOpts :: OptSpec
  DarcsOptDescr DarcsFlag a (Maybe String -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts = DarcsOption
  ([AbsolutePath] -> a) (Maybe String -> [AbsolutePath] -> a)
PrimDarcsOption (Maybe String)
commonBasicOpts DarcsOption
  ([AbsolutePath] -> a) (Maybe String -> [AbsolutePath] -> a)
-> OptSpec DarcsOptDescr DarcsFlag a ([AbsolutePath] -> a)
-> OptSpec
     DarcsOptDescr DarcsFlag a (Maybe String -> [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
   -> [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 String
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr DarcsFlag a (Maybe String -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> [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 String
      -> [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)
PrimDarcsOption UMask
commonAdvancedOpts

optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeRelinkCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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) UpdatePending
YesUpdatePending (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 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 = [String] -> Doc
formatWords
  [ String
"Using this option creates 'repository packs' that can dramatically"
  , String
"speed up performance when a user does a `darcs clone` of the repository"
  , String
"over HTTP. To make use of packs, the clients must have a darcs of at"
  , String
"least version 2.10."
  ]

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

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

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

doOptimizePristine :: [DarcsFlag] -> Repository rt p wR wU wT -> IO ()
doOptimizePristine :: [DarcsFlag] -> Repository rt p wR wU wT -> IO ()
doOptimizePristine [DarcsFlag]
opts Repository rt p wR wU wT
repo = do
    ByteString
inv <- String -> IO ByteString
BC.readFile String
hashedInventoryPath
    let linesInv :: [ByteString]
linesInv = Char -> ByteString -> [ByteString]
BC.split Char
'\n' ByteString
inv
    case [ByteString]
linesInv of
      [] -> () -> IO ()
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 (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 PrimDarcsOption [AbsolutePath]
O.siblings [DarcsFlag]
opts
       [String]
defrepolist <- String -> IO [String]
getPreflist String
"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 Doc
"No siblings -- no relinking done."
          else do String -> IO ()
debugMessage String
"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
patchesDirPath
                  let patches :: [String]
patches = [ AnchoredPath -> String
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 ]
                  [String] -> [String] -> String -> IO ()
maybeRelinkFiles [String]
siblings [String]
patches String
patchesDirPath
                  String -> IO ()
debugMessage String
"Done relinking."

maybeRelinkFiles :: [String] -> [String] -> String -> IO ()
maybeRelinkFiles :: [String] -> [String] -> String -> IO ()
maybeRelinkFiles [String]
src [String]
dst 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 -> String
forall a. [a] -> [a] -> [a]
++)) [String]
dst

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

-- Only 'optimize' commands that works on old-fashionned repositories
optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUpgradeCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ = do
  RepoFormat
rf <- String -> IO RepoFormat
identifyRepoFormat String
"."
  String -> IO ()
debugMessage String
"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 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 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 :: String
k = String
"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
  -- darcs optimize subcommands do not support
  -- the --no-cache option, so use default
  Cache
cache <- UseCache -> String -> IO Cache
getCaches UseCache
YesUseCache String
"."
  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 ()
writeTentativeInventory Cache
cache Compression
compressDefault PatchSet rt p Origin wR
patches'
  String -> IO ()
endTedious String
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 = 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 String
"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
  -- We ignore the returned root hash, we don't use it.
  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
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 -> String -> IO ()
writeRepoFormat (PatchFormat -> WithWorkingDir -> RepoFormat
createRepoFormat PatchFormat
PatchFormat1 WithWorkingDir
WithWorkingDir) String
formatPath
  -- clean out old-fashioned junk
  String -> IO ()
debugMessage String
"Cleaning out old-fashioned repository files..."
  String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist String
oldInventoryPath
  String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist String
oldTentativeInventoryPath
  String -> IO ()
removeDirectoryRecursive String
oldPristineDirPath
    IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` String -> IO ()
removeDirectoryRecursive String
oldCurrentDirPath
  String -> IO ()
forall p. FilePathLike p => p -> IO ()
rmGzsIn String
patchesDirPath
  String -> IO ()
forall p. FilePathLike p => p -> IO ()
rmGzsIn String
inventoriesDirPath
  Bool
hasCheckPoints <- String -> IO Bool
doesDirectoryExist String
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
$ String -> IO ()
removeDirectoryRecursive String
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
      [String]
gzs <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".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]
listDirectory String
"."
      (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 [DarcsFlag]
opts = do
  [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Migrating global cache to bucketed format."
  Maybe String
gCacheDir <- IO (Maybe String)
globalCacheDir

  case Maybe String
gCacheDir of
    Maybe String
Nothing -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"New global cache doesn't exist."
    Just 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 String
"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 Doc
"Done making bucketed cache!"
  where
    toBucketed :: FilePath -> FilePath -> IO ()
    toBucketed :: String -> String -> IO ()
toBucketed String
src 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
$ String
"Making " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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
$ \String
subDir ->
                  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String
dest String -> String -> String
</> String
subDir)
                [String]
fileNames <- String -> IO [String]
listDirectory 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
$ \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]
++ String
" 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' String
s String
d 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 [Int
0..Int
255]

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


optimizeGlobalCache :: DarcsCommand
optimizeGlobalCache :: DarcsCommand
optimizeGlobalCache = DarcsCommand
common
    { commandName :: String
commandName = String
"cache"
    , commandExtraArgs :: Int
commandExtraArgs            = -Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp         = [ String
"<DIRECTORY> ..." ]
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelpGlobalCache
    , commandDescription :: String
commandDescription = String
"garbage collect global cache"
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeGlobalCacheCmd
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = \[DarcsFlag]
_ -> 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 :: Doc
optimizeHelpGlobalCache :: Doc
optimizeHelpGlobalCache = [String] -> Doc
formatWords
  [ String
"This command deletes obsolete files within the global cache."
  , String
"It takes one or more directories as arguments, and recursively"
  , String
"searches all repositories within these directories. Then it deletes"
  , String
"all files in the global cache not belonging to these repositories."
  , String
"When no directory is given, it searches repositories in the user's"
  , String
"home directory."
  ]
  Doc -> Doc -> Doc
$+$ [String] -> Doc
formatWords
  [ String
"It also automatically migrates the global cache to the (default)"
  , String
"bucketed format."
  ]

optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeGlobalCacheCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [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 Doc
"Done cleaning global cache!"

cleanGlobalCache :: [String] -> [DarcsFlag] -> IO ()
cleanGlobalCache :: [String] -> [DarcsFlag] -> IO ()
cleanGlobalCache [String]
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
$ 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 Doc
"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 a -> IO [String]
fGetFiles String
cacheSubDir 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' String
dir [String]
s1 [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
. (\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 String
repoDir = do
    ByteString
i <- String -> IO ByteString
gzReadFilePS (String
repoDir String -> String -> String
</> String
hashedInventoryPath)
    String -> [String] -> IO [String]
getHashedFiles (String
repoDir String -> String -> String
</> String
pristineDirPath) [PristineHash -> String
forall a. ValidHash a => a -> String
getValidHash (PristineHash -> String) -> PristineHash -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> PristineHash
peekPristineHash ByteString
i]