darcs-beta-2.2.98.1: src/Darcs/Commands/Optimize.lhs
% 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.
\darcsCommand{optimize}
\begin{code}
{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE CPP #-}
module Darcs.Commands.Optimize ( optimize ) where
import Control.Monad ( when, unless )
import Data.Maybe ( isJust )
import Text.Regex ( mkRegex, matchRegex )
import System.Directory ( getDirectoryContents, doesDirectoryExist )
import Darcs.Hopefully ( hopefully, info )
import Darcs.Commands ( DarcsCommand(..), nodefaults )
import Darcs.Arguments ( DarcsFlag( Compress, UnCompress,
NoCompress, Reorder,
TagName, CheckPoint,
Relink, RelinkPristine ),
tagname, checkpoint, reorder_patches,
uncompress_nocompress,
relink, relink_pristine, sibling,
flagsToSiblings,
working_repo_dir, umask_option,
)
import Darcs.Repository.Prefs ( get_preflist )
import Darcs.Repository ( Repository, PatchSet, withRepoLock, ($-), withGutsOf,
read_repo, optimizeInventory, slurp_recorded,
tentativelyReplacePatches, cleanRepository,
amInRepository, finalizeRepositoryChanges )
import Darcs.Repository.Checkpoint ( write_checkpoint )
import Darcs.Ordered ( RL(..), unsafeUnRL, (+<+), mapFL_FL, reverseRL, mapRL, concatRL )
import Darcs.Patch.Info ( PatchInfo, just_name, human_friendly )
import Darcs.Patch ( RepoPatch )
import ByteStringUtils ( gzReadFilePS )
import Darcs.Patch.Depends ( deep_optimize_patchset, slightly_optimize_patchset,
get_patches_beyond_tag, get_patches_in_tag,
)
import Darcs.Lock ( maybeRelink, gzWriteAtomicFilePS, writeAtomicFilePS )
import Darcs.RepoPath ( toFilePath )
import Darcs.Utils ( withCurrentDirectory )
import Progress ( debugMessage )
import Printer ( putDocLn, text, ($$) )
import Darcs.SlurpDirectory ( slurp, list_slurpy_files )
import Darcs.Repository.Pristine ( identifyPristine, pristineDirectory )
import Darcs.Sealed ( FlippedSeal(..), unsafeUnseal )
import Darcs.Global ( darcsdir )
#include "impossible.h"
optimize_description :: String
optimize_description = "Optimize the repository."
optimize_help :: String
optimize_help =
"The `darcs optimize' command modifies the current repository in an\n" ++
"attempt to reduce its resource requirements. By default a single\n" ++
"fast, safe optimization is performed; additional optimization\n" ++
"techniques can be enabled by passing options to `darcs optimize'.\n" ++
"\n" ++ optimize_help_inventory ++
-- "\n" ++ optimize_help_reorder ++
"\n" ++ optimize_help_relink ++
-- checkpoints and uncompression are least useful, so they are last.
"\n" ++ optimize_help_compression ++
"\n" ++ optimize_help_checkpoint ++
"\n" ++
"There is one more optimization which CAN NOT be performed by this\n" ++
"command. Every time your record a patch, a new inventory file is\n" ++
"written to _darcs/inventories/, and old inventories are never reaped.\n" ++
"\n" ++
"If _darcs/inventories/ is consuming a relatively large amount of\n" ++
"space, you can safely reclaim it by using `darcs get' to make a\n" ++
"complete copy of the repo. When doing so, don't forget to copy over\n" ++
"any unsaved changes you have made to the working tree or to\n" ++
"unversioned files in _darcs/prefs/ (such as _darcs/prefs/author).\n"
optimize :: DarcsCommand
optimize = DarcsCommand {command_name = "optimize",
command_help = optimize_help,
command_description = optimize_description,
command_extra_args = 0,
command_extra_arg_help = [],
command_command = optimize_cmd,
command_prereq = amInRepository,
command_get_arg_possibilities = return [],
command_argdefaults = nodefaults,
command_advanced_options = [uncompress_nocompress, umask_option],
command_basic_options = [checkpoint,
tagname,
working_repo_dir,
reorder_patches,
sibling, relink,
relink_pristine]}
optimize_cmd :: [DarcsFlag] -> [String] -> IO ()
optimize_cmd origopts _ = withRepoLock opts $- \repository -> do
cleanRepository repository
do_reorder opts repository
do_optimize_inventory repository
when (CheckPoint `elem` opts) $ do_checkpoint opts repository
when (Compress `elem` opts || UnCompress `elem` opts) $ optimize_compression opts
when (Relink `elem` opts || (RelinkPristine `elem` opts)) $
do_relink opts repository
putStrLn "Done optimizing!"
where opts = if UnCompress `elem` origopts then NoCompress:origopts else origopts
is_tag :: PatchInfo -> Bool
is_tag pinfo = take 4 (just_name pinfo) == "TAG "
optimize_help_inventory :: String
optimize_help_inventory =
"The default optimization moves recent patches (those not included in\n" ++
"the latest tag) to the `front', reducing the amount that a typical\n" ++
"remote command needs to download. It should also reduce the CPU time\n" ++
"needed for some operations.\n"
do_optimize_inventory :: RepoPatch p => Repository p -> IO ()
do_optimize_inventory repository = do
debugMessage "Writing out a nice copy of the inventory."
optimizeInventory repository
debugMessage "Done writing out a nice copy of the inventory."
optimize_help_checkpoint :: String
optimize_help_checkpoint =
"If the repository is in `old-fashioned-inventory' format, the `darcs\n" ++
"optimize --checkpoint' command creates a checkpoint of the latest tag.\n" ++
"This checkpoint is used by `darcs get --partial' to create partial\n" ++
"repositories. With the `--tag' option, checkpoints for older tags can\n" ++
"be created. In newer repository formats, this feature has been\n" ++
"replaced by `darcs get --lazy', which does not require checkpoints.\n"
do_checkpoint :: RepoPatch p => [DarcsFlag] -> Repository p -> IO ()
do_checkpoint opts repository = do
mpi <- get_tag opts repository
case mpi of
Nothing -> return ()
Just pinfo -> do putDocLn $ text "Checkpointing tag:"
$$ human_friendly pinfo
write_checkpoint repository pinfo
get_tag :: RepoPatch p => [DarcsFlag] -> Repository p -> IO (Maybe PatchInfo)
get_tag [] r = do ps <- read_repo r
case filter is_tag $ lasts $ mapRL (mapRL info) ps of
[] -> do putStrLn "There is no tag to checkpoint!"
return Nothing
(pinfo:_) -> return $ Just pinfo
get_tag (TagName t:_) r =
do ps <- read_repo r
case filter (match_tag t) $ lasts $ mapRL (mapRL info) ps of
(pinfo:_) -> return $ Just pinfo
_ -> case filter (match_tag t) $
lasts $ mapRL (mapRL info) $ deep_optimize_patchset ps of
(pinfo:_) -> return $ Just pinfo
_ -> do putStr "Cannot checkpoint any tag "
putStr $ "matching '"++t++"'\n"
return Nothing
get_tag (_:fs) r = get_tag fs r
lasts :: [[a]] -> [a]
lasts [] = []
lasts (x@(_:_):ls) = last x : lasts ls
lasts ([]:ls) = lasts ls
mymatch :: String -> PatchInfo -> Bool
mymatch r = match_name $ matchRegex (mkRegex r)
match_name :: (String -> Maybe a) -> PatchInfo -> Bool
match_name ch pinfo = isJust $ ch (just_name pinfo)
match_tag :: String -> PatchInfo -> Bool
match_tag ('^':n) = mymatch $ "^TAG "++n
match_tag n = mymatch $ "^TAG .*"++n
optimize_help_compression :: String
optimize_help_compression =
"By default patches are compressed with zlib (RFC 1951) to reduce\n" ++
"storage (and download) size. In exceptional circumstances, it may be\n" ++
"preferable to avoid compression. In this case the `--dont-compress'\n" ++
"option can be used (e.g. with `darcs record') to avoid compression.\n" ++
"\n" ++
"The `darcs optimize --uncompress' and `darcs optimize --compress'\n" ++
"commands can be used to ensure existing patches in the current\n" ++
"repository are respectively uncompressed or compressed. Note that\n" ++
"repositories in the legacy `old-fashioned-inventory' format have a .gz\n" ++
"extension on patch files even when uncompressed.\n"
optimize_compression :: [DarcsFlag] -> IO ()
optimize_compression opts = do
putStrLn "Optimizing (un)compression of patches..."
do_compress (darcsdir++"/patches")
putStrLn "Optimizing (un)compression of inventories..."
do_compress (darcsdir++"/inventories")
where do_compress f =
do isd <- doesDirectoryExist f
if isd then withCurrentDirectory f $
do fs <- filter notdot `fmap` getDirectoryContents "."
mapM_ do_compress fs
else if Compress `elem` opts
then gzReadFilePS f >>= gzWriteAtomicFilePS f
else gzReadFilePS f >>= writeAtomicFilePS f
notdot ('.':_) = False
notdot _ = True
optimize_help_relink :: String
optimize_help_relink =
"The `darcs optimize --relink' command hard-links patches that the\n" ++
"current repository has in common with its peers. Peers are those\n" ++
"repositories listed in _darcs/prefs/sources, or defined with the\n" ++
"`--sibling' option (which can be used multiple times).\n" ++
"\n" ++
"Darcs uses hard-links automatically, so this command is rarely needed.\n" ++
"It is most useful if you used `cp -r' instead of `darcs get' to copy a\n" ++
"repository, or if you pulled the same patch from a remote repository\n" ++
"into multiple local repositories.\n" ++
"\n" ++
"A `darcs optimize --relink-pristine' command is also available, but\n" ++
"generally SHOULD NOT be used. It results in a relatively small space\n" ++
"saving at the cost of making many Darcs commands MUCH slower.\n"
do_relink :: RepoPatch p => [DarcsFlag] -> Repository p -> IO ()
do_relink opts repository =
do some_siblings <- return (flagsToSiblings opts)
defrepolist <- get_preflist "defaultrepo"
siblings <- return (map toFilePath some_siblings ++ defrepolist)
if (siblings == [])
then putStrLn "No siblings -- no relinking done."
else do when (Relink `elem` opts) $
do debugMessage "Relinking patches..."
patches <-
(fmap list_slurpy_files) (slurp $ darcsdir++"/patches")
maybeRelinkFiles siblings patches (darcsdir++"/patches")
when (RelinkPristine `elem` opts) $
do pristine <- identifyPristine
case (pristineDirectory pristine) of
(Just d) -> do
debugMessage "Relinking pristine tree..."
c <- slurp_recorded repository
maybeRelinkFiles
siblings (list_slurpy_files c) d
Nothing -> return ()
debugMessage "Done relinking."
return ()
return ()
maybeRelinkFiles :: [String] -> [String] -> String -> IO ()
maybeRelinkFiles src dst dir =
mapM_ (maybeRelinkFile src) (map ((dir ++ "/") ++) dst)
maybeRelinkFile :: [String] -> String -> IO ()
maybeRelinkFile [] _ = return ()
maybeRelinkFile (h:t) f =
do done <- maybeRelink (h ++ "/" ++ f) f
unless done $
maybeRelinkFile t f
return ()
\end{code}
\begin{options}
--reorder-patches
\end{options}
The \verb|--reorder-patches| option causes Darcs to create an optimal
ordering of its internal patch inventory. This may help to produce shorter
`context' lists when sending patches, and may improve performance for some
other operations as well. You should not run \verb!--reorder-patches! on a
repository from which someone may be simultaneously pulling or getting, as
this could lead to repository corruption.
\begin{code}
-- FIXME: someone needs to grovel through the source and determine
-- just how optimizeInventory differs from do_reorder. The following
-- is purely speculation. --twb, 2009-04
-- optimize_help_reorder :: String
-- optimize_help_reorder =
-- "The `darcs optimize --reorder' command is a more comprehensive version\n" ++
-- "of the default optimization. It reorders patches with respect to ALL\n" ++
-- "tags, rather than just the latest tag.\n"
do_reorder :: RepoPatch p => [DarcsFlag] -> Repository p -> IO ()
do_reorder opts _ | not (Reorder `elem` opts) = return ()
do_reorder opts repository = do
debugMessage "Reordering the inventory."
psnew <- choose_order `fmap` read_repo repository
let ps = mapFL_FL hopefully $ reverseRL $ head $ unsafeUnRL psnew
withGutsOf repository $ do tentativelyReplacePatches repository opts ps
finalizeRepositoryChanges repository
debugMessage "Done reordering the inventory."
choose_order :: RepoPatch p => PatchSet p -> PatchSet p
choose_order ps | isJust last_tag =
case slightly_optimize_patchset $ unsafeUnseal $ get_patches_in_tag lt ps of
((t:<:NilRL):<:pps) -> case get_patches_beyond_tag lt ps of
FlippedSeal (p :<: NilRL) -> (p+<+(t:<:NilRL)) :<: pps
_ -> impossible
_ -> impossible
where last_tag = case filter is_tag $ mapRL info $ concatRL ps of
(t:_) -> Just t
_ -> Nothing
lt = fromJust last_tag
choose_order ps = ps
\end{code}