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

\begin{code}
module Darcs.Repository.Internal ( Repository(..), RepoType(..),
                    maybeIdentifyRepository, identifyRepository,
                    findRepository, amInRepository, amNotInRepository,
                    slurp_pending,
                    slurp_recorded, slurp_recorded_and_unrecorded,
                    withRecorded,
                    get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,
                    read_repo, sync_repo, absolute_dir,
                    unsafe_fast_read_repo,
                    prefsUrl,
                    read_pending, add_to_pending,
                    withRepoLock,
#ifdef HAVEWX
                    takeRepoGuiLock, releaseRepoGuiLock, withRepoGuiLockCanFail,
#endif
                    tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
                    finalizeRepositoryChanges,
                    unrevertUrl,
                    applyToWorking, applyToPristine, patchSetToPatches,
                    createPristineDirectoryTree,
                    optimizeInventory,
                    getMarkedupFile,
                    PatchSet,
                    add_to_tentative_pristine,
                  ) where
import Prelude hiding ( catch )

import Darcs.External ( fetchFilePS, Cachable( Cachable ) )
import Darcs.IO ( runTolerantly, runSilently )
import Darcs.Repository.Pristine ( Pristine, identifyPristine, nopristine, applyPristine,
                  easyCreatePristineDirectoryTree, slurpPristine,
                )
import Data.List ( (\\) )
import Darcs.SignalHandler ( withSignalsBlocked )
import Darcs.Repository.Format ( RepoFormat, RepoProperty(Darcs1_0, HashedInventory),
                    identifyRepoFormat, format_has_together, format_has,
                    write_problem, read_problem )
import System.Directory ( doesDirectoryExist, setCurrentDirectory, removeFile )
import Control.Monad ( liftM, when, unless )
import Workaround ( createDirectoryIfMissing, getCurrentDirectory )
import FastPackedString ( readFilePS, gzReadFilePS, nilPS, packString )
import Darcs.Patch.Bundle ( scan_bundle, make_bundle )
import Darcs.SlurpDirectory ( Slurpy, slurp_unboring, mmap_slurp, co_slurp,
                              slurp_has )
import Darcs.Hopefully ( Hopefully, hopefully, hopefully2either )
import Darcs.Repository.DarcsRepo ( finalize_pristine_changes, lazily_read_repo,
                                    add_to_tentative_pristine )
import Darcs.Repository.ApplyPatches ( apply_patches )
import Darcs.Repository.HashedRepo ( writeHashFile )
import qualified Darcs.Repository.HashedRepo as HashedRepo
                            ( revert_tentative_changes, finalize_tentative_changes,
                              remove_from_tentative_inventory,
                              read_repo_lazily, write_inventory,
                              add_to_tentative_inventory, read_repo )
import qualified Darcs.Repository.DarcsRepo as DarcsRepo
import qualified Darcs.Repository.GitRepo as GitRepo
import Darcs.Flags ( DarcsFlag(AnyOrder, Boring, LookForAdds, Verbose, Quiet,
                               RepoDir, WorkDir, UMask) )
import Darcs.Patch ( Patch, flatten, join_patches, reorder_and_coalesce,
               commute, patch2patchinfo, null_patch, readPatch,
               writePatch, flatten_to_primitives, invert, is_similar,
               is_addfile, is_adddir, showPatch,
               apply, apply_to_slurpy, gzReadPatchFileLazily,
               empty_markedup_file, MarkedUpFile
             )
import Darcs.Patch.Info ( PatchInfo )
import Darcs.Patch.Set ( PatchSet )
import Darcs.Patch.Apply ( markup_file, LineMark(None) )
import Darcs.Patch.Depends ( get_common_and_uncommon )
import Darcs.Diff ( smart_diff )
import Darcs.Utils ( promptChar, catchall, withCurrentDirectory, withUMask,
                    prettyException )
import Darcs.URL ( is_file )
import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter, filetype_function,
                                Cache, getCaches )
