Repository.hs

-- 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.

{-# LANGUAGE CPP, ScopedTypeVariables #-}
module Darcs.Repository
    ( Repository
    , HashedDir(..)
    , Cache(..)
    , CacheLoc(..)
    , WritableOrNot(..)
    , RepoJob(..)
    , maybeIdentifyRepository
    , identifyRepositoryFor
    , withRecorded
    , withRepoLock
    , withRepoLockCanFail
    , withRepository
    , withRepositoryDirectory
    , writePatchSet
    , findRepository
    , amInRepository
    , amNotInRepository
    , amInHashedRepository
    , replacePristine
    , readRepo
    , prefsUrl
    , repoPatchType
    , readRepoUsingSpecificInventory
    , addToPending
    , addPendingDiffToPending
    , tentativelyAddPatch
    , tentativelyRemovePatches
    , tentativelyAddToPending
    , readTentativeRepo
    , RebaseJobFlags(..)
    , withManualRebaseUpdate
    , tentativelyMergePatches
    , considerMergeToWorking
    , revertRepositoryChanges
    , finalizeRepositoryChanges
    , createRepository
    , cloneRepository
    , patchSetToRepository
    , unrevertUrl
    , applyToWorking
    , createPristineDirectoryTree
    , createPartialsPristineDirectoryTree
    , reorderInventory
    , cleanRepository
    , PatchSet
    , SealedPatchSet
    , PatchInfoAnd
    , setScriptsExecutable
    , setScriptsExecutablePatches
    , checkUnrelatedRepos
    , testTentative
    , modifyCache
    , reportBadSources
    -- * Recorded and unrecorded and pending.
    , readRecorded
    , readUnrecorded
    , unrecordedChanges
    , unrecordedChangesWithPatches
    , filterOutConflicts
    , readPending
    , readRecordedAndPending
    -- * Index.
    , readIndex
    , invalidateIndex
    -- * Used as command arguments
    , listFiles
    , listRegisteredFiles
    , listUnregisteredFiles
    ) where

import Prelude ()
import Darcs.Prelude

import Control.Monad ( unless, when )
import Data.List ( (\\) )
import System.Exit ( exitSuccess )

import Darcs.Repository.State
    ( readRecorded
    , readUnrecorded
    , unrecordedChanges
    , unrecordedChangesWithPatches
    , readPendingAndWorking
    , readPending
    , readIndex
    , invalidateIndex
    , readRecordedAndPending
    , restrictDarcsdir
    , restrictBoring
    , applyTreeFilter
    , filterOutConflicts
    )

import Darcs.Repository.Internal
    ( Repository(..)
    , maybeIdentifyRepository
    , identifyRepositoryFor
    , findRepository
    , amInRepository
    , amNotInRepository
    , amInHashedRepository
    , readRepo
    , readTentativeRepo
    , readRepoUsingSpecificInventory
    , prefsUrl
    , withRecorded
    , tentativelyAddPatch
    , tentativelyRemovePatches
    , tentativelyAddToPending
    , revertRepositoryChanges
    , finalizeRepositoryChanges
    , unrevertUrl
    , applyToWorking
    , createPristineDirectoryTree
    , createPartialsPristineDirectoryTree
    , reorderInventory
    , cleanRepository
    , setScriptsExecutable
    , setScriptsExecutablePatches
    , makeNewPending
    , repoPatchType
    )
import Darcs.Repository.Job
    ( RepoJob(..)
    , withRepoLock
    , withRepoLockCanFail
    , withRepository
    , withRepositoryDirectory
    )
import Darcs.Repository.Rebase ( RebaseJobFlags(..), withManualRebaseUpdate )
import Darcs.Repository.Test ( testTentative )
import Darcs.Repository.Merge( tentativelyMergePatches
                             , considerMergeToWorking
                             )
import Darcs.Repository.Cache ( HashedDir(..)
                              , Cache(..)
                              , CacheLoc(..)
                              , WritableOrNot(..)
                              , reportBadSources
                              )
import Darcs.Repository.InternalTypes ( modifyCache )
import Darcs.Repository.Flags
    ( DiffAlgorithm (..)
    , ScanKnown(..)
    , UpdateWorking(..)
    , UseCache(..)
    , UseIndex(..)
    )
import Darcs.Repository.Clone
    ( createRepository
    , cloneRepository
    , replacePristine
    , writePatchSet
    , patchSetToRepository
    )

import Darcs.Patch ( RepoPatch
                   , PrimOf
                   )
import Darcs.Patch.Set ( PatchSet(..)
                       , SealedPatchSet
                       )
import Darcs.Patch.Commute( commuteFL )
import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), FreeLeft, unFreeLeft )
import Darcs.Patch.Witnesses.Ordered
       ( (:>)(..)
       , reverseRL
       , reverseFL
       , FL(..)
       , (+>+)
       )