import Darcs.Lock ( withLock, writeDocBinFile, withDelayedDir, removeFileMayNotExist )
import Control.Exception ( catch )
#ifdef HAVEWX
import Darcs.Lock ( takeLock, releaseLock, withLockCanFail )
#endif

#include "impossible.h"

data Repository = Repo !String ![DarcsFlag] !RepoFormat !RepoType deriving ( Show )

data RepoType = DarcsRepository !Pristine Cache | GitRepository deriving ( Show )

maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (Either String Repository)
maybeIdentifyRepository opts "." =
    do darcs <- doesDirectoryExist "_darcs"
       git <- doesDirectoryExist ".git"
       rf <- identifyRepoFormat "."
       here <- absolute_dir "."
       case read_problem rf of
         Just err -> return $ Left err
         Nothing ->
           case (darcs, git) of
           (False, False) -> return (Left "Not a repository")
           (True, _)->
               do pris <- identifyPristine
                  cs <- getCaches opts here
                  return $ Right $ Repo here opts rf (DarcsRepository pris cs)
           (False, True) -> return (Right $ Repo here opts rf GitRepository)
maybeIdentifyRepository opts url' = do
    url <- absolute_dir url'
    darcs <- doesRemoteFileExist (url++"/_darcs/inventory")
    hash_darcs <- doesRemoteFileExist (url++"/_darcs/hashed_inventory")
    git <- doesRemoteFileExist (url++"/.git/HEAD")
    rf <- identifyRepoFormat url
    case read_problem rf of
        Just err -> return $ Left err
        Nothing ->
            case (hash_darcs, darcs, git) of
            (Left s, Left _, Left _) ->
                return (Left $ "Not a repository: " ++ url' ++
                        " (" ++ s ++")")
            (Left _, Left _, Right True) -> return (Right $ Repo url opts rf GitRepository)
            _ -> do cs <- getCaches opts url
                    return $ Right $ Repo url opts rf (DarcsRepository nopristine cs)
    where drfe x = fetchFilePS x Cachable >> return True
          doesRemoteFileExist x = (liftM Right) (drfe x) `catch`
                                      (\e -> return (Left (prettyException e)))

identifyRepository :: [DarcsFlag] -> String -> IO Repository
identifyRepository opts url =
    do er <- maybeIdentifyRepository opts url
       case er of
           Left s -> fail s
           Right r -> return r

isRight :: Either a b -> Bool
isRight (Right _) = True
isRight _         = False

currentDirIsRepository :: IO Bool
currentDirIsRepository = isRight `liftM` maybeIdentifyRepository [] "."

amInRepository :: [DarcsFlag] -> IO (Either String FilePath)
amInRepository (WorkDir d:_) =
    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
       amInRepository []
amInRepository (_:fs) = amInRepository fs
amInRepository [] = 
    seekRepo currentDirIsRepository
                 (Left "You need to be in a repository directory to run this command.")

-- | hunt upwards for the darcs repository
-- This keeps changing up one parent directory, testing at each
-- step if the current directory is a repository or not.  $
-- WARNING this changes the current directory for good if matchFn succeeds
seekRepo :: IO Bool
            -- ^ monadic fn to determine if the current dir is a repo
         -> Either String FilePath
            -- ^ what to return if we don't find a repository
         -> IO (Either String FilePath)