import Darcs.Patch.Depends ( areUnrelatedRepos )

import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.Path( anchorPath )

import Darcs.Util.Tree( Tree, emptyTree, expand, list )
import Darcs.Util.Tree.Plain( readPlainTree )

checkUnrelatedRepos :: RepoPatch p
                    => Bool
                    -> PatchSet rt p wStart wX
                    -> PatchSet rt p wStart wY
                    -> IO ()
checkUnrelatedRepos allowUnrelatedRepos us them =
    when ( not allowUnrelatedRepos && areUnrelatedRepos us them ) $
         do confirmed <- promptYorn "Repositories seem to be unrelated. Proceed?"
            unless confirmed $ do putStrLn "Cancelled."
                                  exitSuccess

-- | Add an FL of patches started from the pending state to the pending patch.
-- TODO: add witnesses for pending so we can make the types precise: currently
-- the passed patch can be applied in any context, not just after pending.
addPendingDiffToPending :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
                          => Repository rt p wR wU wT -> UpdateWorking
                          -> FreeLeft (FL (PrimOf p)) -> IO ()
addPendingDiffToPending _ NoUpdateWorking  _ = return ()
addPendingDiffToPending repo@(Repo{}) uw@YesUpdateWorking newP = do
    (toPend :> _) <-
        readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) repo Nothing
    invalidateIndex repo
    case unFreeLeft newP of
        (Sealed p) -> makeNewPending repo uw $ toPend +>+ p

-- | Add a FL of patches starting from the working state to the pending patch,
-- including as much extra context as is necessary (context meaning
-- dependencies), by commuting the patches to be added past as much of the
-- changes between pending and working as is possible, and including anything
-- that doesn't commute, and the patch itself in the new pending patch.
addToPending :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
             => Repository rt p wR wU wT -> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()
addToPending _ NoUpdateWorking  _ = return ()
addToPending repo@(Repo{}) uw@YesUpdateWorking p = do
   (toPend :> toUnrec) <- readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) repo Nothing
   invalidateIndex repo
   case genCommuteWhatWeCanRL commuteFL (reverseFL toUnrec :> p) of
       (toP' :> p'  :> _excessUnrec) ->
           makeNewPending repo uw $ toPend +>+ reverseRL toP' +>+ p'

-- | Get a list of all files and directories in the working copy, including
-- boring files if necessary
listFiles :: Bool -> IO [String]
listFiles takeBoring =
  do
    nonboring <- considered emptyTree
    working <- expand =<< applyTreeFilter nonboring <$> readPlainTree "."
    return $ map (anchorPath "" . fst) $ list working
  where
    considered = if takeBoring
                 then const (return restrictDarcsdir)
                 else restrictBoring

-- | 'listUnregisteredFiles' returns the list of all non-boring unregistered
-- files in the repository.
listUnregisteredFiles :: Bool -> IO [String]
listUnregisteredFiles includeBoring =
    do unregd <- listFiles includeBoring
       regd <- listRegisteredFiles
       return $ unregd \\ regd -- (inefficient)

-- | 'listRegisteredFiles' returns the list of all registered files in the repository.
listRegisteredFiles :: IO [String]
listRegisteredFiles =
    do recorded <- expand =<< withRepository YesUseCache (RepoJob readRecordedAndPending)
       return $ map (anchorPath "" . fst) $ list recorded