seekRepo matchFn onFail = getCurrentDirectory >>= helper "" where
   helper dir startpwd = do
    air <- matchFn
    if air
       then return (Right dir)
       else do cd <- getCurrentDirectory
               setCurrentDirectory ".."
               cd' <- getCurrentDirectory
               if cd' /= cd
                  then helper (reverse (takeWhile (/='/') $ reverse cd)///dir) startpwd
                  else do setCurrentDirectory startpwd
                          return onFail
    where ""///b = b
          a///"" = a
          a///b = a ++ "/" ++ b


amNotInRepository :: [DarcsFlag] -> IO (Either String FilePath)
amNotInRepository (WorkDir d:_) = do createDirectoryIfMissing False d
                                     -- note that the above could always fail
                                     setCurrentDirectory d
                                     amNotInRepository []
amNotInRepository (_:f) = amNotInRepository f
amNotInRepository [] =
    do air <- currentDirIsRepository
       if air then return (Left $ "You may not run this command in a repository.")
              else return $ Right ""

findRepository :: [DarcsFlag] -> IO (Either String FilePath)
findRepository (RepoDir d:_) | is_file d =
    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
       findRepository []
findRepository (WorkDir d:_) =
    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
       findRepository []
findRepository (_:fs) = findRepository fs
findRepository [] = 
    seekRepo currentDirIsRepository (Right "")

slurp_pending :: Repository -> IO Slurpy
slurp_pending repo = do
  cur <- slurp_recorded repo
  mbpend <- read_pending repo
  case mbpend of
    Just pend ->
      case apply_to_slurpy pend cur of
        Just pendcur -> return pendcur
        Nothing -> do putStrLn "Yikes, pending has conflicts!"
                      return cur
    Nothing -> return cur

slurp_recorded :: Repository -> IO Slurpy
slurp_recorded repository@(Repo dir _ _ (DarcsRepository _ _)) = do
    mc <- withCurrentDirectory dir $ identifyPristine >>= slurpPristine
    case mc of (Just slurpy) -> return slurpy
               Nothing -> withDelayedDir "pristine.temp" $ \cd ->
                          do createPristineDirectoryTree repository cd
                             mmap_slurp cd
slurp_recorded (Repo r _ _ GitRepository) = GitRepo.slurpHead r

slurp_recorded_and_unrecorded :: Repository -> IO (Slurpy, Slurpy)
slurp_recorded_and_unrecorded repo@(Repo r _ _ _) = do
  cur <- slurp_recorded repo
  mbpend <- read_pending repo
  withCurrentDirectory r $
    case mbpend of
    Just pend ->
      case apply_to_slurpy pend cur of
      Nothing -> fail "Yikes, pending has conflicts!"
      Just pendslurp -> do unrec <- co_slurp pendslurp "."
                           return (cur, unrec)
    Nothing -> do unrec <- co_slurp cur "."
                  return (cur, unrec)

pendingName :: RepoType -> String
pendingName (DarcsRepository _ _) = "_darcs/patches/pending"
pendingName GitRepository = ".git/darcs_pending"

read_pending :: Repository -> IO (Maybe Patch)
read_pending (Repo r _ _ tp) =
    withCurrentDirectory r (DarcsRepo.read_pending (pendingName tp))

add_to_pending :: Repository -> Patch -> IO ()
add_to_pending repo p =
    do pend <- get_unrecorded repo
       let pnew = case pend of Nothing -> p
                               Just pold -> join_patches [pold, p]
       with_new_pending repo pnew (return ())

with_new_pending :: Repository -> Patch -> IO () -> IO ()
with_new_pending repo@(Repo r _ _ tp) p job =
    withCurrentDirectory r $
    DarcsRepo.with_new_pending (pendingName tp) p $ job >> slurp_recorded repo

unempty :: [a] -> Maybe [a]
unempty [] = Nothing
unempty l = Just l

get_unrecorded_no_look_for_adds :: Repository -> IO (Maybe Patch)
get_unrecorded_no_look_for_adds = get_unrecorded_private (filter (/= LookForAdds))

get_unrecorded_unsorted :: Repository -> IO (Maybe Patch)
get_unrecorded_unsorted = get_unrecorded_private (AnyOrder:)

get_unrecorded :: Repository -> IO (Maybe Patch)
get_unrecorded = get_unrecorded_private id

get_unrecorded_private :: ([DarcsFlag]->[DarcsFlag]) -> Repository -> IO (Maybe Patch)
get_unrecorded_private modopts repository@(Repo r oldopts _ _) =
  withCurrentDirectory r $ do
    cur <- slurp_pending repository
    work <- if LookForAdds `elem` opts
            then do nboring <- if Boring `elem` opts
                               then return $ darcsdir_filter
                               else boring_file_filter
                    slurp_unboring (myfilt cur nboring) "."
            else co_slurp cur "."
    pend <- read_pending repository
    when (Verbose `elem` opts) $ putStrLn "diffing dir..."
    ftf <- filetype_function
    case smart_diff opts ftf cur work of
      Nothing -> case pend of
                 Just x | null (flatten x) -> return Nothing
                 _ -> return pend
      Just di->
        case pend of
        Nothing -> return $ Just di
        Just pp ->
            if AnyOrder `elem` opts
            then return $ liftM join_patches $
                 unempty $ flatten $ join_patches [pp,di]
            else return $ liftM (reorder_and_coalesce . join_patches) $
                 unempty $ flatten $ join_patches [pp,di]
    where myfilt s nboring f = slurp_has f s || nboring [f] /= []
          opts = modopts oldopts

read_repo :: Repository -> IO PatchSet
read_repo (Repo r opts rf (DarcsRepository _ c))
    | format_has HashedInventory rf = HashedRepo.read_repo c opts r
    | otherwise = DarcsRepo.read_repo r
read_repo (Repo r _ _ GitRepository) = GitRepo.read_repo r

-- unsafe_fast_read_repo parses the patches lazily, assuming that they will
-- both exist and be valid files.  This is obviously unsafe in the senses
-- that "isJust" doesn't tell us if a patch is actually parsable.
unsafe_fast_read_repo :: Repository -> IO PatchSet
unsafe_fast_read_repo (Repo r opts rf (DarcsRepository _ c))
    | format_has HashedInventory rf = HashedRepo.read_repo_lazily c opts r
    | otherwise = DarcsRepo.lazily_read_repo r
unsafe_fast_read_repo (Repo r _ _ GitRepository) = GitRepo.read_repo r

sync_repo :: Repository -> IO ()
sync_repo (Repo r _ _ (DarcsRepository p _)) =
    withCurrentDirectory r $ DarcsRepo.sync_repo p
-- this should probably update the Git cache
sync_repo (Repo _ _ _ GitRepository) = return ()

absolute_dir :: FilePath -> IO FilePath
absolute_dir = DarcsRepo.absolute_dir

prefsUrl :: Repository -> String
prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/_darcs/prefs"
prefsUrl (Repo r _ _ GitRepository) = r ++ "/.git/darcs-prefs"

unrevertUrl :: Repository -> String
unrevertUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/_darcs/patches/unrevert"
unrevertUrl (Repo r _ _ GitRepository) = r ++ "/.git/darcs-unrevert"

applyToWorking :: Repository -> [DarcsFlag] -> Patch -> IO ()
applyToWorking (Repo r _ _ (DarcsRepository _ _)) opts patch =
    withCurrentDirectory r $ if Quiet `elem` opts
                             then runSilently $ apply opts patch
                             else runTolerantly $ apply opts patch
applyToWorking (Repo _ _ _ GitRepository) _ _ = return ()


applyToPristine :: Repository -> Patch -> IO ()
applyToPristine (Repo r _ _ (DarcsRepository p _)) patch =
    withCurrentDirectory r $ applyPristine p patch
applyToPristine (Repo _ _ _ GitRepository) _ = return ()

handle_pend_for_add :: Repository -> [DarcsFlag] -> Patch -> IO ()
handle_pend_for_add repository@(Repo _ _ _ rt) opts p =
    do mpend <- read_pending repository
       let is_okay pend pa | is_addfile pa = any (is_similar pa) pend
                           | is_adddir pa = any (is_similar pa) pend
                           | otherwise = True
           filter_p :: [Patch] -> [Patch]
           filter_p = if LookForAdds `elem` opts
                      then case flatten_to_primitives `fmap` mpend of
                             Nothing -> const []
                             Just pend -> filter (is_okay pend)
                      else id
       prepend rt $ invert $ join_patches $ filter_p $ flatten_to_primitives p

data HashedVsOld a = HvsO { old, hashed :: a }

decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a
decideHashedOrNormal rf (HvsO { hashed = h, old = o })
    | format_has_together [HashedInventory] rf = h
    | format_has_together [Darcs1_0,HashedInventory] rf = o >> h
    | otherwise = o

tentativelyAddPatch :: Repository -> [DarcsFlag] -> Patch -> IO Patch
tentativelyAddPatch r@(Repo dir _ rf (DarcsRepository _ _)) opts patch =
    withCurrentDirectory dir $
    do fp <- decideHashedOrNormal rf $ HvsO {
          hashed = HashedRepo.add_to_tentative_inventory opts patch,
          old = DarcsRepo.add_to_tentative_inventory opts patch
                                         }
       add_to_tentative_pristine fp
       handle_pend_for_add r opts patch
       gzReadPatchFileLazily fp
tentativelyAddPatch r@(Repo dir _ _ GitRepository) opts patch =
    withCurrentDirectory dir $ do (patch', token) <- GitRepo.writePatch dir patch
                                  handle_pend_for_add r opts patch'
                                  GitRepo.set_tentative_tree token
                                  return patch'

tentativelyAddToPending :: Repository -> [DarcsFlag] -> Patch -> IO ()
tentativelyAddToPending (Repo dir _ _ rt) _ patch =
    withCurrentDirectory dir $ do
      let pn = pendingName rt
          tpn = pn ++ ".tentative"
      pend <- gzReadFilePS tpn `catchall` (return nilPS)
      let newpend = case readPatch pend of
                    Nothing -> patch
                    Just (p,_) -> join_patches $ flatten_to_primitives p ++ flatten_to_primitives patch
      writePatch tpn $ newpend

prepend :: RepoType -> Patch -> IO ()
prepend rt patch = do let pn = pendingName rt
                          ppn = pn ++ ".tentative_prepend"
                      pend <- gzReadFilePS ppn `catchall` (return nilPS)
                      let newpend = case readPatch pend of
                                      Nothing -> patch
                                      Just (p,_) -> join_patches $ flatten_to_primitives patch ++
                                                                   flatten_to_primitives p
                      writePatch ppn $ newpend

tentativelyRemovePatches :: Repository -> [DarcsFlag] -> [Patch] -> IO ()
tentativelyRemovePatches repository@(Repo dir _ rf rt@(DarcsRepository _ c)) opts ps =
    withCurrentDirectory dir $ do
      prepend rt $ join_patches ps
      remove_from_unrevert_context repository ps
      if format_has_together [HashedInventory] rf
         then do HashedRepo.remove_from_tentative_inventory c opts ps
                 hashes <- mapM (withCurrentDirectory "_darcs/patches" . writeHashFile .
                                 showPatch . invert) ps
                 mapM_ (add_to_tentative_pristine . ("_darcs/patches/"++)) $ reverse hashes
         else if format_has_together [Darcs1_0,HashedInventory] rf
              then do HashedRepo.remove_from_tentative_inventory c opts ps
                      mapM (withCurrentDirectory "_darcs/patches" . writeHashFile .
                                                 showPatch . invert) ps
                      -- Warning! This scenario is *not* properly atomic!
                      DarcsRepo.remove_from_tentative_inventory opts ps
              else DarcsRepo.remove_from_tentative_inventory opts ps
tentativelyRemovePatches repository@(Repo dir _ _ GitRepository) _ ps =
    withCurrentDirectory dir $ do
      prepend GitRepository $ join_patches ps
      remove_from_unrevert_context repository ps
      fail "unimplemented git"

finalize_pending :: Repository -> IO ()
finalize_pending repository@(Repo dir _ _ rt) = do
  withCurrentDirectory dir $ do let pn = pendingName rt
                                    tpn = pn ++ ".tentative"
                                    ppn = pn ++ ".tentative_prepend"
                                pend <- read_pending repository
                                ppfile <- gzReadFilePS ppn `catchall` (return nilPS)
                                tpfile <- gzReadFilePS tpn `catchall` (return nilPS)
                                let tpend = fst `fmap` readPatch tpfile
                                    ppend = fst `fmap` readPatch ppfile
                                    mp2p Nothing = null_patch
                                    mp2p (Just p) = p
                                    new_pending = join_patches $ map mp2p [ppend, pend, tpend]
                                with_new_pending repository new_pending (return ())

finalizeRepositoryChanges :: Repository -> IO ()
finalizeRepositoryChanges repository@(Repo dir _ rf (DarcsRepository _ _)) =
    withCurrentDirectory dir $ withSignalsBlocked $
    do finalize_pristine_changes
       decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.finalize_tentative_changes,
                                        old = DarcsRepo.finalize_tentative_changes }
       finalize_pending repository
finalizeRepositoryChanges repository@(Repo dir _ _ GitRepository) =
    withCurrentDirectory dir $ do GitRepo.finalize_tentative_changes
                                  finalize_pending repository

revertRepositoryChanges :: Repository -> IO ()
revertRepositoryChanges (Repo dir _ rf dr@(DarcsRepository _ _)) =
    withCurrentDirectory dir $
    do removeFileMayNotExist $ (pendingName dr) ++ ".tentative"
       removeFileMayNotExist $ (pendingName dr) ++ ".tentative_prepend"
       decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revert_tentative_changes,
                                        old = DarcsRepo.revert_tentative_changes }
revertRepositoryChanges (Repo dir _ _ GitRepository) =
    withCurrentDirectory dir $
    do removeFileMayNotExist $ (pendingName GitRepository) ++ ".tentative"
       removeFileMayNotExist $ (pendingName GitRepository) ++ ".tentative_prepend"
       GitRepo.revert_tentative_changes

patchSetToPatches :: PatchSet -> [Patch]
patchSetToPatches patchSet = map hopefully $ reverse $ concat patchSet

getUMask :: [DarcsFlag] -> Maybe String
getUMask [] = Nothing
getUMask ((UMask u):_) = Just u
getUMask (_:l) = getUMask l

withRepoLock :: [DarcsFlag] -> (Repository -> IO a) -> IO a
withRepoLock opts job =
    do repository <- identifyRepository opts "."
       let (Repo _ _ rf rt) = repository
       case write_problem rf of
         Nothing -> return ()
         Just err -> fail err
       let name = case rt of
                    (DarcsRepository _ _) -> "./_darcs/lock"
                    GitRepository -> "./.git/lock"
           wu = case (getUMask opts) of
                  Nothing -> id
                  Just u -> withUMask u
       wu $ withLock name
              (revertRepositoryChanges repository >> job repository)

#ifdef HAVEWX
takeRepoGuiLock :: IO Bool
takeRepoGuiLock =
 do (_,name) <- guiLockFileHelper
    takeLock name

releaseRepoGuiLock :: IO ()
releaseRepoGuiLock =
 do (_,name) <- guiLockFileHelper
    releaseLock name

withRepoGuiLockCanFail :: (Repository -> IO a) -> IO (Either () a)
withRepoGuiLockCanFail job =
 do (repository,name) <- guiLockFileHelper
    withLockCanFail name (job repository)

guiLockFileHelper :: IO (Repository, FilePath)
guiLockFileHelper =
 do repository <- identifyRepository [] "."
    let (Repo _ _ rf rt) = repository
    case write_problem rf of
      Nothing  -> return ()
      Just err -> fail err
    let name = case rt of
          (DarcsRepository _ _) -> "./_darcs/guilock"
          GitRepository       -> "./.git/guilock"
    return (repository, name)
#endif
\end{code}

\begin{code}
remove_from_unrevert_context :: Repository -> [Patch] -> IO ()
remove_from_unrevert_context repository ps = do
  bundle <- unrevert_patch_bundle `catchall` return [[]]
  case bundle of
    [[]] -> return ()
    _ -> do
    let unrevert_loc = unrevertUrl repository
    ref <- read_repo repository
    case get_common_and_uncommon (bundle, ref) of
        (common,[[h_us]],[[]]) ->
            case commute (hopefully h_us, join_patches ps) of
            Nothing -> unrevert_impossible unrevert_loc
            Just (_, us') -> do
                s <- slurp_recorded repository
                writeDocBinFile unrevert_loc $
                             make_bundle [] s
                             (common \\ pis) [us']
        (common,[[(_, x)]],_)
            | isr && any (`elem` common) pis -> unrevert_impossible unrevert_loc
            | isr -> return ()
            where isr = isRight $ hopefully2either x
        _ -> unrevert_impossible unrevert_loc
  where unrevert_impossible unrevert_loc =
            do yorn <- promptChar
                       "This operation will make unrevert impossible!\nProceed?"
                       "yn"
               case yorn of
                 'n' -> fail "Cancelled to avoid unrevert catastrophe!"
                 'y' -> removeFile unrevert_loc `catchall` return ()
                 _ -> impossible
        pis = map (fromJust . patch2patchinfo) ps
        unrevert_patch_bundle :: IO PatchSet
        unrevert_patch_bundle = do pf <- readFilePS (unrevertUrl repository)
                                   case scan_bundle pf of
                                     Right foo -> return foo
                                     Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err
\end{code}

\begin{code}
optimizeInventory :: Repository -> IO ()
optimizeInventory repository@(Repo r _ rf (DarcsRepository _ _)) =
    do ps <- read_repo repository
       decideHashedOrNormal rf $
           HvsO { hashed = HashedRepo.write_inventory ps,
                  old = DarcsRepo.write_inventory r ps
                }
optimizeInventory (Repo _ _ _ GitRepository) = return ()

createPristineDirectoryTree :: Repository -> FilePath -> IO ()
createPristineDirectoryTree (Repo r _ rf (DarcsRepository pris _)) dir
    | not (format_has HashedInventory rf) =
        do absdir <- absolute_dir dir
           withCurrentDirectory r $ DarcsRepo.createPristineDirectoryTree pris absdir
createPristineDirectoryTree repository@(Repo r _ _ _) reldir = do
  dir <- absolute_dir reldir
  withCurrentDirectory r $
    do pris <- identifyPristine
       done <- easyCreatePristineDirectoryTree pris dir
       unless done $ do
          patches <- (reverse . concat) `fmap` read_repo repository
          createDirectoryIfMissing True dir
          withCurrentDirectory dir $ apply_patches [] noPut noPut patches
                  where noPut _ = return ()

withRecorded :: Repository -> ((FilePath -> IO a) -> IO a) -> (FilePath -> IO a) -> IO a
withRecorded repository mk_dir f
    = mk_dir $ \d -> do createPristineDirectoryTree repository d
                        f d

\end{code}

\begin{code}
getMarkedupFile :: Repository -> PatchInfo -> FilePath -> IO MarkedUpFile
getMarkedupFile repository pinfo f = do
  patches <- liftM (dropWhile (\ (pi',_)-> pi' /= pinfo)
                    . reverse . concat) $ read_repo repository
  return $ snd $ do_mark_all patches (f, empty_markedup_file)
do_mark_all :: [(PatchInfo, Hopefully Patch)]
            -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)
do_mark_all ((n,hp):pps) (f, mk) =
    case hopefully2either hp of
      Right p -> do_mark_all pps $ markup_file n p (f, mk)
      Left _ -> (f, [(packString "Error reading a patch!",None)])
do_mark_all [] (f, mk) = (f, mk)
\end{code}
