diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,35 @@ +Darcs 2.12.0, 29 April 2016 + + * `darcs show dependencies`: export patch dependency graph as dot file (Ale Gadea) + * improvements in `record` output with irrelevant files (Ben Franksen) + * `darcs log -v --machine-readable`: show internal representation of + patches (including explicit dependencies). Remove patch viewing via the + `annotate` command. (Guillaume Hoffmann) + * `whatsnew -s` (and `status`) show conflicting files (Guillaume Hoffmann) + * honor "quiet" flag in command outputs (Ben Franksen) + * a single `show patch-index` command (Guillaume Hoffmann) + * remove deprecated aliases of show (Guillaume Hoffmann) + * handle file moves natively when importing from git (Owen Stephens) + * require GHC 7.6 (base > 4.6) and support GHC 8 (Ganesh Sittampalam) + * switch to sandi from dataenc (Daniil Frumin) + * remove hack to enable arbitrary protocols via env variables (Guillaume Hoffmann) + * fixed the following bugs: + + * 1807: clarify help of PAGER, DARCS_PAGER (Guillaume Hoffmann) + * 2258: improve patch index error message with suggestion (Guillaume Hoffmann) + * 2269: push hijack test to suspend time (Eric Kow) + * 2276: Keep track of patch hijack decisions (Eric Kow) + * 2138: report conflicting files in whatsnew -s (Guillaume Hoffmann) + * 2393: remove whatsnew functionality from annotate (Guillaume Hoffmann) + * 2400: use async package to keep track of unpack threads (Ben Franksen) + * 2459: fall back to writing the file if createLink fails (Ben Franksen) + * 2479: root dir most not be among the sources of a move (Ben Franksen) + * 2481: expose API for 'darcs diff' command (Ganesh Sittampalam) + * 2486: obliterate --not-in-remote -q should be more quiet (Ben Franksen) + * 2489: dequote filepaths while importing from git (Guillaume Hoffmann) + * 2494: output of darcs record with file arguments (Ben Franksen) + + Darcs 2.10.3, 29 January 2016 * implement weak repository hash and show it in "darcs show repo" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -46,3 +46,12 @@ Please send bug reports to . +Hacking +======= + +Please consult for +up-to-date information about contributing to Darcs. + +The wiki can be downloaded with the command: + + $ darcs clone --lazy http://darcs.net/darcs-wiki diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -4,9 +4,6 @@ -- portions copyright (c) 2008 David Roundy -- portions copyright (c) 2007-2009 Judah Jacobson -import Prelude hiding ( catch ) -import qualified Prelude - import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) diff --git a/containers-0.5.2.1/Darcs/Data/Map/Base.hs b/containers-0.5.2.1/Darcs/Data/Map/Base.hs deleted file mode 100644 --- a/containers-0.5.2.1/Darcs/Data/Map/Base.hs +++ /dev/null @@ -1,2791 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} -#endif -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 -{-# LANGUAGE Trustworthy #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Map.Base --- Copyright : (c) Daan Leijen 2002 --- (c) Andriy Palamarchuk 2008 --- License : BSD-style --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- An efficient implementation of maps from keys to values (dictionaries). --- --- Since many function names (but not the type name) clash with --- "Prelude" names, this module is usually imported @qualified@, e.g. --- --- > import Data.Map (Map) --- > import qualified Data.Map as Map --- --- The implementation of 'Map' is based on /size balanced/ binary trees (or --- trees of /bounded balance/) as described by: --- --- * Stephen Adams, \"/Efficient sets: a balancing act/\", --- Journal of Functional Programming 3(4):553-562, October 1993, --- . --- --- * J. Nievergelt and E.M. Reingold, --- \"/Binary search trees of bounded balance/\", --- SIAM journal of computing 2(1), March 1973. --- --- Note that the implementation is /left-biased/ -- the elements of a --- first argument are always preferred to the second, for example in --- 'union' or 'insert'. --- --- Operation comments contain the operation time complexity in --- the Big-O notation . ------------------------------------------------------------------------------ - --- [Note: Using INLINABLE] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- It is crucial to the performance that the functions specialize on the Ord --- type when possible. GHC 7.0 and higher does this by itself when it sees th --- unfolding of a function -- that is why all public functions are marked --- INLINABLE (that exposes the unfolding). - - --- [Note: Using INLINE] --- ~~~~~~~~~~~~~~~~~~~~ --- For other compilers and GHC pre 7.0, we mark some of the functions INLINE. --- We mark the functions that just navigate down the tree (lookup, insert, --- delete and similar). That navigation code gets inlined and thus specialized --- when possible. There is a price to pay -- code growth. The code INLINED is --- therefore only the tree navigation, all the real work (rebalancing) is not --- INLINED by using a NOINLINE. --- --- All methods marked INLINE have to be nonrecursive -- a 'go' function doing --- the real work is provided. - - --- [Note: Type of local 'go' function] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- If the local 'go' function uses an Ord class, it sometimes heap-allocates --- the Ord dictionary when the 'go' function does not have explicit type. --- In that case we give 'go' explicit type. But this slightly decrease --- performance, as the resulting 'go' function can float out to top level. - - --- [Note: Local 'go' functions and capturing] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- As opposed to IntMap, when 'go' function captures an argument, increased --- heap-allocation can occur: sometimes in a polymorphic function, the 'go' --- floats out of its enclosing function and then it heap-allocates the --- dictionary and the argument. Maybe it floats out too late and strictness --- analyzer cannot see that these could be passed on stack. --- --- For example, change 'member' so that its local 'go' function is not passing --- argument k and then look at the resulting code for hedgeInt. - - --- [Note: Order of constructors] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The order of constructors of Map matters when considering performance. --- Currently in GHC 7.0, when type has 2 constructors, a forward conditional --- jump is made when successfully matching second constructor. Successful match --- of first constructor results in the forward jump not taken. --- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip --- improves the benchmark by up to 10% on x86. - -module Darcs.Data.Map.Base ( - -- * Map type - Map(..) -- instance Eq,Show,Read - - -- * Operators - , (!), (\\) - - -- * Query - , null - , size - , member - , notMember - , lookup - , findWithDefault - , lookupLT - , lookupGT - , lookupLE - , lookupGE - - -- * Construction - , empty - , singleton - - -- ** Insertion - , insert - , insertWith - , insertWithKey - , insertLookupWithKey - - -- ** Delete\/Update - , delete - , adjust - , adjustWithKey - , update - , updateWithKey - , updateLookupWithKey - , alter - - -- * Combine - - -- ** Union - , union - , unionWith - , unionWithKey - , unions - , unionsWith - - -- ** Difference - , difference - , differenceWith - , differenceWithKey - - -- ** Intersection - , intersection - , intersectionWith - , intersectionWithKey - - -- ** Universal combining function - , mergeWithKey - - -- * Traversal - -- ** Map - , map - , mapWithKey - , traverseWithKey - , mapAccum - , mapAccumWithKey - , mapAccumRWithKey - , mapKeys - , mapKeysWith - , mapKeysMonotonic - - -- * Folds - , foldr - , foldl - , foldrWithKey - , foldlWithKey - -- ** Strict folds - , foldr' - , foldl' - , foldrWithKey' - , foldlWithKey' - - -- * Conversion - , elems - , keys - , assocs - , keysSet - , fromSet - - -- ** Lists - , toList - , fromList - , fromListWith - , fromListWithKey - - -- ** Ordered lists - , toAscList - , toDescList - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList - - -- * Filter - , filter - , filterWithKey - , partition - , partitionWithKey - - , mapMaybe - , mapMaybeWithKey - , mapEither - , mapEitherWithKey - - , split - , splitLookup - - -- * Submap - , isSubmapOf, isSubmapOfBy - , isProperSubmapOf, isProperSubmapOfBy - - -- * Indexed - , lookupIndex - , findIndex - , elemAt - , updateAt - , deleteAt - - -- * Min\/Max - , findMin - , findMax - , deleteMin - , deleteMax - , deleteFindMin - , deleteFindMax - , updateMin - , updateMax - , updateMinWithKey - , updateMaxWithKey - , minView - , maxView - , minViewWithKey - , maxViewWithKey - - -- * Debugging - , showTree - , showTreeWith - , valid - - -- Used by the strict version - , bin - , balance - , balanced - , balanceL - , balanceR - , delta - , join - , insertMax - , merge - , glue - , trim - , trimLookupLo - , foldlStrict - , MaybeS(..) - , filterGt - , filterLt - ) where - -import Control.Applicative (Applicative(..), (<$>)) -import Control.DeepSeq (NFData(rnf)) -import Data.Bits (shiftL, shiftR) -import qualified Data.Foldable as Foldable -import Data.Monoid (Monoid(..)) -import Darcs.Data.StrictPair -import Data.Traversable (Traversable(traverse)) -import Data.Typeable -import Prelude hiding (lookup, map, filter, foldr, foldl, null) - -import qualified Darcs.Data.Set.Base as Set - -#if __GLASGOW_HASKELL__ -import GHC.Exts ( build ) -import Text.Read -import Data.Data -#endif - --- Use macros to define strictness of functions. --- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter. --- We do not use BangPatterns, because they are not in any standard and we --- want the compilers to be compiled by as many compilers as possible. -#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined -#define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined -#define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined -#define STRICT_1_OF_4(fn) fn arg _ _ _ | arg `seq` False = undefined -#define STRICT_2_OF_4(fn) fn _ arg _ _ | arg `seq` False = undefined - -{-------------------------------------------------------------------- - Operators ---------------------------------------------------------------------} -infixl 9 !,\\ -- - --- | /O(log n)/. Find the value at a key. --- Calls 'error' when the element can not be found. --- --- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map --- > fromList [(5,'a'), (3,'b')] ! 5 == 'a' - -(!) :: Ord k => Map k a -> k -> a -(!) m k = find k m -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE (!) #-} -#endif - --- | Same as 'difference'. -(\\) :: Ord k => Map k a -> Map k b -> Map k a -m1 \\ m2 = difference m1 m2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE (\\) #-} -#endif - -{-------------------------------------------------------------------- - Size balanced trees. ---------------------------------------------------------------------} --- | A Map from keys @k@ to values @a@. - --- See Note: Order of constructors -data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a) - | Tip - -type Size = Int - -instance (Ord k) => Monoid (Map k v) where - mempty = empty - mappend = union - mconcat = unions - -#if __GLASGOW_HASKELL__ - -{-------------------------------------------------------------------- - A Data instance ---------------------------------------------------------------------} - --- This instance preserves data abstraction at the cost of inefficiency. --- We provide limited reflection services for the sake of data abstraction. - -instance (Data k, Data a, Ord k) => Data (Map k a) where - gfoldl f z m = z fromList `f` toList m - toConstr _ = fromListConstr - gunfold k z c = case constrIndex c of - 1 -> k (z fromList) - _ -> error "gunfold" - dataTypeOf _ = mapDataType - dataCast2 f = gcast2 f - -fromListConstr :: Constr -fromListConstr = mkConstr mapDataType "fromList" [] Prefix - -mapDataType :: DataType -mapDataType = mkDataType "Data.Map.Base.Map" [fromListConstr] - -#endif - -{-------------------------------------------------------------------- - Query ---------------------------------------------------------------------} --- | /O(1)/. Is the map empty? --- --- > Data.Map.null (empty) == True --- > Data.Map.null (singleton 1 'a') == False - -null :: Map k a -> Bool -null Tip = True -null (Bin {}) = False -{-# INLINE null #-} - --- | /O(1)/. The number of elements in the map. --- --- > size empty == 0 --- > size (singleton 1 'a') == 1 --- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3 - -size :: Map k a -> Int -size Tip = 0 -size (Bin sz _ _ _ _) = sz -{-# INLINE size #-} - - --- | /O(log n)/. Lookup the value at a key in the map. --- --- The function will return the corresponding value as @('Just' value)@, --- or 'Nothing' if the key isn't in the map. --- --- An example of using @lookup@: --- --- > import Prelude hiding (lookup) --- > import Data.Map --- > --- > employeeDept = fromList([("John","Sales"), ("Bob","IT")]) --- > deptCountry = fromList([("IT","USA"), ("Sales","France")]) --- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")]) --- > --- > employeeCurrency :: String -> Maybe String --- > employeeCurrency name = do --- > dept <- lookup name employeeDept --- > country <- lookup dept deptCountry --- > lookup country countryCurrency --- > --- > main = do --- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John")) --- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete")) --- --- The output of this program: --- --- > John's currency: Just "Euro" --- > Pete's currency: Nothing -lookup :: Ord k => k -> Map k a -> Maybe a -lookup = go - where - STRICT_1_OF_2(go) - go _ Tip = Nothing - go k (Bin _ kx x l r) = case compare k kx of - LT -> go k l - GT -> go k r - EQ -> Just x -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE lookup #-} -#else -{-# INLINE lookup #-} -#endif - --- | /O(log n)/. Is the key a member of the map? See also 'notMember'. --- --- > member 5 (fromList [(5,'a'), (3,'b')]) == True --- > member 1 (fromList [(5,'a'), (3,'b')]) == False -member :: Ord k => k -> Map k a -> Bool -member = go - where - STRICT_1_OF_2(go) - go _ Tip = False - go k (Bin _ kx _ l r) = case compare k kx of - LT -> go k l - GT -> go k r - EQ -> True -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE member #-} -#else -{-# INLINE member #-} -#endif - --- | /O(log n)/. Is the key not a member of the map? See also 'member'. --- --- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False --- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True - -notMember :: Ord k => k -> Map k a -> Bool -notMember k m = not $ member k m -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE notMember #-} -#else -{-# INLINE notMember #-} -#endif - --- | /O(log n)/. Find the value at a key. --- Calls 'error' when the element can not be found. -find :: Ord k => k -> Map k a -> a -find = go - where - STRICT_1_OF_2(go) - go _ Tip = error "Map.!: given key is not an element in the map" - go k (Bin _ kx x l r) = case compare k kx of - LT -> go k l - GT -> go k r - EQ -> x -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE find #-} -#else -{-# INLINE find #-} -#endif - --- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns --- the value at key @k@ or returns default value @def@ --- when the key is not in the map. --- --- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' --- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' -findWithDefault :: Ord k => a -> k -> Map k a -> a -findWithDefault = go - where - STRICT_2_OF_3(go) - go def _ Tip = def - go def k (Bin _ kx x l r) = case compare k kx of - LT -> go def k l - GT -> go def k r - EQ -> x -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE findWithDefault #-} -#else -{-# INLINE findWithDefault #-} -#endif - --- | /O(log n)/. Find largest key smaller than the given one and return the --- corresponding (key, value) pair. --- --- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing --- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') -lookupLT :: Ord k => k -> Map k v -> Maybe (k, v) -lookupLT = goNothing - where - STRICT_1_OF_2(goNothing) - goNothing _ Tip = Nothing - goNothing k (Bin _ kx x l r) | k <= kx = goNothing k l - | otherwise = goJust k kx x r - - STRICT_1_OF_4(goJust) - goJust _ kx' x' Tip = Just (kx', x') - goJust k kx' x' (Bin _ kx x l r) | k <= kx = goJust k kx' x' l - | otherwise = goJust k kx x r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE lookupLT #-} -#else -{-# INLINE lookupLT #-} -#endif - --- | /O(log n)/. Find smallest key greater than the given one and return the --- corresponding (key, value) pair. --- --- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') --- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing -lookupGT :: Ord k => k -> Map k v -> Maybe (k, v) -lookupGT = goNothing - where - STRICT_1_OF_2(goNothing) - goNothing _ Tip = Nothing - goNothing k (Bin _ kx x l r) | k < kx = goJust k kx x l - | otherwise = goNothing k r - - STRICT_1_OF_4(goJust) - goJust _ kx' x' Tip = Just (kx', x') - goJust k kx' x' (Bin _ kx x l r) | k < kx = goJust k kx x l - | otherwise = goJust k kx' x' r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE lookupGT #-} -#else -{-# INLINE lookupGT #-} -#endif - --- | /O(log n)/. Find largest key smaller or equal to the given one and return --- the corresponding (key, value) pair. --- --- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing --- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') --- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') -lookupLE :: Ord k => k -> Map k v -> Maybe (k, v) -lookupLE = goNothing - where - STRICT_1_OF_2(goNothing) - goNothing _ Tip = Nothing - goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goNothing k l - EQ -> Just (kx, x) - GT -> goJust k kx x r - - STRICT_1_OF_4(goJust) - goJust _ kx' x' Tip = Just (kx', x') - goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx' x' l - EQ -> Just (kx, x) - GT -> goJust k kx x r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE lookupLE #-} -#else -{-# INLINE lookupLE #-} -#endif - --- | /O(log n)/. Find smallest key greater or equal to the given one and return --- the corresponding (key, value) pair. --- --- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') --- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') --- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing -lookupGE :: Ord k => k -> Map k v -> Maybe (k, v) -lookupGE = goNothing - where - STRICT_1_OF_2(goNothing) - goNothing _ Tip = Nothing - goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l - EQ -> Just (kx, x) - GT -> goNothing k r - - STRICT_1_OF_4(goJust) - goJust _ kx' x' Tip = Just (kx', x') - goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l - EQ -> Just (kx, x) - GT -> goJust k kx' x' r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE lookupGE #-} -#else -{-# INLINE lookupGE #-} -#endif - -{-------------------------------------------------------------------- - Construction ---------------------------------------------------------------------} --- | /O(1)/. The empty map. --- --- > empty == fromList [] --- > size empty == 0 - -empty :: Map k a -empty = Tip -{-# INLINE empty #-} - --- | /O(1)/. A map with a single element. --- --- > singleton 1 'a' == fromList [(1, 'a')] --- > size (singleton 1 'a') == 1 - -singleton :: k -> a -> Map k a -singleton k x = Bin 1 k x Tip Tip -{-# INLINE singleton #-} - -{-------------------------------------------------------------------- - Insertion ---------------------------------------------------------------------} --- | /O(log n)/. Insert a new key and value in the map. --- If the key is already present in the map, the associated value is --- replaced with the supplied value. 'insert' is equivalent to --- @'insertWith' 'const'@. --- --- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] --- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] --- > insert 5 'x' empty == singleton 5 'x' - --- See Note: Type of local 'go' function -insert :: Ord k => k -> a -> Map k a -> Map k a -insert = go - where - go :: Ord k => k -> a -> Map k a -> Map k a - STRICT_1_OF_3(go) - go kx x Tip = singleton kx x - go kx x (Bin sz ky y l r) = - case compare kx ky of - LT -> balanceL ky y (go kx x l) r - GT -> balanceR ky y l (go kx x r) - EQ -> Bin sz kx x l r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE insert #-} -#else -{-# INLINE insert #-} -#endif - --- Insert a new key and value in the map if it is not already present. --- Used by `union`. - --- See Note: Type of local 'go' function -insertR :: Ord k => k -> a -> Map k a -> Map k a -insertR = go - where - go :: Ord k => k -> a -> Map k a -> Map k a - STRICT_1_OF_3(go) - go kx x Tip = singleton kx x - go kx x t@(Bin _ ky y l r) = - case compare kx ky of - LT -> balanceL ky y (go kx x l) r - GT -> balanceR ky y l (go kx x r) - EQ -> t -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE insertR #-} -#else -{-# INLINE insertR #-} -#endif - --- | /O(log n)/. Insert with a function, combining new value and old value. --- @'insertWith' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does --- not exist in the map. If the key does exist, the function will --- insert the pair @(key, f new_value old_value)@. --- --- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] --- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] --- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" - -insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a -insertWith f = insertWithKey (\_ x' y' -> f x' y') -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE insertWith #-} -#else -{-# INLINE insertWith #-} -#endif - --- | /O(log n)/. Insert with a function, combining key, new value and old value. --- @'insertWithKey' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does --- not exist in the map. If the key does exist, the function will --- insert the pair @(key,f key new_value old_value)@. --- Note that the key passed to f is the same key passed to 'insertWithKey'. --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] --- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] --- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" - --- See Note: Type of local 'go' function -insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a -insertWithKey = go - where - go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a - STRICT_2_OF_4(go) - go _ kx x Tip = singleton kx x - go f kx x (Bin sy ky y l r) = - case compare kx ky of - LT -> balanceL ky y (go f kx x l) r - GT -> balanceR ky y l (go f kx x r) - EQ -> Bin sy kx (f kx x y) l r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE insertWithKey #-} -#else -{-# INLINE insertWithKey #-} -#endif - --- | /O(log n)/. Combines insert operation with old value retrieval. --- The expression (@'insertLookupWithKey' f k x map@) --- is a pair where the first element is equal to (@'lookup' k map@) --- and the second element equal to (@'insertWithKey' f k x map@). --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) --- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) --- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") --- --- This is how to define @insertLookup@ using @insertLookupWithKey@: --- --- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t --- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) --- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) - --- See Note: Type of local 'go' function -insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a - -> (Maybe a, Map k a) -insertLookupWithKey = go - where - go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a) - STRICT_2_OF_4(go) - go _ kx x Tip = (Nothing, singleton kx x) - go f kx x (Bin sy ky y l r) = - case compare kx ky of - LT -> let (found, l') = go f kx x l - in (found, balanceL ky y l' r) - GT -> let (found, r') = go f kx x r - in (found, balanceR ky y l r') - EQ -> (Just y, Bin sy kx (f kx x y) l r) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE insertLookupWithKey #-} -#else -{-# INLINE insertLookupWithKey #-} -#endif - -{-------------------------------------------------------------------- - Deletion ---------------------------------------------------------------------} --- | /O(log n)/. Delete a key and its value from the map. When the key is not --- a member of the map, the original map is returned. --- --- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" --- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > delete 5 empty == empty - --- See Note: Type of local 'go' function -delete :: Ord k => k -> Map k a -> Map k a -delete = go - where - go :: Ord k => k -> Map k a -> Map k a - STRICT_1_OF_2(go) - go _ Tip = Tip - go k (Bin _ kx x l r) = - case compare k kx of - LT -> balanceR kx x (go k l) r - GT -> balanceL kx x l (go k r) - EQ -> glue l r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE delete #-} -#else -{-# INLINE delete #-} -#endif - --- | /O(log n)/. Update a value at a specific key with the result of the provided function. --- When the key is not --- a member of the map, the original map is returned. --- --- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] --- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > adjust ("new " ++) 7 empty == empty - -adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a -adjust f = adjustWithKey (\_ x -> f x) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE adjust #-} -#else -{-# INLINE adjust #-} -#endif - --- | /O(log n)/. Adjust a value at a specific key. When the key is not --- a member of the map, the original map is returned. --- --- > let f key x = (show key) ++ ":new " ++ x --- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] --- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > adjustWithKey f 7 empty == empty - -adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a -adjustWithKey f = updateWithKey (\k' x' -> Just (f k' x')) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE adjustWithKey #-} -#else -{-# INLINE adjustWithKey #-} -#endif - --- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ --- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is --- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. --- --- > let f x = if x == "a" then Just "new a" else Nothing --- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] --- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a -update f = updateWithKey (\_ x -> f x) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE update #-} -#else -{-# INLINE update #-} -#endif - --- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the --- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', --- the element is deleted. If it is (@'Just' y@), the key @k@ is bound --- to the new value @y@. --- --- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing --- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] --- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - --- See Note: Type of local 'go' function -updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a -updateWithKey = go - where - go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a - STRICT_2_OF_3(go) - go _ _ Tip = Tip - go f k(Bin sx kx x l r) = - case compare k kx of - LT -> balanceR kx x (go f k l) r - GT -> balanceL kx x l (go f k r) - EQ -> case f kx x of - Just x' -> Bin sx kx x' l r - Nothing -> glue l r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE updateWithKey #-} -#else -{-# INLINE updateWithKey #-} -#endif - --- | /O(log n)/. Lookup and update. See also 'updateWithKey'. --- The function returns changed value, if it is updated. --- Returns the original key value if the map entry is deleted. --- --- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing --- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")]) --- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) --- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") - --- See Note: Type of local 'go' function -updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a) -updateLookupWithKey = go - where - go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a) - STRICT_2_OF_3(go) - go _ _ Tip = (Nothing,Tip) - go f k (Bin sx kx x l r) = - case compare k kx of - LT -> let (found,l') = go f k l in (found,balanceR kx x l' r) - GT -> let (found,r') = go f k r in (found,balanceL kx x l r') - EQ -> case f kx x of - Just x' -> (Just x',Bin sx kx x' l r) - Nothing -> (Just x,glue l r) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE updateLookupWithKey #-} -#else -{-# INLINE updateLookupWithKey #-} -#endif - --- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. --- 'alter' can be used to insert, delete, or update a value in a 'Map'. --- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. --- --- > let f _ = Nothing --- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" --- > --- > let f _ = Just "c" --- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")] --- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")] - --- See Note: Type of local 'go' function -alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a -alter = go - where - go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a - STRICT_2_OF_3(go) - go f k Tip = case f Nothing of - Nothing -> Tip - Just x -> singleton k x - - go f k (Bin sx kx x l r) = case compare k kx of - LT -> balance kx x (go f k l) r - GT -> balance kx x l (go f k r) - EQ -> case f (Just x) of - Just x' -> Bin sx kx x' l r - Nothing -> glue l r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE alter #-} -#else -{-# INLINE alter #-} -#endif - -{-------------------------------------------------------------------- - Indexing ---------------------------------------------------------------------} --- | /O(log n)/. Return the /index/ of a key, which is its zero-based index in --- the sequence sorted by keys. The index is a number from /0/ up to, but not --- including, the 'size' of the map. Calls 'error' when the key is not --- a 'member' of the map. --- --- > findIndex 2 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map --- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0 --- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1 --- > findIndex 6 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map - --- See Note: Type of local 'go' function -findIndex :: Ord k => k -> Map k a -> Int -findIndex = go 0 - where - go :: Ord k => Int -> k -> Map k a -> Int - STRICT_1_OF_3(go) - STRICT_2_OF_3(go) - go _ _ Tip = error "Map.findIndex: element is not in the map" - go idx k (Bin _ kx _ l r) = case compare k kx of - LT -> go idx k l - GT -> go (idx + size l + 1) k r - EQ -> idx + size l -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE findIndex #-} -#endif - --- | /O(log n)/. Lookup the /index/ of a key, which is its zero-based index in --- the sequence sorted by keys. The index is a number from /0/ up to, but not --- including, the 'size' of the map. --- --- > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")])) == False --- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0 --- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1 --- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")])) == False - --- See Note: Type of local 'go' function -lookupIndex :: Ord k => k -> Map k a -> Maybe Int -lookupIndex = go 0 - where - go :: Ord k => Int -> k -> Map k a -> Maybe Int - STRICT_1_OF_3(go) - STRICT_2_OF_3(go) - go _ _ Tip = Nothing - go idx k (Bin _ kx _ l r) = case compare k kx of - LT -> go idx k l - GT -> go (idx + size l + 1) k r - EQ -> Just $! idx + size l -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE lookupIndex #-} -#endif - --- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based --- index in the sequence sorted by keys. If the /index/ is out of range (less --- than zero, greater or equal to 'size' of the map), 'error' is called. --- --- > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b") --- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a") --- > elemAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range - -elemAt :: Int -> Map k a -> (k,a) -STRICT_1_OF_2(elemAt) -elemAt _ Tip = error "Map.elemAt: index out of range" -elemAt i (Bin _ kx x l r) - = case compare i sizeL of - LT -> elemAt i l - GT -> elemAt (i-sizeL-1) r - EQ -> (kx,x) - where - sizeL = size l - --- | /O(log n)/. Update the element at /index/, i.e. by its zero-based index in --- the sequence sorted by keys. If the /index/ is out of range (less than zero, --- greater or equal to 'size' of the map), 'error' is called. --- --- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")] --- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")] --- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range --- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range --- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" --- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" --- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range --- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range - -updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a -updateAt f i t = i `seq` - case t of - Tip -> error "Map.updateAt: index out of range" - Bin sx kx x l r -> case compare i sizeL of - LT -> balanceR kx x (updateAt f i l) r - GT -> balanceL kx x l (updateAt f (i-sizeL-1) r) - EQ -> case f kx x of - Just x' -> Bin sx kx x' l r - Nothing -> glue l r - where - sizeL = size l - --- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in --- the sequence sorted by keys. If the /index/ is out of range (less than zero, --- greater or equal to 'size' of the map), 'error' is called. --- --- > deleteAt 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" --- > deleteAt 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" --- > deleteAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range --- > deleteAt (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range - -deleteAt :: Int -> Map k a -> Map k a -deleteAt i t = i `seq` - case t of - Tip -> error "Map.deleteAt: index out of range" - Bin _ kx x l r -> case compare i sizeL of - LT -> balanceR kx x (deleteAt i l) r - GT -> balanceL kx x l (deleteAt (i-sizeL-1) r) - EQ -> glue l r - where - sizeL = size l - - -{-------------------------------------------------------------------- - Minimal, Maximal ---------------------------------------------------------------------} --- | /O(log n)/. The minimal key of the map. Calls 'error' if the map is empty. --- --- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b") --- > findMin empty Error: empty map has no minimal element - -findMin :: Map k a -> (k,a) -findMin (Bin _ kx x Tip _) = (kx,x) -findMin (Bin _ _ _ l _) = findMin l -findMin Tip = error "Map.findMin: empty map has no minimal element" - --- | /O(log n)/. The maximal key of the map. Calls 'error' if the map is empty. --- --- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a") --- > findMax empty Error: empty map has no maximal element - -findMax :: Map k a -> (k,a) -findMax (Bin _ kx x _ Tip) = (kx,x) -findMax (Bin _ _ _ _ r) = findMax r -findMax Tip = error "Map.findMax: empty map has no maximal element" - --- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty. --- --- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")] --- > deleteMin empty == empty - -deleteMin :: Map k a -> Map k a -deleteMin (Bin _ _ _ Tip r) = r -deleteMin (Bin _ kx x l r) = balanceR kx x (deleteMin l) r -deleteMin Tip = Tip - --- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty. --- --- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")] --- > deleteMax empty == empty - -deleteMax :: Map k a -> Map k a -deleteMax (Bin _ _ _ l Tip) = l -deleteMax (Bin _ kx x l r) = balanceL kx x l (deleteMax r) -deleteMax Tip = Tip - --- | /O(log n)/. Update the value at the minimal key. --- --- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] --- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -updateMin :: (a -> Maybe a) -> Map k a -> Map k a -updateMin f m - = updateMinWithKey (\_ x -> f x) m - --- | /O(log n)/. Update the value at the maximal key. --- --- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] --- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" - -updateMax :: (a -> Maybe a) -> Map k a -> Map k a -updateMax f m - = updateMaxWithKey (\_ x -> f x) m - - --- | /O(log n)/. Update the value at the minimal key. --- --- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] --- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a -updateMinWithKey _ Tip = Tip -updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of - Nothing -> r - Just x' -> Bin sx kx x' Tip r -updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r - --- | /O(log n)/. Update the value at the maximal key. --- --- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] --- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" - -updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a -updateMaxWithKey _ Tip = Tip -updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of - Nothing -> l - Just x' -> Bin sx kx x' l Tip -updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r) - --- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and --- the map stripped of that element, or 'Nothing' if passed an empty map. --- --- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a") --- > minViewWithKey empty == Nothing - -minViewWithKey :: Map k a -> Maybe ((k,a), Map k a) -minViewWithKey Tip = Nothing -minViewWithKey x = Just (deleteFindMin x) - --- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and --- the map stripped of that element, or 'Nothing' if passed an empty map. --- --- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b") --- > maxViewWithKey empty == Nothing - -maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a) -maxViewWithKey Tip = Nothing -maxViewWithKey x = Just (deleteFindMax x) - --- | /O(log n)/. Retrieves the value associated with minimal key of the --- map, and the map stripped of that element, or 'Nothing' if passed an --- empty map. --- --- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a") --- > minView empty == Nothing - -minView :: Map k a -> Maybe (a, Map k a) -minView Tip = Nothing -minView x = Just (first snd $ deleteFindMin x) - --- | /O(log n)/. Retrieves the value associated with maximal key of the --- map, and the map stripped of that element, or 'Nothing' if passed an --- --- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b") --- > maxView empty == Nothing - -maxView :: Map k a -> Maybe (a, Map k a) -maxView Tip = Nothing -maxView x = Just (first snd $ deleteFindMax x) - --- Update the 1st component of a tuple (special case of Control.Arrow.first) -first :: (a -> b) -> (a,c) -> (b,c) -first f (x,y) = (f x, y) - -{-------------------------------------------------------------------- - Union. ---------------------------------------------------------------------} --- | The union of a list of maps: --- (@'unions' == 'Prelude.foldl' 'union' 'empty'@). --- --- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] --- > == fromList [(3, "b"), (5, "a"), (7, "C")] --- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] --- > == fromList [(3, "B3"), (5, "A3"), (7, "C")] - -unions :: Ord k => [Map k a] -> Map k a -unions ts - = foldlStrict union empty ts -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE unions #-} -#endif - --- | The union of a list of maps, with a combining operation: --- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@). --- --- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] --- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] - -unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a -unionsWith f ts - = foldlStrict (unionWith f) empty ts -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE unionsWith #-} -#endif - --- | /O(n+m)/. --- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. --- It prefers @t1@ when duplicate keys are encountered, --- i.e. (@'union' == 'unionWith' 'const'@). --- The implementation uses the efficient /hedge-union/ algorithm. --- --- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")] - -union :: Ord k => Map k a -> Map k a -> Map k a -union Tip t2 = t2 -union t1 Tip = t1 -union t1 t2 = hedgeUnion NothingS NothingS t1 t2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE union #-} -#endif - --- left-biased hedge union -hedgeUnion :: Ord a => MaybeS a -> MaybeS a -> Map a b -> Map a b -> Map a b -hedgeUnion _ _ t1 Tip = t1 -hedgeUnion blo bhi Tip (Bin _ kx x l r) = join kx x (filterGt blo l) (filterLt bhi r) -hedgeUnion _ _ t1 (Bin _ kx x Tip Tip) = insertR kx x t1 -- According to benchmarks, this special case increases - -- performance up to 30%. It does not help in difference or intersection. -hedgeUnion blo bhi (Bin _ kx x l r) t2 = join kx x (hedgeUnion blo bmi l (trim blo bmi t2)) - (hedgeUnion bmi bhi r (trim bmi bhi t2)) - where bmi = JustS kx -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE hedgeUnion #-} -#endif - -{-------------------------------------------------------------------- - Union with a combining function ---------------------------------------------------------------------} --- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. --- --- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] - -unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a -unionWith f m1 m2 - = unionWithKey (\_ x y -> f x y) m1 m2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE unionWith #-} -#endif - --- | /O(n+m)/. --- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. --- --- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value --- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] - -unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a -unionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) id id t1 t2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE unionWithKey #-} -#endif - -{-------------------------------------------------------------------- - Difference ---------------------------------------------------------------------} --- | /O(n+m)/. Difference of two maps. --- Return elements of the first map not existing in the second map. --- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. --- --- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b" - -difference :: Ord k => Map k a -> Map k b -> Map k a -difference Tip _ = Tip -difference t1 Tip = t1 -difference t1 t2 = hedgeDiff NothingS NothingS t1 t2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE difference #-} -#endif - -hedgeDiff :: Ord a => MaybeS a -> MaybeS a -> Map a b -> Map a c -> Map a b -hedgeDiff _ _ Tip _ = Tip -hedgeDiff blo bhi (Bin _ kx x l r) Tip = join kx x (filterGt blo l) (filterLt bhi r) -hedgeDiff blo bhi t (Bin _ kx _ l r) = merge (hedgeDiff blo bmi (trim blo bmi t) l) - (hedgeDiff bmi bhi (trim bmi bhi t) r) - where bmi = JustS kx -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE hedgeDiff #-} -#endif - --- | /O(n+m)/. Difference with a combining function. --- When two equal keys are --- encountered, the combining function is applied to the values of these keys. --- If it returns 'Nothing', the element is discarded (proper set difference). If --- it returns (@'Just' y@), the element is updated with a new value @y@. --- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. --- --- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing --- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) --- > == singleton 3 "b:B" - -differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a -differenceWith f m1 m2 - = differenceWithKey (\_ x y -> f x y) m1 m2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE differenceWith #-} -#endif - --- | /O(n+m)/. Difference with a combining function. When two equal keys are --- encountered, the combining function is applied to the key and both values. --- If it returns 'Nothing', the element is discarded (proper set difference). If --- it returns (@'Just' y@), the element is updated with a new value @y@. --- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. --- --- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing --- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) --- > == singleton 3 "3:b|B" - -differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a -differenceWithKey f t1 t2 = mergeWithKey f id (const Tip) t1 t2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE differenceWithKey #-} -#endif - - -{-------------------------------------------------------------------- - Intersection ---------------------------------------------------------------------} --- | /O(n+m)/. Intersection of two maps. --- Return data in the first map for the keys existing in both maps. --- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). --- The implementation uses an efficient /hedge/ algorithm comparable with --- /hedge-union/. --- --- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a" - -intersection :: Ord k => Map k a -> Map k b -> Map k a -intersection Tip _ = Tip -intersection _ Tip = Tip -intersection t1 t2 = hedgeInt NothingS NothingS t1 t2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE intersection #-} -#endif - -hedgeInt :: Ord k => MaybeS k -> MaybeS k -> Map k a -> Map k b -> Map k a -hedgeInt _ _ _ Tip = Tip -hedgeInt _ _ Tip _ = Tip -hedgeInt blo bhi (Bin _ kx x l r) t2 = let l' = hedgeInt blo bmi l (trim blo bmi t2) - r' = hedgeInt bmi bhi r (trim bmi bhi t2) - in if kx `member` t2 then join kx x l' r' else merge l' r' - where bmi = JustS kx -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE hedgeInt #-} -#endif - --- | /O(n+m)/. Intersection with a combining function. The implementation uses --- an efficient /hedge/ algorithm comparable with /hedge-union/. --- --- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" - -intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c -intersectionWith f m1 m2 - = intersectionWithKey (\_ x y -> f x y) m1 m2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE intersectionWith #-} -#endif - --- | /O(n+m)/. Intersection with a combining function. The implementation uses --- an efficient /hedge/ algorithm comparable with /hedge-union/. --- --- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar --- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" - - -intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c -intersectionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) (const Tip) (const Tip) t1 t2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE intersectionWithKey #-} -#endif - - -{-------------------------------------------------------------------- - MergeWithKey ---------------------------------------------------------------------} - --- | /O(n+m)/. A high-performance universal combining function. This function --- is used to define 'unionWith', 'unionWithKey', 'differenceWith', --- 'differenceWithKey', 'intersectionWith', 'intersectionWithKey' and can be --- used to define other custom combine functions. --- --- Please make sure you know what is going on when using 'mergeWithKey', --- otherwise you can be surprised by unexpected code growth or even --- corruption of the data structure. --- --- When 'mergeWithKey' is given three arguments, it is inlined to the call --- site. You should therefore use 'mergeWithKey' only to define your custom --- combining functions. For example, you could define 'unionWithKey', --- 'differenceWithKey' and 'intersectionWithKey' as --- --- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2 --- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2 --- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2 --- --- When calling @'mergeWithKey' combine only1 only2@, a function combining two --- 'IntMap's is created, such that --- --- * if a key is present in both maps, it is passed with both corresponding --- values to the @combine@ function. Depending on the result, the key is either --- present in the result with specified value, or is left out; --- --- * a nonempty subtree present only in the first map is passed to @only1@ and --- the output is added to the result; --- --- * a nonempty subtree present only in the second map is passed to @only2@ and --- the output is added to the result. --- --- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/. --- The values can be modified arbitrarily. Most common variants of @only1@ and --- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or --- @'filterWithKey' f@ could be used for any @f@. - -mergeWithKey :: Ord k => (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c) - -> Map k a -> Map k b -> Map k c -mergeWithKey f g1 g2 = go - where - go Tip t2 = g2 t2 - go t1 Tip = g1 t1 - go t1 t2 = hedgeMerge NothingS NothingS t1 t2 - - hedgeMerge _ _ t1 Tip = g1 t1 - hedgeMerge blo bhi Tip (Bin _ kx x l r) = g2 $ join kx x (filterGt blo l) (filterLt bhi r) - hedgeMerge blo bhi (Bin _ kx x l r) t2 = let l' = hedgeMerge blo bmi l (trim blo bmi t2) - (found, trim_t2) = trimLookupLo kx bhi t2 - r' = hedgeMerge bmi bhi r trim_t2 - in case found of - Nothing -> case g1 (singleton kx x) of - Tip -> merge l' r' - (Bin _ _ x' Tip Tip) -> join kx x' l' r' - _ -> error "mergeWithKey: Given function only1 does not fulfil required conditions (see documentation)" - Just x2 -> case f kx x x2 of - Nothing -> merge l' r' - Just x' -> join kx x' l' r' - where bmi = JustS kx -{-# INLINE mergeWithKey #-} - -{-------------------------------------------------------------------- - Submap ---------------------------------------------------------------------} --- | /O(n+m)/. --- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). --- -isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool -isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE isSubmapOf #-} -#endif - -{- | /O(n+m)/. - The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if - all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when - applied to their respective values. For example, the following - expressions are all 'True': - - > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) - > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) - > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)]) - - But the following are all 'False': - - > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)]) - > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) - > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)]) - - --} -isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool -isSubmapOfBy f t1 t2 - = (size t1 <= size t2) && (submap' f t1 t2) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE isSubmapOfBy #-} -#endif - -submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool -submap' _ Tip _ = True -submap' _ _ Tip = False -submap' f (Bin _ kx x l r) t - = case found of - Nothing -> False - Just y -> f x y && submap' f l lt && submap' f r gt - where - (lt,found,gt) = splitLookup kx t -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE submap' #-} -#endif - --- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). --- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). -isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool -isProperSubmapOf m1 m2 - = isProperSubmapOfBy (==) m1 m2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE isProperSubmapOf #-} -#endif - -{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). - The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when - @m1@ and @m2@ are not equal, - all keys in @m1@ are in @m2@, and when @f@ returns 'True' when - applied to their respective values. For example, the following - expressions are all 'True': - - > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - - But the following are all 'False': - - > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) - > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) - > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - - --} -isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool -isProperSubmapOfBy f t1 t2 - = (size t1 < size t2) && (submap' f t1 t2) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE isProperSubmapOfBy #-} -#endif - -{-------------------------------------------------------------------- - Filter and partition ---------------------------------------------------------------------} --- | /O(n)/. Filter all values that satisfy the predicate. --- --- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" --- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty --- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty - -filter :: (a -> Bool) -> Map k a -> Map k a -filter p m - = filterWithKey (\_ x -> p x) m - --- | /O(n)/. Filter all keys\/values that satisfy the predicate. --- --- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a -filterWithKey _ Tip = Tip -filterWithKey p (Bin _ kx x l r) - | p kx x = join kx x (filterWithKey p l) (filterWithKey p r) - | otherwise = merge (filterWithKey p l) (filterWithKey p r) - --- | /O(n)/. Partition the map according to a predicate. The first --- map contains all elements that satisfy the predicate, the second all --- elements that fail the predicate. See also 'split'. --- --- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a") --- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty) --- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")]) - -partition :: (a -> Bool) -> Map k a -> (Map k a,Map k a) -partition p m - = partitionWithKey (\_ x -> p x) m - --- | /O(n)/. Partition the map according to a predicate. The first --- map contains all elements that satisfy the predicate, the second all --- elements that fail the predicate. See also 'split'. --- --- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b") --- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty) --- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")]) - -partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a,Map k a) -partitionWithKey p0 t0 = toPair $ go p0 t0 - where - go _ Tip = (Tip :*: Tip) - go p (Bin _ kx x l r) - | p kx x = join kx x l1 r1 :*: merge l2 r2 - | otherwise = merge l1 r1 :*: join kx x l2 r2 - where - (l1 :*: l2) = go p l - (r1 :*: r2) = go p r - --- | /O(n)/. Map values and collect the 'Just' results. --- --- > let f x = if x == "a" then Just "new a" else Nothing --- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" - -mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b -mapMaybe f = mapMaybeWithKey (\_ x -> f x) - --- | /O(n)/. Map keys\/values and collect the 'Just' results. --- --- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing --- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" - -mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b -mapMaybeWithKey _ Tip = Tip -mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of - Just y -> join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r) - Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r) - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. --- --- > let f a = if a < "c" then Left a else Right a --- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) --- > --- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) - -mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c) -mapEither f m - = mapEitherWithKey (\_ x -> f x) m - --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. --- --- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) --- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) --- > --- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) - -mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c) -mapEitherWithKey f0 t0 = toPair $ go f0 t0 - where - go _ Tip = (Tip :*: Tip) - go f (Bin _ kx x l r) = case f kx x of - Left y -> join kx y l1 r1 :*: merge l2 r2 - Right z -> merge l1 r1 :*: join kx z l2 r2 - where - (l1 :*: l2) = go f l - (r1 :*: r2) = go f r - -{-------------------------------------------------------------------- - Mapping ---------------------------------------------------------------------} --- | /O(n)/. Map a function over all values in the map. --- --- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] - -map :: (a -> b) -> Map k a -> Map k b -map _ Tip = Tip -map f (Bin sx kx x l r) = Bin sx kx (f x) (map f l) (map f r) - --- | /O(n)/. Map a function over all values in the map. --- --- > let f key x = (show key) ++ ":" ++ x --- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] - -mapWithKey :: (k -> a -> b) -> Map k a -> Map k b -mapWithKey _ Tip = Tip -mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r) - --- | /O(n)/. --- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ --- That is, behaves exactly like a regular 'traverse' except that the traversing --- function also has access to the key associated with a value. --- --- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) --- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing -{-# INLINE traverseWithKey #-} -traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b) -traverseWithKey f = go - where - go Tip = pure Tip - go (Bin s k v l r) - = flip (Bin s k) <$> go l <*> f k v <*> go r - --- | /O(n)/. The function 'mapAccum' threads an accumulating --- argument through the map in ascending order of keys. --- --- > let f a b = (a ++ b, b ++ "X") --- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) - -mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) -mapAccum f a m - = mapAccumWithKey (\a' _ x' -> f a' x') a m - --- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating --- argument through the map in ascending order of keys. --- --- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") --- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) - -mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) -mapAccumWithKey f a t - = mapAccumL f a t - --- | /O(n)/. The function 'mapAccumL' threads an accumulating --- argument through the map in ascending order of keys. -mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) -mapAccumL _ a Tip = (a,Tip) -mapAccumL f a (Bin sx kx x l r) = - let (a1,l') = mapAccumL f a l - (a2,x') = f a1 kx x - (a3,r') = mapAccumL f a2 r - in (a3,Bin sx kx x' l' r') - --- | /O(n)/. The function 'mapAccumR' threads an accumulating --- argument through the map in descending order of keys. -mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) -mapAccumRWithKey _ a Tip = (a,Tip) -mapAccumRWithKey f a (Bin sx kx x l r) = - let (a1,r') = mapAccumRWithKey f a r - (a2,x') = f a1 kx x - (a3,l') = mapAccumRWithKey f a2 l - in (a3,Bin sx kx x' l' r') - --- | /O(n*log n)/. --- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the value at the greatest of the --- original keys is retained. --- --- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")] --- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c" --- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c" - -mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a -mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) [] -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE mapKeys #-} -#endif - --- | /O(n*log n)/. --- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the associated values will be --- combined using @c@. --- --- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" --- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" - -mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a -mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE mapKeysWith #-} -#endif - - --- | /O(n)/. --- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ --- is strictly monotonic. --- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. --- /The precondition is not checked./ --- Semi-formally, we have: --- --- > and [x < y ==> f x < f y | x <- ls, y <- ls] --- > ==> mapKeysMonotonic f s == mapKeys f s --- > where ls = keys s --- --- This means that @f@ maps distinct original keys to distinct resulting keys. --- This function has better performance than 'mapKeys'. --- --- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")] --- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True --- > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False - -mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a -mapKeysMonotonic _ Tip = Tip -mapKeysMonotonic f (Bin sz k x l r) = - Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r) - -{-------------------------------------------------------------------- - Folds ---------------------------------------------------------------------} - --- | /O(n)/. Fold the values in the map using the given right-associative --- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. --- --- For example, --- --- > elems map = foldr (:) [] map --- --- > let f a len = len + (length a) --- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 -foldr :: (a -> b -> b) -> b -> Map k a -> b -foldr f z = go z - where - go z' Tip = z' - go z' (Bin _ _ x l r) = go (f x (go z' r)) l -{-# INLINE foldr #-} - --- | /O(n)/. A strict version of 'foldr'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldr' :: (a -> b -> b) -> b -> Map k a -> b -foldr' f z = go z - where - STRICT_1_OF_2(go) - go z' Tip = z' - go z' (Bin _ _ x l r) = go (f x (go z' r)) l -{-# INLINE foldr' #-} - --- | /O(n)/. Fold the values in the map using the given left-associative --- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. --- --- For example, --- --- > elems = reverse . foldl (flip (:)) [] --- --- > let f len a = len + (length a) --- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 -foldl :: (a -> b -> a) -> a -> Map k b -> a -foldl f z = go z - where - go z' Tip = z' - go z' (Bin _ _ x l r) = go (f (go z' l) x) r -{-# INLINE foldl #-} - --- | /O(n)/. A strict version of 'foldl'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldl' :: (a -> b -> a) -> a -> Map k b -> a -foldl' f z = go z - where - STRICT_1_OF_2(go) - go z' Tip = z' - go z' (Bin _ _ x l r) = go (f (go z' l) x) r -{-# INLINE foldl' #-} - --- | /O(n)/. Fold the keys and values in the map using the given right-associative --- binary operator, such that --- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. --- --- For example, --- --- > keys map = foldrWithKey (\k x ks -> k:ks) [] map --- --- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" --- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" -foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b -foldrWithKey f z = go z - where - go z' Tip = z' - go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l -{-# INLINE foldrWithKey #-} - --- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b -foldrWithKey' f z = go z - where - STRICT_1_OF_2(go) - go z' Tip = z' - go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l -{-# INLINE foldrWithKey' #-} - --- | /O(n)/. Fold the keys and values in the map using the given left-associative --- binary operator, such that --- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. --- --- For example, --- --- > keys = reverse . foldlWithKey (\ks k x -> k:ks) [] --- --- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" --- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)" -foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a -foldlWithKey f z = go z - where - go z' Tip = z' - go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r -{-# INLINE foldlWithKey #-} - --- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a -foldlWithKey' f z = go z - where - STRICT_1_OF_2(go) - go z' Tip = z' - go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r -{-# INLINE foldlWithKey' #-} - -{-------------------------------------------------------------------- - List variations ---------------------------------------------------------------------} --- | /O(n)/. --- Return all elements of the map in the ascending order of their keys. --- Subject to list fusion. --- --- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"] --- > elems empty == [] - -elems :: Map k a -> [a] -elems = foldr (:) [] - --- | /O(n)/. Return all keys of the map in ascending order. Subject to list --- fusion. --- --- > keys (fromList [(5,"a"), (3,"b")]) == [3,5] --- > keys empty == [] - -keys :: Map k a -> [k] -keys = foldrWithKey (\k _ ks -> k : ks) [] - --- | /O(n)/. An alias for 'toAscList'. Return all key\/value pairs in the map --- in ascending key order. Subject to list fusion. --- --- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] --- > assocs empty == [] - -assocs :: Map k a -> [(k,a)] -assocs m - = toAscList m - --- | /O(n)/. The set of all keys of the map. --- --- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5] --- > keysSet empty == Data.Set.empty - -keysSet :: Map k a -> Set.Set k -keysSet Tip = Set.Tip -keysSet (Bin sz kx _ l r) = Set.Bin sz kx (keysSet l) (keysSet r) - --- | /O(n)/. Build a map from a set of keys and a function which for each key --- computes its value. --- --- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] --- > fromSet undefined Data.Set.empty == empty - -fromSet :: (k -> a) -> Set.Set k -> Map k a -fromSet _ Set.Tip = Tip -fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r) - -{-------------------------------------------------------------------- - Lists - use [foldlStrict] to reduce demand on the control-stack ---------------------------------------------------------------------} --- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'. --- If the list contains more than one value for the same key, the last value --- for the key is retained. --- --- If the keys of the list are ordered, linear-time implementation is used, --- with the performance equal to 'fromDistinctAscList'. --- --- > fromList [] == empty --- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] --- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] - --- For some reason, when 'singleton' is used in fromList or in --- create, it is not inlined, so we inline it manually. -fromList :: Ord k => [(k,a)] -> Map k a -fromList [] = Tip -fromList [(kx, x)] = Bin 1 kx x Tip Tip -fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = fromList' (Bin 1 kx0 x0 Tip Tip) xs0 - | otherwise = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0 - where - not_ordered _ [] = False - not_ordered kx ((ky,_) : _) = kx >= ky - {-# INLINE not_ordered #-} - - fromList' t0 xs = foldlStrict ins t0 xs - where ins t (k,x) = insert k x t - - STRICT_1_OF_3(go) - go _ t [] = t - go _ t [(kx, x)] = insertMax kx x t - go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs - | otherwise = case create s xss of - (r, ys, []) -> go (s `shiftL` 1) (join kx x l r) ys - (r, _, ys) -> fromList' (join kx x l r) ys - - -- The create is returning a triple (tree, xs, ys). Both xs and ys - -- represent not yet processed elements and only one of them can be nonempty. - -- If ys is nonempty, the keys in ys are not ordered with respect to tree - -- and must be inserted using fromList'. Otherwise the keys have been - -- ordered so far. - STRICT_1_OF_2(create) - create _ [] = (Tip, [], []) - create s xs@(xp : xss) - | s == 1 = case xp of (kx, x) | not_ordered kx xss -> (Bin 1 kx x Tip Tip, [], xss) - | otherwise -> (Bin 1 kx x Tip Tip, xss, []) - | otherwise = case create (s `shiftR` 1) xs of - res@(_, [], _) -> res - (l, [(ky, y)], zs) -> (insertMax ky y l, [], zs) - (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys) - | otherwise -> case create (s `shiftR` 1) yss of - (r, zs, ws) -> (join ky y l r, zs, ws) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromList #-} -#endif - --- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. --- --- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] --- > fromListWith (++) [] == empty - -fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a -fromListWith f xs - = fromListWithKey (\_ x y -> f x y) xs -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromListWith #-} -#endif - --- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. --- --- > let f k a1 a2 = (show k) ++ a1 ++ a2 --- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")] --- > fromListWithKey f [] == empty - -fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a -fromListWithKey f xs - = foldlStrict ins empty xs - where - ins t (k,x) = insertWithKey f k x t -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromListWithKey #-} -#endif - --- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list fusion. --- --- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] --- > toList empty == [] - -toList :: Map k a -> [(k,a)] -toList = toAscList - --- | /O(n)/. Convert the map to a list of key\/value pairs where the keys are --- in ascending order. Subject to list fusion. --- --- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] - -toAscList :: Map k a -> [(k,a)] -toAscList = foldrWithKey (\k x xs -> (k,x):xs) [] - --- | /O(n)/. Convert the map to a list of key\/value pairs where the keys --- are in descending order. Subject to list fusion. --- --- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")] - -toDescList :: Map k a -> [(k,a)] -toDescList = foldlWithKey (\xs k x -> (k,x):xs) [] - --- List fusion for the list generating functions. -#if __GLASGOW_HASKELL__ --- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion. --- They are important to convert unfused methods back, see mapFB in prelude. -foldrFB :: (k -> a -> b -> b) -> b -> Map k a -> b -foldrFB = foldrWithKey -{-# INLINE[0] foldrFB #-} -foldlFB :: (a -> k -> b -> a) -> a -> Map k b -> a -foldlFB = foldlWithKey -{-# INLINE[0] foldlFB #-} - --- Inline assocs and toList, so that we need to fuse only toAscList. -{-# INLINE assocs #-} -{-# INLINE toList #-} - --- The fusion is enabled up to phase 2 included. If it does not succeed, --- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to --- elems,keys,to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were --- used in a list fusion, otherwise it would go away in phase 1), and let compiler --- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to --- inline it before phase 0, otherwise the fusion rules would not fire at all. -{-# NOINLINE[0] elems #-} -{-# NOINLINE[0] keys #-} -{-# NOINLINE[0] toAscList #-} -{-# NOINLINE[0] toDescList #-} -{-# RULES "Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-} -{-# RULES "Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-} -{-# RULES "Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-} -{-# RULES "Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-} -{-# RULES "Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-} -{-# RULES "Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-} -{-# RULES "Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-} -{-# RULES "Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-} -#endif - -{-------------------------------------------------------------------- - Building trees from ascending/descending lists can be done in linear time. - - Note that if [xs] is ascending that: - fromAscList xs == fromList xs - fromAscListWith f xs == fromListWith f xs ---------------------------------------------------------------------} --- | /O(n)/. Build a map from an ascending list in linear time. --- /The precondition (input list is ascending) is not checked./ --- --- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] --- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] --- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True --- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False - -fromAscList :: Eq k => [(k,a)] -> Map k a -fromAscList xs - = fromAscListWithKey (\_ x _ -> x) xs -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromAscList #-} -#endif - --- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. --- /The precondition (input list is ascending) is not checked./ --- --- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] --- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True --- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False - -fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a -fromAscListWith f xs - = fromAscListWithKey (\_ x y -> f x y) xs -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromAscListWith #-} -#endif - --- | /O(n)/. Build a map from an ascending list in linear time with a --- combining function for equal keys. --- /The precondition (input list is ascending) is not checked./ --- --- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 --- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")] --- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True --- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False - -fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a -fromAscListWithKey f xs - = fromDistinctAscList (combineEq f xs) - where - -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] - combineEq _ xs' - = case xs' of - [] -> [] - [x] -> [x] - (x:xx) -> combineEq' x xx - - combineEq' z [] = [z] - combineEq' z@(kz,zz) (x@(kx,xx):xs') - | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs' - | otherwise = z:combineEq' x xs' -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromAscListWithKey #-} -#endif - - --- | /O(n)/. Build a map from an ascending list of distinct elements in linear time. --- /The precondition is not checked./ --- --- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] --- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True --- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False - --- For some reason, when 'singleton' is used in fromDistinctAscList or in --- create, it is not inlined, so we inline it manually. -fromDistinctAscList :: [(k,a)] -> Map k a -fromDistinctAscList [] = Tip -fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0 - where - STRICT_1_OF_3(go) - go _ t [] = t - go s l ((kx, x) : xs) = case create s xs of - (r, ys) -> go (s `shiftL` 1) (join kx x l r) ys - - STRICT_1_OF_2(create) - create _ [] = (Tip, []) - create s xs@(x' : xs') - | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip, xs') - | otherwise = case create (s `shiftR` 1) xs of - res@(_, []) -> res - (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of - (r, zs) -> (join ky y l r, zs) - - -{-------------------------------------------------------------------- - Utility functions that return sub-ranges of the original - tree. Some functions take a `Maybe value` as an argument to - allow comparisons against infinite values. These are called `blow` - (Nothing is -\infty) and `bhigh` (here Nothing is +\infty). - We use MaybeS value, which is a Maybe strict in the Just case. - - [trim blow bhigh t] A tree that is either empty or where [x > blow] - and [x < bhigh] for the value [x] of the root. - [filterGt blow t] A tree where for all values [k]. [k > blow] - [filterLt bhigh t] A tree where for all values [k]. [k < bhigh] - - [split k t] Returns two trees [l] and [r] where all keys - in [l] are <[k] and all keys in [r] are >[k]. - [splitLookup k t] Just like [split] but also returns whether [k] - was found in the tree. ---------------------------------------------------------------------} - -data MaybeS a = NothingS | JustS !a - -{-------------------------------------------------------------------- - [trim blo bhi t] trims away all subtrees that surely contain no - values between the range [blo] to [bhi]. The returned tree is either - empty or the key of the root is between @blo@ and @bhi@. ---------------------------------------------------------------------} -trim :: Ord k => MaybeS k -> MaybeS k -> Map k a -> Map k a -trim NothingS NothingS t = t -trim (JustS lk) NothingS t = greater lk t where greater lo (Bin _ k _ _ r) | k <= lo = greater lo r - greater _ t' = t' -trim NothingS (JustS hk) t = lesser hk t where lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l - lesser _ t' = t' -trim (JustS lk) (JustS hk) t = middle lk hk t where middle lo hi (Bin _ k _ _ r) | k <= lo = middle lo hi r - middle lo hi (Bin _ k _ l _) | k >= hi = middle lo hi l - middle _ _ t' = t' -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE trim #-} -#endif - --- Helper function for 'mergeWithKey'. The @'trimLookupLo' lk hk t@ performs both --- @'trim' (JustS lk) hk t@ and @'lookup' lk t@. - --- See Note: Type of local 'go' function -trimLookupLo :: Ord k => k -> MaybeS k -> Map k a -> (Maybe a, Map k a) -trimLookupLo lk0 mhk0 t0 = toPair $ go lk0 mhk0 t0 - where - go lk NothingS t = greater lk t - where greater :: Ord k => k -> Map k a -> StrictPair (Maybe a) (Map k a) - greater lo t'@(Bin _ kx x l r) = case compare lo kx of - LT -> lookup lo l :*: t' - EQ -> (Just x :*: r) - GT -> greater lo r - greater _ Tip = (Nothing :*: Tip) - go lk (JustS hk) t = middle lk hk t - where middle :: Ord k => k -> k -> Map k a -> StrictPair (Maybe a) (Map k a) - middle lo hi t'@(Bin _ kx x l r) = case compare lo kx of - LT | kx < hi -> lookup lo l :*: t' - | otherwise -> middle lo hi l - EQ -> Just x :*: lesser hi r - GT -> middle lo hi r - middle _ _ Tip = (Nothing :*: Tip) - - lesser :: Ord k => k -> Map k a -> Map k a - lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l - lesser _ t' = t' -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE trimLookupLo #-} -#endif - - -{-------------------------------------------------------------------- - [filterGt b t] filter all keys >[b] from tree [t] - [filterLt b t] filter all keys <[b] from tree [t] ---------------------------------------------------------------------} -filterGt :: Ord k => MaybeS k -> Map k v -> Map k v -filterGt NothingS t = t -filterGt (JustS b) t = filter' b t - where filter' _ Tip = Tip - filter' b' (Bin _ kx x l r) = - case compare b' kx of LT -> join kx x (filter' b' l) r - EQ -> r - GT -> filter' b' r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE filterGt #-} -#endif - -filterLt :: Ord k => MaybeS k -> Map k v -> Map k v -filterLt NothingS t = t -filterLt (JustS b) t = filter' b t - where filter' _ Tip = Tip - filter' b' (Bin _ kx x l r) = - case compare kx b' of LT -> join kx x l (filter' b' r) - EQ -> l - GT -> filter' b' l -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE filterLt #-} -#endif - -{-------------------------------------------------------------------- - Split ---------------------------------------------------------------------} --- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where --- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. --- Any key equal to @k@ is found in neither @map1@ nor @map2@. --- --- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")]) --- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a") --- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a") --- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty) --- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty) - -split :: Ord k => k -> Map k a -> (Map k a,Map k a) -split k0 t0 = k0 `seq` toPair $ go k0 t0 - where - go k t = - case t of - Tip -> (Tip :*: Tip) - Bin _ kx x l r -> case compare k kx of - LT -> let (lt :*: gt) = go k l in lt :*: join kx x gt r - GT -> let (lt :*: gt) = go k r in join kx x l lt :*: gt - EQ -> (l :*: r) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE split #-} -#endif - --- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just --- like 'split' but also returns @'lookup' k map@. --- --- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")]) --- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a") --- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a") --- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty) --- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty) - -splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a) -splitLookup k t = k `seq` - case t of - Tip -> (Tip,Nothing,Tip) - Bin _ kx x l r -> case compare k kx of - LT -> let (lt,z,gt) = splitLookup k l - gt' = join kx x gt r - in gt' `seq` (lt,z,gt') - GT -> let (lt,z,gt) = splitLookup k r - lt' = join kx x l lt - in lt' `seq` (lt',z,gt) - EQ -> (l,Just x,r) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE splitLookup #-} -#endif - -{-------------------------------------------------------------------- - Utility functions that maintain the balance properties of the tree. - All constructors assume that all values in [l] < [k] and all values - in [r] > [k], and that [l] and [r] are valid trees. - - In order of sophistication: - [Bin sz k x l r] The type constructor. - [bin k x l r] Maintains the correct size, assumes that both [l] - and [r] are balanced with respect to each other. - [balance k x l r] Restores the balance and size. - Assumes that the original tree was balanced and - that [l] or [r] has changed by at most one element. - [join k x l r] Restores balance and size. - - Furthermore, we can construct a new tree from two trees. Both operations - assume that all values in [l] < all values in [r] and that [l] and [r] - are valid: - [glue l r] Glues [l] and [r] together. Assumes that [l] and - [r] are already balanced with respect to each other. - [merge l r] Merges two trees and restores balance. - - Note: in contrast to Adam's paper, we use (<=) comparisons instead - of (<) comparisons in [join], [merge] and [balance]. - Quickcheck (on [difference]) showed that this was necessary in order - to maintain the invariants. It is quite unsatisfactory that I haven't - been able to find out why this is actually the case! Fortunately, it - doesn't hurt to be a bit more conservative. ---------------------------------------------------------------------} - -{-------------------------------------------------------------------- - Join ---------------------------------------------------------------------} -join :: k -> a -> Map k a -> Map k a -> Map k a -join kx x Tip r = insertMin kx x r -join kx x l Tip = insertMax kx x l -join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz) - | delta*sizeL < sizeR = balanceL kz z (join kx x l lz) rz - | delta*sizeR < sizeL = balanceR ky y ly (join kx x ry r) - | otherwise = bin kx x l r - - --- insertMin and insertMax don't perform potentially expensive comparisons. -insertMax,insertMin :: k -> a -> Map k a -> Map k a -insertMax kx x t - = case t of - Tip -> singleton kx x - Bin _ ky y l r - -> balanceR ky y l (insertMax kx x r) - -insertMin kx x t - = case t of - Tip -> singleton kx x - Bin _ ky y l r - -> balanceL ky y (insertMin kx x l) r - -{-------------------------------------------------------------------- - [merge l r]: merges two trees. ---------------------------------------------------------------------} -merge :: Map k a -> Map k a -> Map k a -merge Tip r = r -merge l Tip = l -merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry) - | delta*sizeL < sizeR = balanceL ky y (merge l ly) ry - | delta*sizeR < sizeL = balanceR kx x lx (merge rx r) - | otherwise = glue l r - -{-------------------------------------------------------------------- - [glue l r]: glues two trees together. - Assumes that [l] and [r] are already balanced with respect to each other. ---------------------------------------------------------------------} -glue :: Map k a -> Map k a -> Map k a -glue Tip r = r -glue l Tip = l -glue l r - | size l > size r = let ((km,m),l') = deleteFindMax l in balanceR km m l' r - | otherwise = let ((km,m),r') = deleteFindMin r in balanceL km m l r' - - --- | /O(log n)/. Delete and find the minimal element. --- --- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")]) --- > deleteFindMin Error: can not return the minimal element of an empty map - -deleteFindMin :: Map k a -> ((k,a),Map k a) -deleteFindMin t - = case t of - Bin _ k x Tip r -> ((k,x),r) - Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balanceR k x l' r) - Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip) - --- | /O(log n)/. Delete and find the maximal element. --- --- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")]) --- > deleteFindMax empty Error: can not return the maximal element of an empty map - -deleteFindMax :: Map k a -> ((k,a),Map k a) -deleteFindMax t - = case t of - Bin _ k x l Tip -> ((k,x),l) - Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balanceL k x l r') - Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip) - - -{-------------------------------------------------------------------- - [balance l x r] balances two trees with value x. - The sizes of the trees should balance after decreasing the - size of one of them. (a rotation). - - [delta] is the maximal relative difference between the sizes of - two trees, it corresponds with the [w] in Adams' paper. - [ratio] is the ratio between an outer and inner sibling of the - heavier subtree in an unbalanced setting. It determines - whether a double or single rotation should be performed - to restore balance. It is corresponds with the inverse - of $\alpha$ in Adam's article. - - Note that according to the Adam's paper: - - [delta] should be larger than 4.646 with a [ratio] of 2. - - [delta] should be larger than 3.745 with a [ratio] of 1.534. - - But the Adam's paper is erroneous: - - It can be proved that for delta=2 and delta>=5 there does - not exist any ratio that would work. - - Delta=4.5 and ratio=2 does not work. - - That leaves two reasonable variants, delta=3 and delta=4, - both with ratio=2. - - - A lower [delta] leads to a more 'perfectly' balanced tree. - - A higher [delta] performs less rebalancing. - - In the benchmarks, delta=3 is faster on insert operations, - and delta=4 has slightly better deletes. As the insert speedup - is larger, we currently use delta=3. - ---------------------------------------------------------------------} -delta,ratio :: Int -delta = 3 -ratio = 2 - --- The balance function is equivalent to the following: --- --- balance :: k -> a -> Map k a -> Map k a -> Map k a --- balance k x l r --- | sizeL + sizeR <= 1 = Bin sizeX k x l r --- | sizeR > delta*sizeL = rotateL k x l r --- | sizeL > delta*sizeR = rotateR k x l r --- | otherwise = Bin sizeX k x l r --- where --- sizeL = size l --- sizeR = size r --- sizeX = sizeL + sizeR + 1 --- --- rotateL :: a -> b -> Map a b -> Map a b -> Map a b --- rotateL k x l r@(Bin _ _ _ ly ry) | size ly < ratio*size ry = singleL k x l r --- | otherwise = doubleL k x l r --- --- rotateR :: a -> b -> Map a b -> Map a b -> Map a b --- rotateR k x l@(Bin _ _ _ ly ry) r | size ry < ratio*size ly = singleR k x l r --- | otherwise = doubleR k x l r --- --- singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b --- singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3 --- singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3) --- --- doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b --- doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4) --- doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4) --- --- It is only written in such a way that every node is pattern-matched only once. - -balance :: k -> a -> Map k a -> Map k a -> Map k a -balance k x l r = case l of - Tip -> case r of - Tip -> Bin 1 k x Tip Tip - (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r - (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr - (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip) - (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _)) - | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr - | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr) - - (Bin ls lk lx ll lr) -> case r of - Tip -> case (ll, lr) of - (Tip, Tip) -> Bin 2 k x l Tip - (Tip, (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip) - ((Bin _ _ _ _ _), Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip) - ((Bin lls _ _ _ _), (Bin lrs lrk lrx lrl lrr)) - | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip) - | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip) - (Bin rs rk rx rl rr) - | rs > delta*ls -> case (rl, rr) of - (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _) - | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr - | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr) - (_, _) -> error "Failure in Data.Map.balance" - | ls > delta*rs -> case (ll, lr) of - (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr) - | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r) - | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r) - (_, _) -> error "Failure in Data.Map.balance" - | otherwise -> Bin (1+ls+rs) k x l r -{-# NOINLINE balance #-} - --- Functions balanceL and balanceR are specialised versions of balance. --- balanceL only checks whether the left subtree is too big, --- balanceR only checks whether the right subtree is too big. - --- balanceL is called when left subtree might have been inserted to or when --- right subtree might have been deleted from. -balanceL :: k -> a -> Map k a -> Map k a -> Map k a -balanceL k x l r = case r of - Tip -> case l of - Tip -> Bin 1 k x Tip Tip - (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip - (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip) - (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip) - (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr)) - | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip) - | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip) - - (Bin rs _ _ _ _) -> case l of - Tip -> Bin (1+rs) k x Tip r - - (Bin ls lk lx ll lr) - | ls > delta*rs -> case (ll, lr) of - (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr) - | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r) - | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r) - (_, _) -> error "Failure in Data.Map.balanceL" - | otherwise -> Bin (1+ls+rs) k x l r -{-# NOINLINE balanceL #-} - --- balanceR is called when right subtree might have been inserted to or when --- left subtree might have been deleted from. -balanceR :: k -> a -> Map k a -> Map k a -> Map k a -balanceR k x l r = case l of - Tip -> case r of - Tip -> Bin 1 k x Tip Tip - (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r - (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr - (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip) - (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _)) - | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr - | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr) - - (Bin ls _ _ _ _) -> case r of - Tip -> Bin (1+ls) k x l Tip - - (Bin rs rk rx rl rr) - | rs > delta*ls -> case (rl, rr) of - (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _) - | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr - | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr) - (_, _) -> error "Failure in Data.Map.balanceR" - | otherwise -> Bin (1+ls+rs) k x l r -{-# NOINLINE balanceR #-} - - -{-------------------------------------------------------------------- - The bin constructor maintains the size of the tree ---------------------------------------------------------------------} -bin :: k -> a -> Map k a -> Map k a -> Map k a -bin k x l r - = Bin (size l + size r + 1) k x l r -{-# INLINE bin #-} - - -{-------------------------------------------------------------------- - Eq converts the tree to a list. In a lazy setting, this - actually seems one of the faster methods to compare two trees - and it is certainly the simplest :-) ---------------------------------------------------------------------} -instance (Eq k,Eq a) => Eq (Map k a) where - t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2) - -{-------------------------------------------------------------------- - Ord ---------------------------------------------------------------------} - -instance (Ord k, Ord v) => Ord (Map k v) where - compare m1 m2 = compare (toAscList m1) (toAscList m2) - -{-------------------------------------------------------------------- - Functor ---------------------------------------------------------------------} -instance Functor (Map k) where - fmap f m = map f m - -instance Traversable (Map k) where - traverse f = traverseWithKey (\_ -> f) - -instance Foldable.Foldable (Map k) where - fold Tip = mempty - fold (Bin _ _ v l r) = Foldable.fold l `mappend` v `mappend` Foldable.fold r - foldr = foldr - foldl = foldl - foldMap _ Tip = mempty - foldMap f (Bin _ _ v l r) = Foldable.foldMap f l `mappend` f v `mappend` Foldable.foldMap f r - -instance (NFData k, NFData a) => NFData (Map k a) where - rnf Tip = () - rnf (Bin _ kx x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r - -{-------------------------------------------------------------------- - Read ---------------------------------------------------------------------} -instance (Ord k, Read k, Read e) => Read (Map k e) where -#ifdef __GLASGOW_HASKELL__ - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - xs <- readPrec - return (fromList xs) - - readListPrec = readListPrecDefault -#else - readsPrec p = readParen (p > 10) $ \ r -> do - ("fromList",s) <- lex r - (xs,t) <- reads s - return (fromList xs,t) -#endif - -{-------------------------------------------------------------------- - Show ---------------------------------------------------------------------} -instance (Show k, Show a) => Show (Map k a) where - showsPrec d m = showParen (d > 10) $ - showString "fromList " . shows (toList m) - --- | /O(n)/. Show the tree that implements the map. The tree is shown --- in a compressed, hanging format. See 'showTreeWith'. -showTree :: (Show k,Show a) => Map k a -> String -showTree m - = showTreeWith showElem True False m - where - showElem k x = show k ++ ":=" ++ show x - - -{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows - the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is - 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If - @wide@ is 'True', an extra wide version is shown. - -> Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]] -> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t -> (4,()) -> +--(2,()) -> | +--(1,()) -> | +--(3,()) -> +--(5,()) -> -> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t -> (4,()) -> | -> +--(2,()) -> | | -> | +--(1,()) -> | | -> | +--(3,()) -> | -> +--(5,()) -> -> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t -> +--(5,()) -> | -> (4,()) -> | -> | +--(3,()) -> | | -> +--(2,()) -> | -> +--(1,()) - --} -showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String -showTreeWith showelem hang wide t - | hang = (showsTreeHang showelem wide [] t) "" - | otherwise = (showsTree showelem wide [] [] t) "" - -showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS -showsTree showelem wide lbars rbars t - = case t of - Tip -> showsBars lbars . showString "|\n" - Bin _ kx x Tip Tip - -> showsBars lbars . showString (showelem kx x) . showString "\n" - Bin _ kx x l r - -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r . - showWide wide rbars . - showsBars lbars . showString (showelem kx x) . showString "\n" . - showWide wide lbars . - showsTree showelem wide (withEmpty lbars) (withBar lbars) l - -showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS -showsTreeHang showelem wide bars t - = case t of - Tip -> showsBars bars . showString "|\n" - Bin _ kx x Tip Tip - -> showsBars bars . showString (showelem kx x) . showString "\n" - Bin _ kx x l r - -> showsBars bars . showString (showelem kx x) . showString "\n" . - showWide wide bars . - showsTreeHang showelem wide (withBar bars) l . - showWide wide bars . - showsTreeHang showelem wide (withEmpty bars) r - -showWide :: Bool -> [String] -> String -> String -showWide wide bars - | wide = showString (concat (reverse bars)) . showString "|\n" - | otherwise = id - -showsBars :: [String] -> ShowS -showsBars bars - = case bars of - [] -> id - _ -> showString (concat (reverse (tail bars))) . showString node - -node :: String -node = "+--" - -withBar, withEmpty :: [String] -> [String] -withBar bars = "| ":bars -withEmpty bars = " ":bars - -{-------------------------------------------------------------------- - Typeable ---------------------------------------------------------------------} - -#include "Typeable.h" -INSTANCE_TYPEABLE2(Map,mapTc,"Map") - -{-------------------------------------------------------------------- - Assertions ---------------------------------------------------------------------} --- | /O(n)/. Test if the internal map structure is valid. --- --- > valid (fromAscList [(3,"b"), (5,"a")]) == True --- > valid (fromAscList [(5,"a"), (3,"b")]) == False - -valid :: Ord k => Map k a -> Bool -valid t - = balanced t && ordered t && validsize t - -ordered :: Ord a => Map a b -> Bool -ordered t - = bounded (const True) (const True) t - where - bounded lo hi t' - = case t' of - Tip -> True - Bin _ kx _ l r -> (lo kx) && (hi kx) && bounded lo (kx) hi r - --- | Exported only for "Debug.QuickCheck" -balanced :: Map k a -> Bool -balanced t - = case t of - Tip -> True - Bin _ _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) && - balanced l && balanced r - -validsize :: Map a b -> Bool -validsize t - = (realsize t == Just (size t)) - where - realsize t' - = case t' of - Tip -> Just 0 - Bin sz _ _ l r -> case (realsize l,realsize r) of - (Just n,Just m) | n+m+1 == sz -> Just sz - _ -> Nothing - -{-------------------------------------------------------------------- - Utilities ---------------------------------------------------------------------} -foldlStrict :: (a -> b -> a) -> a -> [b] -> a -foldlStrict f = go - where - go z [] = z - go z (x:xs) = let z' = f z x in z' `seq` go z' xs -{-# INLINE foldlStrict #-} diff --git a/containers-0.5.2.1/Darcs/Data/Map/Strict.hs b/containers-0.5.2.1/Darcs/Data/Map/Strict.hs deleted file mode 100644 --- a/containers-0.5.2.1/Darcs/Data/Map/Strict.hs +++ /dev/null @@ -1,1180 +0,0 @@ -{-# LANGUAGE CPP #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 -{-# LANGUAGE Safe #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Map.Strict --- Copyright : (c) Daan Leijen 2002 --- (c) Andriy Palamarchuk 2008 --- License : BSD-style --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- An efficient implementation of ordered maps from keys to values --- (dictionaries). --- --- API of this module is strict in both the keys and the values. --- If you need value-lazy maps, use "Data.Map.Lazy" instead. --- The 'Map' type is shared between the lazy and strict modules, --- meaning that the same 'Map' value can be passed to functions in --- both modules (although that is rarely needed). --- --- These modules are intended to be imported qualified, to avoid name --- clashes with Prelude functions, e.g. --- --- > import qualified Data.Map.Strict as Map --- --- The implementation of 'Map' is based on /size balanced/ binary trees (or --- trees of /bounded balance/) as described by: --- --- * Stephen Adams, \"/Efficient sets: a balancing act/\", --- Journal of Functional Programming 3(4):553-562, October 1993, --- . --- --- * J. Nievergelt and E.M. Reingold, --- \"/Binary search trees of bounded balance/\", --- SIAM journal of computing 2(1), March 1973. --- --- Note that the implementation is /left-biased/ -- the elements of a --- first argument are always preferred to the second, for example in --- 'union' or 'insert'. --- --- Operation comments contain the operation time complexity in --- the Big-O notation (). --- --- Be aware that the 'Functor', 'Traversable' and 'Data' instances --- are the same as for the "Data.Map.Lazy" module, so if they are used --- on strict maps, the resulting maps will be lazy. ------------------------------------------------------------------------------ - --- See the notes at the beginning of Data.Map.Base. - -module Darcs.Data.Map.Strict - ( - -- * Strictness properties - -- $strictness - - -- * Map type -#if !defined(TESTING) - Map -- instance Eq,Show,Read -#else - Map(..) -- instance Eq,Show,Read -#endif - - -- * Operators - , (!), (\\) - - -- * Query - , null - , size - , member - , notMember - , lookup - , findWithDefault - , lookupLT - , lookupGT - , lookupLE - , lookupGE - - -- * Construction - , empty - , singleton - - -- ** Insertion - , insert - , insertWith - , insertWithKey - , insertLookupWithKey - - -- ** Delete\/Update - , delete - , adjust - , adjustWithKey - , update - , updateWithKey - , updateLookupWithKey - , alter - - -- * Combine - - -- ** Union - , union - , unionWith - , unionWithKey - , unions - , unionsWith - - -- ** Difference - , difference - , differenceWith - , differenceWithKey - - -- ** Intersection - , intersection - , intersectionWith - , intersectionWithKey - - -- ** Universal combining function - , mergeWithKey - - -- * Traversal - -- ** Map - , map - , mapWithKey - , traverseWithKey - , mapAccum - , mapAccumWithKey - , mapAccumRWithKey - , mapKeys - , mapKeysWith - , mapKeysMonotonic - - -- * Folds - , foldr - , foldl - , foldrWithKey - , foldlWithKey - -- ** Strict folds - , foldr' - , foldl' - , foldrWithKey' - , foldlWithKey' - - -- * Conversion - , elems - , keys - , assocs - , keysSet - , fromSet - - -- ** Lists - , toList - , fromList - , fromListWith - , fromListWithKey - - -- ** Ordered lists - , toAscList - , toDescList - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList - - -- * Filter - , filter - , filterWithKey - , partition - , partitionWithKey - - , mapMaybe - , mapMaybeWithKey - , mapEither - , mapEitherWithKey - - , split - , splitLookup - - -- * Submap - , isSubmapOf, isSubmapOfBy - , isProperSubmapOf, isProperSubmapOfBy - - -- * Indexed - , lookupIndex - , findIndex - , elemAt - , updateAt - , deleteAt - - -- * Min\/Max - , findMin - , findMax - , deleteMin - , deleteMax - , deleteFindMin - , deleteFindMax - , updateMin - , updateMax - , updateMinWithKey - , updateMaxWithKey - , minView - , maxView - , minViewWithKey - , maxViewWithKey - - -- * Debugging - , showTree - , showTreeWith - , valid - -#if defined(TESTING) - -- * Internals - , bin - , balanced - , join - , merge -#endif - ) where - -import Prelude hiding (lookup,map,filter,foldr,foldl,null) - -import Darcs.Data.Map.Base hiding - ( findWithDefault - , singleton - , insert - , insertWith - , insertWithKey - , insertLookupWithKey - , adjust - , adjustWithKey - , update - , updateWithKey - , updateLookupWithKey - , alter - , unionWith - , unionWithKey - , unionsWith - , differenceWith - , differenceWithKey - , intersectionWith - , intersectionWithKey - , mergeWithKey - , map - , mapWithKey - , mapAccum - , mapAccumWithKey - , mapAccumRWithKey - , mapKeysWith - , fromSet - , fromList - , fromListWith - , fromListWithKey - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList - , mapMaybe - , mapMaybeWithKey - , mapEither - , mapEitherWithKey - , updateAt - , updateMin - , updateMax - , updateMinWithKey - , updateMaxWithKey - ) -import qualified Darcs.Data.Set.Base as Set -import Darcs.Data.StrictPair -import Data.Bits (shiftL, shiftR) - --- Use macros to define strictness of functions. STRICT_x_OF_y --- denotes an y-ary function strict in the x-th parameter. Similarly --- STRICT_x_y_OF_z denotes an z-ary function strict in the x-th and --- y-th parameter. We do not use BangPatterns, because they are not --- in any standard and we want the compilers to be compiled by as many --- compilers as possible. -#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined -#define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined -#define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined -#define STRICT_1_2_OF_3(fn) fn arg1 arg2 _ | arg1 `seq` arg2 `seq` False = undefined -#define STRICT_2_3_OF_4(fn) fn _ arg1 arg2 _ | arg1 `seq` arg2 `seq` False = undefined - --- $strictness --- --- This module satisfies the following strictness properties: --- --- 1. Key and value arguments are evaluated to WHNF; --- --- 2. Keys and values are evaluated to WHNF before they are stored in --- the map. --- --- Here are some examples that illustrate the first property: --- --- > insertWith (\ new old -> old) k undefined m == undefined --- > delete undefined m == undefined --- --- Here are some examples that illustrate the second property: --- --- > map (\ v -> undefined) m == undefined -- m is not empty --- > mapKeys (\ k -> undefined) m == undefined -- m is not empty - -{-------------------------------------------------------------------- - Query ---------------------------------------------------------------------} - --- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns --- the value at key @k@ or returns default value @def@ --- when the key is not in the map. --- --- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' --- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' - --- See Map.Base.Note: Local 'go' functions and capturing -findWithDefault :: Ord k => a -> k -> Map k a -> a -findWithDefault def k = def `seq` k `seq` go - where - go Tip = def - go (Bin _ kx x l r) = case compare k kx of - LT -> go l - GT -> go r - EQ -> x -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE findWithDefault #-} -#else -{-# INLINE findWithDefault #-} -#endif - -{-------------------------------------------------------------------- - Construction ---------------------------------------------------------------------} - --- | /O(1)/. A map with a single element. --- --- > singleton 1 'a' == fromList [(1, 'a')] --- > size (singleton 1 'a') == 1 - -singleton :: k -> a -> Map k a -singleton k x = x `seq` Bin 1 k x Tip Tip -{-# INLINE singleton #-} - -{-------------------------------------------------------------------- - Insertion ---------------------------------------------------------------------} --- | /O(log n)/. Insert a new key and value in the map. --- If the key is already present in the map, the associated value is --- replaced with the supplied value. 'insert' is equivalent to --- @'insertWith' 'const'@. --- --- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] --- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] --- > insert 5 'x' empty == singleton 5 'x' - --- See Map.Base.Note: Type of local 'go' function -insert :: Ord k => k -> a -> Map k a -> Map k a -insert = go - where - go :: Ord k => k -> a -> Map k a -> Map k a - STRICT_1_2_OF_3(go) - go kx x Tip = singleton kx x - go kx x (Bin sz ky y l r) = - case compare kx ky of - LT -> balanceL ky y (go kx x l) r - GT -> balanceR ky y l (go kx x r) - EQ -> Bin sz kx x l r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE insert #-} -#else -{-# INLINE insert #-} -#endif - --- | /O(log n)/. Insert with a function, combining new value and old value. --- @'insertWith' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does --- not exist in the map. If the key does exist, the function will --- insert the pair @(key, f new_value old_value)@. --- --- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] --- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] --- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" - -insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a -insertWith f = insertWithKey (\_ x' y' -> f x' y') -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE insertWith #-} -#else -{-# INLINE insertWith #-} -#endif - --- | /O(log n)/. Insert with a function, combining key, new value and old value. --- @'insertWithKey' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does --- not exist in the map. If the key does exist, the function will --- insert the pair @(key,f key new_value old_value)@. --- Note that the key passed to f is the same key passed to 'insertWithKey'. --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] --- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] --- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" - --- See Map.Base.Note: Type of local 'go' function -insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a -insertWithKey = go - where - go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a - STRICT_2_3_OF_4(go) - go _ kx x Tip = singleton kx x - go f kx x (Bin sy ky y l r) = - case compare kx ky of - LT -> balanceL ky y (go f kx x l) r - GT -> balanceR ky y l (go f kx x r) - EQ -> let x' = f kx x y - in x' `seq` Bin sy kx x' l r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE insertWithKey #-} -#else -{-# INLINE insertWithKey #-} -#endif - --- | /O(log n)/. Combines insert operation with old value retrieval. --- The expression (@'insertLookupWithKey' f k x map@) --- is a pair where the first element is equal to (@'lookup' k map@) --- and the second element equal to (@'insertWithKey' f k x map@). --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) --- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) --- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") --- --- This is how to define @insertLookup@ using @insertLookupWithKey@: --- --- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t --- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) --- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) - --- See Map.Base.Note: Type of local 'go' function -insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a - -> (Maybe a, Map k a) -insertLookupWithKey f0 kx0 x0 t0 = toPair $ go f0 kx0 x0 t0 - where - go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a) - STRICT_2_3_OF_4(go) - go _ kx x Tip = Nothing :*: singleton kx x - go f kx x (Bin sy ky y l r) = - case compare kx ky of - LT -> let (found :*: l') = go f kx x l - in found :*: balanceL ky y l' r - GT -> let (found :*: r') = go f kx x r - in found :*: balanceR ky y l r' - EQ -> let x' = f kx x y - in x' `seq` (Just y :*: Bin sy kx x' l r) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE insertLookupWithKey #-} -#else -{-# INLINE insertLookupWithKey #-} -#endif - -{-------------------------------------------------------------------- - Deletion ---------------------------------------------------------------------} - --- | /O(log n)/. Update a value at a specific key with the result of the provided function. --- When the key is not --- a member of the map, the original map is returned. --- --- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] --- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > adjust ("new " ++) 7 empty == empty - -adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a -adjust f = adjustWithKey (\_ x -> f x) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE adjust #-} -#else -{-# INLINE adjust #-} -#endif - --- | /O(log n)/. Adjust a value at a specific key. When the key is not --- a member of the map, the original map is returned. --- --- > let f key x = (show key) ++ ":new " ++ x --- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] --- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > adjustWithKey f 7 empty == empty - -adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a -adjustWithKey f = updateWithKey (\k' x' -> Just (f k' x')) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE adjustWithKey #-} -#else -{-# INLINE adjustWithKey #-} -#endif - --- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ --- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is --- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. --- --- > let f x = if x == "a" then Just "new a" else Nothing --- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] --- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a -update f = updateWithKey (\_ x -> f x) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE update #-} -#else -{-# INLINE update #-} -#endif - --- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the --- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', --- the element is deleted. If it is (@'Just' y@), the key @k@ is bound --- to the new value @y@. --- --- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing --- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] --- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - --- See Map.Base.Note: Type of local 'go' function -updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a -updateWithKey = go - where - go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a - STRICT_2_OF_3(go) - go _ _ Tip = Tip - go f k(Bin sx kx x l r) = - case compare k kx of - LT -> balanceR kx x (go f k l) r - GT -> balanceL kx x l (go f k r) - EQ -> case f kx x of - Just x' -> x' `seq` Bin sx kx x' l r - Nothing -> glue l r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE updateWithKey #-} -#else -{-# INLINE updateWithKey #-} -#endif - --- | /O(log n)/. Lookup and update. See also 'updateWithKey'. --- The function returns changed value, if it is updated. --- Returns the original key value if the map entry is deleted. --- --- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing --- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")]) --- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) --- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") - --- See Map.Base.Note: Type of local 'go' function -updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a) -updateLookupWithKey f0 k0 t0 = toPair $ go f0 k0 t0 - where - go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a) - STRICT_2_OF_3(go) - go _ _ Tip = (Nothing :*: Tip) - go f k (Bin sx kx x l r) = - case compare k kx of - LT -> let (found :*: l') = go f k l - in found :*: balanceR kx x l' r - GT -> let (found :*: r') = go f k r - in found :*: balanceL kx x l r' - EQ -> case f kx x of - Just x' -> x' `seq` (Just x' :*: Bin sx kx x' l r) - Nothing -> (Just x :*: glue l r) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE updateLookupWithKey #-} -#else -{-# INLINE updateLookupWithKey #-} -#endif - --- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. --- 'alter' can be used to insert, delete, or update a value in a 'Map'. --- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. --- --- > let f _ = Nothing --- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" --- > --- > let f _ = Just "c" --- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")] --- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")] - --- See Map.Base.Note: Type of local 'go' function -alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a -alter = go - where - go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a - STRICT_2_OF_3(go) - go f k Tip = case f Nothing of - Nothing -> Tip - Just x -> singleton k x - - go f k (Bin sx kx x l r) = case compare k kx of - LT -> balance kx x (go f k l) r - GT -> balance kx x l (go f k r) - EQ -> case f (Just x) of - Just x' -> x' `seq` Bin sx kx x' l r - Nothing -> glue l r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE alter #-} -#else -{-# INLINE alter #-} -#endif - -{-------------------------------------------------------------------- - Indexing ---------------------------------------------------------------------} - --- | /O(log n)/. Update the element at /index/. Calls 'error' when an --- invalid index is used. --- --- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")] --- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")] --- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range --- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range --- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" --- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" --- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range --- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range - -updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a -updateAt f i t = i `seq` - case t of - Tip -> error "Map.updateAt: index out of range" - Bin sx kx x l r -> case compare i sizeL of - LT -> balanceR kx x (updateAt f i l) r - GT -> balanceL kx x l (updateAt f (i-sizeL-1) r) - EQ -> case f kx x of - Just x' -> x' `seq` Bin sx kx x' l r - Nothing -> glue l r - where - sizeL = size l - -{-------------------------------------------------------------------- - Minimal, Maximal ---------------------------------------------------------------------} - --- | /O(log n)/. Update the value at the minimal key. --- --- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] --- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -updateMin :: (a -> Maybe a) -> Map k a -> Map k a -updateMin f m - = updateMinWithKey (\_ x -> f x) m - --- | /O(log n)/. Update the value at the maximal key. --- --- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] --- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" - -updateMax :: (a -> Maybe a) -> Map k a -> Map k a -updateMax f m - = updateMaxWithKey (\_ x -> f x) m - - --- | /O(log n)/. Update the value at the minimal key. --- --- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] --- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a -updateMinWithKey _ Tip = Tip -updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of - Nothing -> r - Just x' -> x' `seq` Bin sx kx x' Tip r -updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r - --- | /O(log n)/. Update the value at the maximal key. --- --- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] --- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" - -updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a -updateMaxWithKey _ Tip = Tip -updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of - Nothing -> l - Just x' -> x' `seq` Bin sx kx x' l Tip -updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r) - -{-------------------------------------------------------------------- - Union. ---------------------------------------------------------------------} - --- | The union of a list of maps, with a combining operation: --- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@). --- --- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] --- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] - -unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a -unionsWith f ts - = foldlStrict (unionWith f) empty ts -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE unionsWith #-} -#endif - -{-------------------------------------------------------------------- - Union with a combining function ---------------------------------------------------------------------} --- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. --- --- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] - -unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a -unionWith f m1 m2 - = unionWithKey (\_ x y -> f x y) m1 m2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE unionWith #-} -#endif - --- | /O(n+m)/. --- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. --- --- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value --- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] - -unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a -unionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) id id t1 t2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE unionWithKey #-} -#endif - -{-------------------------------------------------------------------- - Difference ---------------------------------------------------------------------} - --- | /O(n+m)/. Difference with a combining function. --- When two equal keys are --- encountered, the combining function is applied to the values of these keys. --- If it returns 'Nothing', the element is discarded (proper set difference). If --- it returns (@'Just' y@), the element is updated with a new value @y@. --- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. --- --- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing --- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) --- > == singleton 3 "b:B" - -differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a -differenceWith f m1 m2 - = differenceWithKey (\_ x y -> f x y) m1 m2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE differenceWith #-} -#endif - --- | /O(n+m)/. Difference with a combining function. When two equal keys are --- encountered, the combining function is applied to the key and both values. --- If it returns 'Nothing', the element is discarded (proper set difference). If --- it returns (@'Just' y@), the element is updated with a new value @y@. --- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. --- --- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing --- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) --- > == singleton 3 "3:b|B" - -differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a -differenceWithKey f t1 t2 = mergeWithKey f id (const Tip) t1 t2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE differenceWithKey #-} -#endif - - -{-------------------------------------------------------------------- - Intersection ---------------------------------------------------------------------} - --- | /O(n+m)/. Intersection with a combining function. The implementation uses --- an efficient /hedge/ algorithm comparable with /hedge-union/. --- --- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" - -intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c -intersectionWith f m1 m2 - = intersectionWithKey (\_ x y -> f x y) m1 m2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE intersectionWith #-} -#endif - --- | /O(n+m)/. Intersection with a combining function. The implementation uses --- an efficient /hedge/ algorithm comparable with /hedge-union/. --- --- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar --- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" - - -intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c -intersectionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) (const Tip) (const Tip) t1 t2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE intersectionWithKey #-} -#endif - - -{-------------------------------------------------------------------- - MergeWithKey ---------------------------------------------------------------------} - --- | /O(n+m)/. A high-performance universal combining function. This function --- is used to define 'unionWith', 'unionWithKey', 'differenceWith', --- 'differenceWithKey', 'intersectionWith', 'intersectionWithKey' and can be --- used to define other custom combine functions. --- --- Please make sure you know what is going on when using 'mergeWithKey', --- otherwise you can be surprised by unexpected code growth or even --- corruption of the data structure. --- --- When 'mergeWithKey' is given three arguments, it is inlined to the call --- site. You should therefore use 'mergeWithKey' only to define your custom --- combining functions. For example, you could define 'unionWithKey', --- 'differenceWithKey' and 'intersectionWithKey' as --- --- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2 --- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2 --- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2 --- --- When calling @'mergeWithKey' combine only1 only2@, a function combining two --- 'IntMap's is created, such that --- --- * if a key is present in both maps, it is passed with both corresponding --- values to the @combine@ function. Depending on the result, the key is either --- present in the result with specified value, or is left out; --- --- * a nonempty subtree present only in the first map is passed to @only1@ and --- the output is added to the result; --- --- * a nonempty subtree present only in the second map is passed to @only2@ and --- the output is added to the result. --- --- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/. --- The values can be modified arbitrarily. Most common variants of @only1@ and --- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or --- @'filterWithKey' f@ could be used for any @f@. - -mergeWithKey :: Ord k => (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c) - -> Map k a -> Map k b -> Map k c -mergeWithKey f g1 g2 = go - where - go Tip t2 = g2 t2 - go t1 Tip = g1 t1 - go t1 t2 = hedgeMerge NothingS NothingS t1 t2 - - hedgeMerge _ _ t1 Tip = g1 t1 - hedgeMerge blo bhi Tip (Bin _ kx x l r) = g2 $ join kx x (filterGt blo l) (filterLt bhi r) - hedgeMerge blo bhi (Bin _ kx x l r) t2 = let l' = hedgeMerge blo bmi l (trim blo bmi t2) - (found, trim_t2) = trimLookupLo kx bhi t2 - r' = hedgeMerge bmi bhi r trim_t2 - in case found of - Nothing -> case g1 (singleton kx x) of - Tip -> merge l' r' - (Bin _ _ x' Tip Tip) -> join kx x' l' r' - _ -> error "mergeWithKey: Given function only1 does not fulfil required conditions (see documentation)" - Just x2 -> case f kx x x2 of - Nothing -> merge l' r' - Just x' -> x' `seq` join kx x' l' r' - where bmi = JustS kx -{-# INLINE mergeWithKey #-} - -{-------------------------------------------------------------------- - Filter and partition ---------------------------------------------------------------------} - --- | /O(n)/. Map values and collect the 'Just' results. --- --- > let f x = if x == "a" then Just "new a" else Nothing --- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" - -mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b -mapMaybe f = mapMaybeWithKey (\_ x -> f x) - --- | /O(n)/. Map keys\/values and collect the 'Just' results. --- --- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing --- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" - -mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b -mapMaybeWithKey _ Tip = Tip -mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of - Just y -> y `seq` join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r) - Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r) - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. --- --- > let f a = if a < "c" then Left a else Right a --- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) --- > --- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) - -mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c) -mapEither f m - = mapEitherWithKey (\_ x -> f x) m - --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. --- --- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) --- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) --- > --- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) - -mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c) -mapEitherWithKey f0 t0 = toPair $ go f0 t0 - where - go _ Tip = (Tip :*: Tip) - go f (Bin _ kx x l r) = case f kx x of - Left y -> y `seq` (join kx y l1 r1 :*: merge l2 r2) - Right z -> z `seq` (merge l1 r1 :*: join kx z l2 r2) - where - (l1 :*: l2) = go f l - (r1 :*: r2) = go f r - -{-------------------------------------------------------------------- - Mapping ---------------------------------------------------------------------} --- | /O(n)/. Map a function over all values in the map. --- --- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] - -map :: (a -> b) -> Map k a -> Map k b -map _ Tip = Tip -map f (Bin sx kx x l r) = let x' = f x in x' `seq` Bin sx kx x' (map f l) (map f r) - --- | /O(n)/. Map a function over all values in the map. --- --- > let f key x = (show key) ++ ":" ++ x --- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] - -mapWithKey :: (k -> a -> b) -> Map k a -> Map k b -mapWithKey _ Tip = Tip -mapWithKey f (Bin sx kx x l r) = let x' = f kx x - in x' `seq` Bin sx kx x' (mapWithKey f l) (mapWithKey f r) - --- | /O(n)/. The function 'mapAccum' threads an accumulating --- argument through the map in ascending order of keys. --- --- > let f a b = (a ++ b, b ++ "X") --- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) - -mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) -mapAccum f a m - = mapAccumWithKey (\a' _ x' -> f a' x') a m - --- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating --- argument through the map in ascending order of keys. --- --- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") --- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) - -mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) -mapAccumWithKey f a t - = mapAccumL f a t - --- | /O(n)/. The function 'mapAccumL' threads an accumulating --- argument through the map in ascending order of keys. -mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) -mapAccumL _ a Tip = (a,Tip) -mapAccumL f a (Bin sx kx x l r) = - let (a1,l') = mapAccumL f a l - (a2,x') = f a1 kx x - (a3,r') = mapAccumL f a2 r - in x' `seq` (a3,Bin sx kx x' l' r') - --- | /O(n)/. The function 'mapAccumR' threads an accumulating --- argument through the map in descending order of keys. -mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) -mapAccumRWithKey _ a Tip = (a,Tip) -mapAccumRWithKey f a (Bin sx kx x l r) = - let (a1,r') = mapAccumRWithKey f a r - (a2,x') = f a1 kx x - (a3,l') = mapAccumRWithKey f a2 l - in x' `seq` (a3,Bin sx kx x' l' r') - --- | /O(n*log n)/. --- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the associated values will be --- combined using @c@. --- --- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" --- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" - -mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a -mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE mapKeysWith #-} -#endif - -{-------------------------------------------------------------------- - Conversions ---------------------------------------------------------------------} - --- | /O(n)/. Build a map from a set of keys and a function which for each key --- computes its value. --- --- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] --- > fromSet undefined Data.Set.empty == empty - -fromSet :: (k -> a) -> Set.Set k -> Map k a -fromSet _ Set.Tip = Tip -fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l) (fromSet f r) - -{-------------------------------------------------------------------- - Lists - use [foldlStrict] to reduce demand on the control-stack ---------------------------------------------------------------------} --- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'. --- If the list contains more than one value for the same key, the last value --- for the key is retained. --- --- If the keys of the list are ordered, linear-time implementation is used, --- with the performance equal to 'fromDistinctAscList'. --- --- > fromList [] == empty --- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] --- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] - --- For some reason, when 'singleton' is used in fromList or in --- create, it is not inlined, so we inline it manually. -fromList :: Ord k => [(k,a)] -> Map k a -fromList [] = Tip -fromList [(kx, x)] = x `seq` Bin 1 kx x Tip Tip -fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = x0 `seq` fromList' (Bin 1 kx0 x0 Tip Tip) xs0 - | otherwise = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0 - where - not_ordered _ [] = False - not_ordered kx ((ky,_) : _) = kx >= ky - {-# INLINE not_ordered #-} - - fromList' t0 xs = foldlStrict ins t0 xs - where ins t (k,x) = insert k x t - - STRICT_1_OF_3(go) - go _ t [] = t - go _ t [(kx, x)] = x `seq` insertMax kx x t - go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs - | otherwise = case create s xss of - (r, ys, []) -> x `seq` go (s `shiftL` 1) (join kx x l r) ys - (r, _, ys) -> x `seq` fromList' (join kx x l r) ys - - -- The create is returning a triple (tree, xs, ys). Both xs and ys - -- represent not yet processed elements and only one of them can be nonempty. - -- If ys is nonempty, the keys in ys are not ordered with respect to tree - -- and must be inserted using fromList'. Otherwise the keys have been - -- ordered so far. - STRICT_1_OF_2(create) - create _ [] = (Tip, [], []) - create s xs@(xp : xss) - | s == 1 = case xp of (kx, x) | not_ordered kx xss -> x `seq` (Bin 1 kx x Tip Tip, [], xss) - | otherwise -> x `seq` (Bin 1 kx x Tip Tip, xss, []) - | otherwise = case create (s `shiftR` 1) xs of - res@(_, [], _) -> res - (l, [(ky, y)], zs) -> y `seq` (insertMax ky y l, [], zs) - (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys) - | otherwise -> case create (s `shiftR` 1) yss of - (r, zs, ws) -> y `seq` (join ky y l r, zs, ws) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromList #-} -#endif - --- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. --- --- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] --- > fromListWith (++) [] == empty - -fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a -fromListWith f xs - = fromListWithKey (\_ x y -> f x y) xs -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromListWith #-} -#endif - --- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. --- --- > let f k a1 a2 = (show k) ++ a1 ++ a2 --- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")] --- > fromListWithKey f [] == empty - -fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a -fromListWithKey f xs - = foldlStrict ins empty xs - where - ins t (k,x) = insertWithKey f k x t -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromListWithKey #-} -#endif - -{-------------------------------------------------------------------- - Building trees from ascending/descending lists can be done in linear time. - - Note that if [xs] is ascending that: - fromAscList xs == fromList xs - fromAscListWith f xs == fromListWith f xs ---------------------------------------------------------------------} --- | /O(n)/. Build a map from an ascending list in linear time. --- /The precondition (input list is ascending) is not checked./ --- --- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] --- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] --- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True --- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False - -fromAscList :: Eq k => [(k,a)] -> Map k a -fromAscList xs - = fromAscListWithKey (\_ x _ -> x) xs -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromAscList #-} -#endif - --- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. --- /The precondition (input list is ascending) is not checked./ --- --- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] --- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True --- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False - -fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a -fromAscListWith f xs - = fromAscListWithKey (\_ x y -> f x y) xs -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromAscListWith #-} -#endif - --- | /O(n)/. Build a map from an ascending list in linear time with a --- combining function for equal keys. --- /The precondition (input list is ascending) is not checked./ --- --- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 --- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")] --- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True --- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False - -fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a -fromAscListWithKey f xs - = fromDistinctAscList (combineEq f xs) - where - -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] - combineEq _ xs' - = case xs' of - [] -> [] - [x] -> [x] - (x:xx) -> combineEq' x xx - - combineEq' z [] = [z] - combineEq' z@(kz,zz) (x@(kx,xx):xs') - | kx==kz = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs' - | otherwise = z:combineEq' x xs' -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromAscListWithKey #-} -#endif - --- | /O(n)/. Build a map from an ascending list of distinct elements in linear time. --- /The precondition is not checked./ --- --- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] --- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True --- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False - --- For some reason, when 'singleton' is used in fromDistinctAscList or in --- create, it is not inlined, so we inline it manually. -fromDistinctAscList :: [(k,a)] -> Map k a -fromDistinctAscList [] = Tip -fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0 - where - STRICT_1_OF_3(go) - go _ t [] = t - go s l ((kx, x) : xs) = case create s xs of - (r, ys) -> x `seq` go (s `shiftL` 1) (join kx x l r) ys - - STRICT_1_OF_2(create) - create _ [] = (Tip, []) - create s xs@(x' : xs') - | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip, xs') - | otherwise = case create (s `shiftR` 1) xs of - res@(_, []) -> res - (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of - (r, zs) -> y `seq` (join ky y l r, zs) diff --git a/containers-0.5.2.1/Darcs/Data/Set/Base.hs b/containers-0.5.2.1/Darcs/Data/Set/Base.hs deleted file mode 100644 --- a/containers-0.5.2.1/Darcs/Data/Set/Base.hs +++ /dev/null @@ -1,1526 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} -#endif -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 -{-# LANGUAGE Trustworthy #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Set.Base --- Copyright : (c) Daan Leijen 2002 --- License : BSD-style --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- An efficient implementation of sets. --- --- These modules are intended to be imported qualified, to avoid name --- clashes with Prelude functions, e.g. --- --- > import Data.Set (Set) --- > import qualified Data.Set as Set --- --- The implementation of 'Set' is based on /size balanced/ binary trees (or --- trees of /bounded balance/) as described by: --- --- * Stephen Adams, \"/Efficient sets: a balancing act/\", --- Journal of Functional Programming 3(4):553-562, October 1993, --- . --- --- * J. Nievergelt and E.M. Reingold, --- \"/Binary search trees of bounded balance/\", --- SIAM journal of computing 2(1), March 1973. --- --- Note that the implementation is /left-biased/ -- the elements of a --- first argument are always preferred to the second, for example in --- 'union' or 'insert'. Of course, left-biasing can only be observed --- when equality is an equivalence relation instead of structural --- equality. ------------------------------------------------------------------------------ - --- [Note: Using INLINABLE] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- It is crucial to the performance that the functions specialize on the Ord --- type when possible. GHC 7.0 and higher does this by itself when it sees th --- unfolding of a function -- that is why all public functions are marked --- INLINABLE (that exposes the unfolding). - - --- [Note: Using INLINE] --- ~~~~~~~~~~~~~~~~~~~~ --- For other compilers and GHC pre 7.0, we mark some of the functions INLINE. --- We mark the functions that just navigate down the tree (lookup, insert, --- delete and similar). That navigation code gets inlined and thus specialized --- when possible. There is a price to pay -- code growth. The code INLINED is --- therefore only the tree navigation, all the real work (rebalancing) is not --- INLINED by using a NOINLINE. --- --- All methods marked INLINE have to be nonrecursive -- a 'go' function doing --- the real work is provided. - - --- [Note: Type of local 'go' function] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- If the local 'go' function uses an Ord class, it sometimes heap-allocates --- the Ord dictionary when the 'go' function does not have explicit type. --- In that case we give 'go' explicit type. But this slightly decrease --- performance, as the resulting 'go' function can float out to top level. - - --- [Note: Local 'go' functions and capturing] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- As opposed to IntSet, when 'go' function captures an argument, increased --- heap-allocation can occur: sometimes in a polymorphic function, the 'go' --- floats out of its enclosing function and then it heap-allocates the --- dictionary and the argument. Maybe it floats out too late and strictness --- analyzer cannot see that these could be passed on stack. --- --- For example, change 'member' so that its local 'go' function is not passing --- argument x and then look at the resulting code for hedgeInt. - - --- [Note: Order of constructors] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The order of constructors of Set matters when considering performance. --- Currently in GHC 7.0, when type has 2 constructors, a forward conditional --- jump is made when successfully matching second constructor. Successful match --- of first constructor results in the forward jump not taken. --- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip --- improves the benchmark by up to 10% on x86. - -module Darcs.Data.Set.Base ( - -- * Set type - Set(..) -- instance Eq,Ord,Show,Read,Data,Typeable - - -- * Operators - , (\\) - - -- * Query - , null - , size - , member - , notMember - , lookupLT - , lookupGT - , lookupLE - , lookupGE - , isSubsetOf - , isProperSubsetOf - - -- * Construction - , empty - , singleton - , insert - , delete - - -- * Combine - , union - , unions - , difference - , intersection - - -- * Filter - , filter - , partition - , split - , splitMember - - -- * Indexed - , lookupIndex - , findIndex - , elemAt - , deleteAt - - -- * Map - , map - , mapMonotonic - - -- * Folds - , foldr - , foldl - -- ** Strict folds - , foldr' - , foldl' - -- ** Legacy folds - , fold - - -- * Min\/Max - , findMin - , findMax - , deleteMin - , deleteMax - , deleteFindMin - , deleteFindMax - , maxView - , minView - - -- * Conversion - - -- ** List - , elems - , toList - , fromList - - -- ** Ordered list - , toAscList - , toDescList - , fromAscList - , fromDistinctAscList - - -- * Debugging - , showTree - , showTreeWith - , valid - - -- Internals (for testing) - , bin - , balanced - , join - , merge - ) where - -import Prelude hiding (filter,foldl,foldr,null,map) -import qualified Data.List as List -import Data.Bits (shiftL, shiftR) -import Data.Monoid (Monoid(..)) -import qualified Data.Foldable as Foldable -import Data.Typeable -import Control.DeepSeq (NFData(rnf)) - -import Darcs.Data.StrictPair - -#if __GLASGOW_HASKELL__ -import GHC.Exts ( build ) -import Text.Read -import Data.Data -#endif - --- Use macros to define strictness of functions. --- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter. --- We do not use BangPatterns, because they are not in any standard and we --- want the compilers to be compiled by as many compilers as possible. -#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined -#define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined -#define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined - -{-------------------------------------------------------------------- - Operators ---------------------------------------------------------------------} -infixl 9 \\ -- - --- | /O(n+m)/. See 'difference'. -(\\) :: Ord a => Set a -> Set a -> Set a -m1 \\ m2 = difference m1 m2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE (\\) #-} -#endif - -{-------------------------------------------------------------------- - Sets are size balanced trees ---------------------------------------------------------------------} --- | A set of values @a@. - --- See Note: Order of constructors -data Set a = Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a) - | Tip - -type Size = Int - -instance Ord a => Monoid (Set a) where - mempty = empty - mappend = union - mconcat = unions - -instance Foldable.Foldable Set where - fold Tip = mempty - fold (Bin _ k l r) = Foldable.fold l `mappend` k `mappend` Foldable.fold r - foldr = foldr - foldl = foldl - foldMap _ Tip = mempty - foldMap f (Bin _ k l r) = Foldable.foldMap f l `mappend` f k `mappend` Foldable.foldMap f r - -#if __GLASGOW_HASKELL__ - -{-------------------------------------------------------------------- - A Data instance ---------------------------------------------------------------------} - --- This instance preserves data abstraction at the cost of inefficiency. --- We provide limited reflection services for the sake of data abstraction. - -instance (Data a, Ord a) => Data (Set a) where - gfoldl f z set = z fromList `f` (toList set) - toConstr _ = fromListConstr - gunfold k z c = case constrIndex c of - 1 -> k (z fromList) - _ -> error "gunfold" - dataTypeOf _ = setDataType - dataCast1 f = gcast1 f - -fromListConstr :: Constr -fromListConstr = mkConstr setDataType "fromList" [] Prefix - -setDataType :: DataType -setDataType = mkDataType "Data.Set.Base.Set" [fromListConstr] - -#endif - -{-------------------------------------------------------------------- - Query ---------------------------------------------------------------------} --- | /O(1)/. Is this the empty set? -null :: Set a -> Bool -null Tip = True -null (Bin {}) = False -{-# INLINE null #-} - --- | /O(1)/. The number of elements in the set. -size :: Set a -> Int -size Tip = 0 -size (Bin sz _ _ _) = sz -{-# INLINE size #-} - --- | /O(log n)/. Is the element in the set? -member :: Ord a => a -> Set a -> Bool -member = go - where - STRICT_1_OF_2(go) - go _ Tip = False - go x (Bin _ y l r) = case compare x y of - LT -> go x l - GT -> go x r - EQ -> True -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE member #-} -#else -{-# INLINE member #-} -#endif - --- | /O(log n)/. Is the element not in the set? -notMember :: Ord a => a -> Set a -> Bool -notMember a t = not $ member a t -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE notMember #-} -#else -{-# INLINE notMember #-} -#endif - --- | /O(log n)/. Find largest element smaller than the given one. --- --- > lookupLT 3 (fromList [3, 5]) == Nothing --- > lookupLT 5 (fromList [3, 5]) == Just 3 -lookupLT :: Ord a => a -> Set a -> Maybe a -lookupLT = goNothing - where - STRICT_1_OF_2(goNothing) - goNothing _ Tip = Nothing - goNothing x (Bin _ y l r) | x <= y = goNothing x l - | otherwise = goJust x y r - - STRICT_1_OF_3(goJust) - goJust _ best Tip = Just best - goJust x best (Bin _ y l r) | x <= y = goJust x best l - | otherwise = goJust x y r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE lookupLT #-} -#else -{-# INLINE lookupLT #-} -#endif - --- | /O(log n)/. Find smallest element greater than the given one. --- --- > lookupGT 4 (fromList [3, 5]) == Just 5 --- > lookupGT 5 (fromList [3, 5]) == Nothing -lookupGT :: Ord a => a -> Set a -> Maybe a -lookupGT = goNothing - where - STRICT_1_OF_2(goNothing) - goNothing _ Tip = Nothing - goNothing x (Bin _ y l r) | x < y = goJust x y l - | otherwise = goNothing x r - - STRICT_1_OF_3(goJust) - goJust _ best Tip = Just best - goJust x best (Bin _ y l r) | x < y = goJust x y l - | otherwise = goJust x best r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE lookupGT #-} -#else -{-# INLINE lookupGT #-} -#endif - --- | /O(log n)/. Find largest element smaller or equal to the given one. --- --- > lookupLE 2 (fromList [3, 5]) == Nothing --- > lookupLE 4 (fromList [3, 5]) == Just 3 --- > lookupLE 5 (fromList [3, 5]) == Just 5 -lookupLE :: Ord a => a -> Set a -> Maybe a -lookupLE = goNothing - where - STRICT_1_OF_2(goNothing) - goNothing _ Tip = Nothing - goNothing x (Bin _ y l r) = case compare x y of LT -> goNothing x l - EQ -> Just y - GT -> goJust x y r - - STRICT_1_OF_3(goJust) - goJust _ best Tip = Just best - goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x best l - EQ -> Just y - GT -> goJust x y r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE lookupLE #-} -#else -{-# INLINE lookupLE #-} -#endif - --- | /O(log n)/. Find smallest element greater or equal to the given one. --- --- > lookupGE 3 (fromList [3, 5]) == Just 3 --- > lookupGE 4 (fromList [3, 5]) == Just 5 --- > lookupGE 6 (fromList [3, 5]) == Nothing -lookupGE :: Ord a => a -> Set a -> Maybe a -lookupGE = goNothing - where - STRICT_1_OF_2(goNothing) - goNothing _ Tip = Nothing - goNothing x (Bin _ y l r) = case compare x y of LT -> goJust x y l - EQ -> Just y - GT -> goNothing x r - - STRICT_1_OF_3(goJust) - goJust _ best Tip = Just best - goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x y l - EQ -> Just y - GT -> goJust x best r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE lookupGE #-} -#else -{-# INLINE lookupGE #-} -#endif - -{-------------------------------------------------------------------- - Construction ---------------------------------------------------------------------} --- | /O(1)/. The empty set. -empty :: Set a -empty = Tip -{-# INLINE empty #-} - --- | /O(1)/. Create a singleton set. -singleton :: a -> Set a -singleton x = Bin 1 x Tip Tip -{-# INLINE singleton #-} - -{-------------------------------------------------------------------- - Insertion, Deletion ---------------------------------------------------------------------} --- | /O(log n)/. Insert an element in a set. --- If the set already contains an element equal to the given value, --- it is replaced with the new value. - --- See Note: Type of local 'go' function -insert :: Ord a => a -> Set a -> Set a -insert = go - where - go :: Ord a => a -> Set a -> Set a - STRICT_1_OF_2(go) - go x Tip = singleton x - go x (Bin sz y l r) = case compare x y of - LT -> balanceL y (go x l) r - GT -> balanceR y l (go x r) - EQ -> Bin sz x l r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE insert #-} -#else -{-# INLINE insert #-} -#endif - --- Insert an element to the set only if it is not in the set. --- Used by `union`. - --- See Note: Type of local 'go' function -insertR :: Ord a => a -> Set a -> Set a -insertR = go - where - go :: Ord a => a -> Set a -> Set a - STRICT_1_OF_2(go) - go x Tip = singleton x - go x t@(Bin _ y l r) = case compare x y of - LT -> balanceL y (go x l) r - GT -> balanceR y l (go x r) - EQ -> t -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE insertR #-} -#else -{-# INLINE insertR #-} -#endif - --- | /O(log n)/. Delete an element from a set. - --- See Note: Type of local 'go' function -delete :: Ord a => a -> Set a -> Set a -delete = go - where - go :: Ord a => a -> Set a -> Set a - STRICT_1_OF_2(go) - go _ Tip = Tip - go x (Bin _ y l r) = case compare x y of - LT -> balanceR y (go x l) r - GT -> balanceL y l (go x r) - EQ -> glue l r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE delete #-} -#else -{-# INLINE delete #-} -#endif - -{-------------------------------------------------------------------- - Subset ---------------------------------------------------------------------} --- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). -isProperSubsetOf :: Ord a => Set a -> Set a -> Bool -isProperSubsetOf s1 s2 - = (size s1 < size s2) && (isSubsetOf s1 s2) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE isProperSubsetOf #-} -#endif - - --- | /O(n+m)/. Is this a subset? --- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@. -isSubsetOf :: Ord a => Set a -> Set a -> Bool -isSubsetOf t1 t2 - = (size t1 <= size t2) && (isSubsetOfX t1 t2) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE isSubsetOf #-} -#endif - -isSubsetOfX :: Ord a => Set a -> Set a -> Bool -isSubsetOfX Tip _ = True -isSubsetOfX _ Tip = False -isSubsetOfX (Bin _ x l r) t - = found && isSubsetOfX l lt && isSubsetOfX r gt - where - (lt,found,gt) = splitMember x t -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE isSubsetOfX #-} -#endif - - -{-------------------------------------------------------------------- - Minimal, Maximal ---------------------------------------------------------------------} --- | /O(log n)/. The minimal element of a set. -findMin :: Set a -> a -findMin (Bin _ x Tip _) = x -findMin (Bin _ _ l _) = findMin l -findMin Tip = error "Set.findMin: empty set has no minimal element" - --- | /O(log n)/. The maximal element of a set. -findMax :: Set a -> a -findMax (Bin _ x _ Tip) = x -findMax (Bin _ _ _ r) = findMax r -findMax Tip = error "Set.findMax: empty set has no maximal element" - --- | /O(log n)/. Delete the minimal element. Returns an empty set if the set is empty. -deleteMin :: Set a -> Set a -deleteMin (Bin _ _ Tip r) = r -deleteMin (Bin _ x l r) = balanceR x (deleteMin l) r -deleteMin Tip = Tip - --- | /O(log n)/. Delete the maximal element. Returns an empty set if the set is empty. -deleteMax :: Set a -> Set a -deleteMax (Bin _ _ l Tip) = l -deleteMax (Bin _ x l r) = balanceL x l (deleteMax r) -deleteMax Tip = Tip - -{-------------------------------------------------------------------- - Union. ---------------------------------------------------------------------} --- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@). -unions :: Ord a => [Set a] -> Set a -unions = foldlStrict union empty -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE unions #-} -#endif - --- | /O(n+m)/. The union of two sets, preferring the first set when --- equal elements are encountered. --- The implementation uses the efficient /hedge-union/ algorithm. -union :: Ord a => Set a -> Set a -> Set a -union Tip t2 = t2 -union t1 Tip = t1 -union t1 t2 = hedgeUnion NothingS NothingS t1 t2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE union #-} -#endif - -hedgeUnion :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a -hedgeUnion _ _ t1 Tip = t1 -hedgeUnion blo bhi Tip (Bin _ x l r) = join x (filterGt blo l) (filterLt bhi r) -hedgeUnion _ _ t1 (Bin _ x Tip Tip) = insertR x t1 -- According to benchmarks, this special case increases - -- performance up to 30%. It does not help in difference or intersection. -hedgeUnion blo bhi (Bin _ x l r) t2 = join x (hedgeUnion blo bmi l (trim blo bmi t2)) - (hedgeUnion bmi bhi r (trim bmi bhi t2)) - where bmi = JustS x -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE hedgeUnion #-} -#endif - -{-------------------------------------------------------------------- - Difference ---------------------------------------------------------------------} --- | /O(n+m)/. Difference of two sets. --- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. -difference :: Ord a => Set a -> Set a -> Set a -difference Tip _ = Tip -difference t1 Tip = t1 -difference t1 t2 = hedgeDiff NothingS NothingS t1 t2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE difference #-} -#endif - -hedgeDiff :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a -hedgeDiff _ _ Tip _ = Tip -hedgeDiff blo bhi (Bin _ x l r) Tip = join x (filterGt blo l) (filterLt bhi r) -hedgeDiff blo bhi t (Bin _ x l r) = merge (hedgeDiff blo bmi (trim blo bmi t) l) - (hedgeDiff bmi bhi (trim bmi bhi t) r) - where bmi = JustS x -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE hedgeDiff #-} -#endif - -{-------------------------------------------------------------------- - Intersection ---------------------------------------------------------------------} --- | /O(n+m)/. The intersection of two sets. The implementation uses an --- efficient /hedge/ algorithm comparable with /hedge-union/. Elements of the --- result come from the first set, so for example --- --- > import qualified Data.Set as S --- > data AB = A | B deriving Show --- > instance Ord AB where compare _ _ = EQ --- > instance Eq AB where _ == _ = True --- > main = print (S.singleton A `S.intersection` S.singleton B, --- > S.singleton B `S.intersection` S.singleton A) --- --- prints @(fromList [A],fromList [B])@. -intersection :: Ord a => Set a -> Set a -> Set a -intersection Tip _ = Tip -intersection _ Tip = Tip -intersection t1 t2 = hedgeInt NothingS NothingS t1 t2 -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE intersection #-} -#endif - -hedgeInt :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a -hedgeInt _ _ _ Tip = Tip -hedgeInt _ _ Tip _ = Tip -hedgeInt blo bhi (Bin _ x l r) t2 = let l' = hedgeInt blo bmi l (trim blo bmi t2) - r' = hedgeInt bmi bhi r (trim bmi bhi t2) - in if x `member` t2 then join x l' r' else merge l' r' - where bmi = JustS x -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE hedgeInt #-} -#endif - -{-------------------------------------------------------------------- - Filter and partition ---------------------------------------------------------------------} --- | /O(n)/. Filter all elements that satisfy the predicate. -filter :: (a -> Bool) -> Set a -> Set a -filter _ Tip = Tip -filter p (Bin _ x l r) - | p x = join x (filter p l) (filter p r) - | otherwise = merge (filter p l) (filter p r) - --- | /O(n)/. Partition the set into two sets, one with all elements that satisfy --- the predicate and one with all elements that don't satisfy the predicate. --- See also 'split'. -partition :: (a -> Bool) -> Set a -> (Set a,Set a) -partition p0 t0 = toPair $ go p0 t0 - where - go _ Tip = (Tip :*: Tip) - go p (Bin _ x l r) = case (go p l, go p r) of - ((l1 :*: l2), (r1 :*: r2)) - | p x -> join x l1 r1 :*: merge l2 r2 - | otherwise -> merge l1 r1 :*: join x l2 r2 - -{---------------------------------------------------------------------- - Map -----------------------------------------------------------------------} - --- | /O(n*log n)/. --- @'map' f s@ is the set obtained by applying @f@ to each element of @s@. --- --- It's worth noting that the size of the result may be smaller if, --- for some @(x,y)@, @x \/= y && f x == f y@ - -map :: Ord b => (a->b) -> Set a -> Set b -map f = fromList . List.map f . toList -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE map #-} -#endif - --- | /O(n)/. The --- --- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is monotonic. --- /The precondition is not checked./ --- Semi-formally, we have: --- --- > and [x < y ==> f x < f y | x <- ls, y <- ls] --- > ==> mapMonotonic f s == map f s --- > where ls = toList s - -mapMonotonic :: (a->b) -> Set a -> Set b -mapMonotonic _ Tip = Tip -mapMonotonic f (Bin sz x l r) = Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r) - -{-------------------------------------------------------------------- - Fold ---------------------------------------------------------------------} --- | /O(n)/. Fold the elements in the set using the given right-associative --- binary operator. This function is an equivalent of 'foldr' and is present --- for compatibility only. --- --- /Please note that fold will be deprecated in the future and removed./ -fold :: (a -> b -> b) -> b -> Set a -> b -fold = foldr -{-# INLINE fold #-} - --- | /O(n)/. Fold the elements in the set using the given right-associative --- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@. --- --- For example, --- --- > toAscList set = foldr (:) [] set -foldr :: (a -> b -> b) -> b -> Set a -> b -foldr f z = go z - where - go z' Tip = z' - go z' (Bin _ x l r) = go (f x (go z' r)) l -{-# INLINE foldr #-} - --- | /O(n)/. A strict version of 'foldr'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldr' :: (a -> b -> b) -> b -> Set a -> b -foldr' f z = go z - where - STRICT_1_OF_2(go) - go z' Tip = z' - go z' (Bin _ x l r) = go (f x (go z' r)) l -{-# INLINE foldr' #-} - --- | /O(n)/. Fold the elements in the set using the given left-associative --- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@. --- --- For example, --- --- > toDescList set = foldl (flip (:)) [] set -foldl :: (a -> b -> a) -> a -> Set b -> a -foldl f z = go z - where - go z' Tip = z' - go z' (Bin _ x l r) = go (f (go z' l) x) r -{-# INLINE foldl #-} - --- | /O(n)/. A strict version of 'foldl'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldl' :: (a -> b -> a) -> a -> Set b -> a -foldl' f z = go z - where - STRICT_1_OF_2(go) - go z' Tip = z' - go z' (Bin _ x l r) = go (f (go z' l) x) r -{-# INLINE foldl' #-} - -{-------------------------------------------------------------------- - List variations ---------------------------------------------------------------------} --- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order. --- Subject to list fusion. -elems :: Set a -> [a] -elems = toAscList - -{-------------------------------------------------------------------- - Lists ---------------------------------------------------------------------} --- | /O(n)/. Convert the set to a list of elements. Subject to list fusion. -toList :: Set a -> [a] -toList = toAscList - --- | /O(n)/. Convert the set to an ascending list of elements. Subject to list fusion. -toAscList :: Set a -> [a] -toAscList = foldr (:) [] - --- | /O(n)/. Convert the set to a descending list of elements. Subject to list --- fusion. -toDescList :: Set a -> [a] -toDescList = foldl (flip (:)) [] - --- List fusion for the list generating functions. -#if __GLASGOW_HASKELL__ --- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion. --- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude. -foldrFB :: (a -> b -> b) -> b -> Set a -> b -foldrFB = foldr -{-# INLINE[0] foldrFB #-} -foldlFB :: (a -> b -> a) -> a -> Set b -> a -foldlFB = foldl -{-# INLINE[0] foldlFB #-} - --- Inline elems and toList, so that we need to fuse only toAscList. -{-# INLINE elems #-} -{-# INLINE toList #-} - --- The fusion is enabled up to phase 2 included. If it does not succeed, --- convert in phase 1 the expanded to{Asc,Desc}List calls back to --- to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were used in --- a list fusion, otherwise it would go away in phase 1), and let compiler do --- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it --- before phase 0, otherwise the fusion rules would not fire at all. -{-# NOINLINE[0] toAscList #-} -{-# NOINLINE[0] toDescList #-} -{-# RULES "Set.toAscList" [~1] forall s . toAscList s = build (\c n -> foldrFB c n s) #-} -{-# RULES "Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-} -{-# RULES "Set.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-} -{-# RULES "Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-} -#endif - --- | /O(n*log n)/. Create a set from a list of elements. --- --- If the elemens are ordered, linear-time implementation is used, --- with the performance equal to 'fromDistinctAscList'. - --- For some reason, when 'singleton' is used in fromList or in --- create, it is not inlined, so we inline it manually. -fromList :: Ord a => [a] -> Set a -fromList [] = Tip -fromList [x] = Bin 1 x Tip Tip -fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0 - | otherwise = go (1::Int) (Bin 1 x0 Tip Tip) xs0 - where - not_ordered _ [] = False - not_ordered x (y : _) = x >= y - {-# INLINE not_ordered #-} - - fromList' t0 xs = foldlStrict ins t0 xs - where ins t x = insert x t - - STRICT_1_OF_3(go) - go _ t [] = t - go _ t [x] = insertMax x t - go s l xs@(x : xss) | not_ordered x xss = fromList' l xs - | otherwise = case create s xss of - (r, ys, []) -> go (s `shiftL` 1) (join x l r) ys - (r, _, ys) -> fromList' (join x l r) ys - - -- The create is returning a triple (tree, xs, ys). Both xs and ys - -- represent not yet processed elements and only one of them can be nonempty. - -- If ys is nonempty, the keys in ys are not ordered with respect to tree - -- and must be inserted using fromList'. Otherwise the keys have been - -- ordered so far. - STRICT_1_OF_2(create) - create _ [] = (Tip, [], []) - create s xs@(x : xss) - | s == 1 = if not_ordered x xss then (Bin 1 x Tip Tip, [], xss) - else (Bin 1 x Tip Tip, xss, []) - | otherwise = case create (s `shiftR` 1) xs of - res@(_, [], _) -> res - (l, [y], zs) -> (insertMax y l, [], zs) - (l, ys@(y:yss), _) | not_ordered y yss -> (l, [], ys) - | otherwise -> case create (s `shiftR` 1) yss of - (r, zs, ws) -> (join y l r, zs, ws) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromList #-} -#endif - -{-------------------------------------------------------------------- - Building trees from ascending/descending lists can be done in linear time. - - Note that if [xs] is ascending that: - fromAscList xs == fromList xs ---------------------------------------------------------------------} --- | /O(n)/. Build a set from an ascending list in linear time. --- /The precondition (input list is ascending) is not checked./ -fromAscList :: Eq a => [a] -> Set a -fromAscList xs - = fromDistinctAscList (combineEq xs) - where - -- [combineEq xs] combines equal elements with [const] in an ordered list [xs] - combineEq xs' - = case xs' of - [] -> [] - [x] -> [x] - (x:xx) -> combineEq' x xx - - combineEq' z [] = [z] - combineEq' z (x:xs') - | z==x = combineEq' z xs' - | otherwise = z:combineEq' x xs' -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE fromAscList #-} -#endif - - --- | /O(n)/. Build a set from an ascending list of distinct elements in linear time. --- /The precondition (input list is strictly ascending) is not checked./ - --- For some reason, when 'singleton' is used in fromDistinctAscList or in --- create, it is not inlined, so we inline it manually. -fromDistinctAscList :: [a] -> Set a -fromDistinctAscList [] = Tip -fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0 - where - STRICT_1_OF_3(go) - go _ t [] = t - go s l (x : xs) = case create s xs of - (r, ys) -> go (s `shiftL` 1) (join x l r) ys - - STRICT_1_OF_2(create) - create _ [] = (Tip, []) - create s xs@(x : xs') - | s == 1 = (Bin 1 x Tip Tip, xs') - | otherwise = case create (s `shiftR` 1) xs of - res@(_, []) -> res - (l, y:ys) -> case create (s `shiftR` 1) ys of - (r, zs) -> (join y l r, zs) - -{-------------------------------------------------------------------- - Eq converts the set to a list. In a lazy setting, this - actually seems one of the faster methods to compare two trees - and it is certainly the simplest :-) ---------------------------------------------------------------------} -instance Eq a => Eq (Set a) where - t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2) - -{-------------------------------------------------------------------- - Ord ---------------------------------------------------------------------} - -instance Ord a => Ord (Set a) where - compare s1 s2 = compare (toAscList s1) (toAscList s2) - -{-------------------------------------------------------------------- - Show ---------------------------------------------------------------------} -instance Show a => Show (Set a) where - showsPrec p xs = showParen (p > 10) $ - showString "fromList " . shows (toList xs) - -{-------------------------------------------------------------------- - Read ---------------------------------------------------------------------} -instance (Read a, Ord a) => Read (Set a) where -#ifdef __GLASGOW_HASKELL__ - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - xs <- readPrec - return (fromList xs) - - readListPrec = readListPrecDefault -#else - readsPrec p = readParen (p > 10) $ \ r -> do - ("fromList",s) <- lex r - (xs,t) <- reads s - return (fromList xs,t) -#endif - -{-------------------------------------------------------------------- - Typeable/Data ---------------------------------------------------------------------} - -#include "Typeable.h" -INSTANCE_TYPEABLE1(Set,setTc,"Set") - -{-------------------------------------------------------------------- - NFData ---------------------------------------------------------------------} - -instance NFData a => NFData (Set a) where - rnf Tip = () - rnf (Bin _ y l r) = rnf y `seq` rnf l `seq` rnf r - -{-------------------------------------------------------------------- - Utility functions that return sub-ranges of the original - tree. Some functions take a `Maybe value` as an argument to - allow comparisons against infinite values. These are called `blow` - (Nothing is -\infty) and `bhigh` (here Nothing is +\infty). - We use MaybeS value, which is a Maybe strict in the Just case. - - [trim blow bhigh t] A tree that is either empty or where [x > blow] - and [x < bhigh] for the value [x] of the root. - [filterGt blow t] A tree where for all values [k]. [k > blow] - [filterLt bhigh t] A tree where for all values [k]. [k < bhigh] - - [split k t] Returns two trees [l] and [r] where all values - in [l] are <[k] and all keys in [r] are >[k]. - [splitMember k t] Just like [split] but also returns whether [k] - was found in the tree. ---------------------------------------------------------------------} - -data MaybeS a = NothingS | JustS !a - -{-------------------------------------------------------------------- - [trim blo bhi t] trims away all subtrees that surely contain no - values between the range [blo] to [bhi]. The returned tree is either - empty or the key of the root is between @blo@ and @bhi@. ---------------------------------------------------------------------} -trim :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a -trim NothingS NothingS t = t -trim (JustS lx) NothingS t = greater lx t where greater lo (Bin _ x _ r) | x <= lo = greater lo r - greater _ t' = t' -trim NothingS (JustS hx) t = lesser hx t where lesser hi (Bin _ x l _) | x >= hi = lesser hi l - lesser _ t' = t' -trim (JustS lx) (JustS hx) t = middle lx hx t where middle lo hi (Bin _ x _ r) | x <= lo = middle lo hi r - middle lo hi (Bin _ x l _) | x >= hi = middle lo hi l - middle _ _ t' = t' -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE trim #-} -#endif - -{-------------------------------------------------------------------- - [filterGt b t] filter all values >[b] from tree [t] - [filterLt b t] filter all values <[b] from tree [t] ---------------------------------------------------------------------} -filterGt :: Ord a => MaybeS a -> Set a -> Set a -filterGt NothingS t = t -filterGt (JustS b) t = filter' b t - where filter' _ Tip = Tip - filter' b' (Bin _ x l r) = - case compare b' x of LT -> join x (filter' b' l) r - EQ -> r - GT -> filter' b' r -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE filterGt #-} -#endif - -filterLt :: Ord a => MaybeS a -> Set a -> Set a -filterLt NothingS t = t -filterLt (JustS b) t = filter' b t - where filter' _ Tip = Tip - filter' b' (Bin _ x l r) = - case compare x b' of LT -> join x l (filter' b' r) - EQ -> l - GT -> filter' b' l -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE filterLt #-} -#endif - -{-------------------------------------------------------------------- - Split ---------------------------------------------------------------------} --- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@ --- where @set1@ comprises the elements of @set@ less than @x@ and @set2@ --- comprises the elements of @set@ greater than @x@. -split :: Ord a => a -> Set a -> (Set a,Set a) -split x0 t0 = toPair $ go x0 t0 - where - go _ Tip = (Tip :*: Tip) - go x (Bin _ y l r) - = case compare x y of - LT -> let (lt :*: gt) = go x l in (lt :*: join y gt r) - GT -> let (lt :*: gt) = go x r in (join y l lt :*: gt) - EQ -> (l :*: r) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE split #-} -#endif - --- | /O(log n)/. Performs a 'split' but also returns whether the pivot --- element was found in the original set. -splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a) -splitMember _ Tip = (Tip, False, Tip) -splitMember x (Bin _ y l r) - = case compare x y of - LT -> let (lt, found, gt) = splitMember x l - gt' = join y gt r - in gt' `seq` (lt, found, gt') - GT -> let (lt, found, gt) = splitMember x r - lt' = join y l lt - in lt' `seq` (lt', found, gt) - EQ -> (l, True, r) -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE splitMember #-} -#endif - -{-------------------------------------------------------------------- - Indexing ---------------------------------------------------------------------} - --- | /O(log n)/. Return the /index/ of an element, which is its zero-based --- index in the sorted sequence of elements. The index is a number from /0/ up --- to, but not including, the 'size' of the set. Calls 'error' when the element --- is not a 'member' of the set. --- --- > findIndex 2 (fromList [5,3]) Error: element is not in the set --- > findIndex 3 (fromList [5,3]) == 0 --- > findIndex 5 (fromList [5,3]) == 1 --- > findIndex 6 (fromList [5,3]) Error: element is not in the set - --- See Note: Type of local 'go' function -findIndex :: Ord a => a -> Set a -> Int -findIndex = go 0 - where - go :: Ord a => Int -> a -> Set a -> Int - STRICT_1_OF_3(go) - STRICT_2_OF_3(go) - go _ _ Tip = error "Set.findIndex: element is not in the set" - go idx x (Bin _ kx l r) = case compare x kx of - LT -> go idx x l - GT -> go (idx + size l + 1) x r - EQ -> idx + size l -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE findIndex #-} -#endif - --- | /O(log n)/. Lookup the /index/ of an element, which is its zero-based index in --- the sorted sequence of elements. The index is a number from /0/ up to, but not --- including, the 'size' of the set. --- --- > isJust (lookupIndex 2 (fromList [5,3])) == False --- > fromJust (lookupIndex 3 (fromList [5,3])) == 0 --- > fromJust (lookupIndex 5 (fromList [5,3])) == 1 --- > isJust (lookupIndex 6 (fromList [5,3])) == False - --- See Note: Type of local 'go' function -lookupIndex :: Ord a => a -> Set a -> Maybe Int -lookupIndex = go 0 - where - go :: Ord a => Int -> a -> Set a -> Maybe Int - STRICT_1_OF_3(go) - STRICT_2_OF_3(go) - go _ _ Tip = Nothing - go idx x (Bin _ kx l r) = case compare x kx of - LT -> go idx x l - GT -> go (idx + size l + 1) x r - EQ -> Just $! idx + size l -#if __GLASGOW_HASKELL__ >= 700 -{-# INLINABLE lookupIndex #-} -#endif - --- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based --- index in the sorted sequence of elements. If the /index/ is out of range (less --- than zero, greater or equal to 'size' of the set), 'error' is called. --- --- > elemAt 0 (fromList [5,3]) == 3 --- > elemAt 1 (fromList [5,3]) == 5 --- > elemAt 2 (fromList [5,3]) Error: index out of range - -elemAt :: Int -> Set a -> a -STRICT_1_OF_2(elemAt) -elemAt _ Tip = error "Set.elemAt: index out of range" -elemAt i (Bin _ x l r) - = case compare i sizeL of - LT -> elemAt i l - GT -> elemAt (i-sizeL-1) r - EQ -> x - where - sizeL = size l - --- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in --- the sorted sequence of elements. If the /index/ is out of range (less than zero, --- greater or equal to 'size' of the set), 'error' is called. --- --- > deleteAt 0 (fromList [5,3]) == singleton 5 --- > deleteAt 1 (fromList [5,3]) == singleton 3 --- > deleteAt 2 (fromList [5,3]) Error: index out of range --- > deleteAt (-1) (fromList [5,3]) Error: index out of range - -deleteAt :: Int -> Set a -> Set a -deleteAt i t = i `seq` - case t of - Tip -> error "Set.deleteAt: index out of range" - Bin _ x l r -> case compare i sizeL of - LT -> balanceR x (deleteAt i l) r - GT -> balanceL x l (deleteAt (i-sizeL-1) r) - EQ -> glue l r - where - sizeL = size l - - -{-------------------------------------------------------------------- - Utility functions that maintain the balance properties of the tree. - All constructors assume that all values in [l] < [x] and all values - in [r] > [x], and that [l] and [r] are valid trees. - - In order of sophistication: - [Bin sz x l r] The type constructor. - [bin x l r] Maintains the correct size, assumes that both [l] - and [r] are balanced with respect to each other. - [balance x l r] Restores the balance and size. - Assumes that the original tree was balanced and - that [l] or [r] has changed by at most one element. - [join x l r] Restores balance and size. - - Furthermore, we can construct a new tree from two trees. Both operations - assume that all values in [l] < all values in [r] and that [l] and [r] - are valid: - [glue l r] Glues [l] and [r] together. Assumes that [l] and - [r] are already balanced with respect to each other. - [merge l r] Merges two trees and restores balance. - - Note: in contrast to Adam's paper, we use (<=) comparisons instead - of (<) comparisons in [join], [merge] and [balance]. - Quickcheck (on [difference]) showed that this was necessary in order - to maintain the invariants. It is quite unsatisfactory that I haven't - been able to find out why this is actually the case! Fortunately, it - doesn't hurt to be a bit more conservative. ---------------------------------------------------------------------} - -{-------------------------------------------------------------------- - Join ---------------------------------------------------------------------} -join :: a -> Set a -> Set a -> Set a -join x Tip r = insertMin x r -join x l Tip = insertMax x l -join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz) - | delta*sizeL < sizeR = balanceL z (join x l lz) rz - | delta*sizeR < sizeL = balanceR y ly (join x ry r) - | otherwise = bin x l r - - --- insertMin and insertMax don't perform potentially expensive comparisons. -insertMax,insertMin :: a -> Set a -> Set a -insertMax x t - = case t of - Tip -> singleton x - Bin _ y l r - -> balanceR y l (insertMax x r) - -insertMin x t - = case t of - Tip -> singleton x - Bin _ y l r - -> balanceL y (insertMin x l) r - -{-------------------------------------------------------------------- - [merge l r]: merges two trees. ---------------------------------------------------------------------} -merge :: Set a -> Set a -> Set a -merge Tip r = r -merge l Tip = l -merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry) - | delta*sizeL < sizeR = balanceL y (merge l ly) ry - | delta*sizeR < sizeL = balanceR x lx (merge rx r) - | otherwise = glue l r - -{-------------------------------------------------------------------- - [glue l r]: glues two trees together. - Assumes that [l] and [r] are already balanced with respect to each other. ---------------------------------------------------------------------} -glue :: Set a -> Set a -> Set a -glue Tip r = r -glue l Tip = l -glue l r - | size l > size r = let (m,l') = deleteFindMax l in balanceR m l' r - | otherwise = let (m,r') = deleteFindMin r in balanceL m l r' - --- | /O(log n)/. Delete and find the minimal element. --- --- > deleteFindMin set = (findMin set, deleteMin set) - -deleteFindMin :: Set a -> (a,Set a) -deleteFindMin t - = case t of - Bin _ x Tip r -> (x,r) - Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balanceR x l' r) - Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip) - --- | /O(log n)/. Delete and find the maximal element. --- --- > deleteFindMax set = (findMax set, deleteMax set) -deleteFindMax :: Set a -> (a,Set a) -deleteFindMax t - = case t of - Bin _ x l Tip -> (x,l) - Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balanceL x l r') - Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip) - --- | /O(log n)/. Retrieves the minimal key of the set, and the set --- stripped of that element, or 'Nothing' if passed an empty set. -minView :: Set a -> Maybe (a, Set a) -minView Tip = Nothing -minView x = Just (deleteFindMin x) - --- | /O(log n)/. Retrieves the maximal key of the set, and the set --- stripped of that element, or 'Nothing' if passed an empty set. -maxView :: Set a -> Maybe (a, Set a) -maxView Tip = Nothing -maxView x = Just (deleteFindMax x) - -{-------------------------------------------------------------------- - [balance x l r] balances two trees with value x. - The sizes of the trees should balance after decreasing the - size of one of them. (a rotation). - - [delta] is the maximal relative difference between the sizes of - two trees, it corresponds with the [w] in Adams' paper. - [ratio] is the ratio between an outer and inner sibling of the - heavier subtree in an unbalanced setting. It determines - whether a double or single rotation should be performed - to restore balance. It is correspondes with the inverse - of $\alpha$ in Adam's article. - - Note that according to the Adam's paper: - - [delta] should be larger than 4.646 with a [ratio] of 2. - - [delta] should be larger than 3.745 with a [ratio] of 1.534. - - But the Adam's paper is errorneous: - - it can be proved that for delta=2 and delta>=5 there does - not exist any ratio that would work - - delta=4.5 and ratio=2 does not work - - That leaves two reasonable variants, delta=3 and delta=4, - both with ratio=2. - - - A lower [delta] leads to a more 'perfectly' balanced tree. - - A higher [delta] performs less rebalancing. - - In the benchmarks, delta=3 is faster on insert operations, - and delta=4 has slightly better deletes. As the insert speedup - is larger, we currently use delta=3. - ---------------------------------------------------------------------} -delta,ratio :: Int -delta = 3 -ratio = 2 - --- The balance function is equivalent to the following: --- --- balance :: a -> Set a -> Set a -> Set a --- balance x l r --- | sizeL + sizeR <= 1 = Bin sizeX x l r --- | sizeR > delta*sizeL = rotateL x l r --- | sizeL > delta*sizeR = rotateR x l r --- | otherwise = Bin sizeX x l r --- where --- sizeL = size l --- sizeR = size r --- sizeX = sizeL + sizeR + 1 --- --- rotateL :: a -> Set a -> Set a -> Set a --- rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r --- | otherwise = doubleL x l r --- rotateR :: a -> Set a -> Set a -> Set a --- rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r --- | otherwise = doubleR x l r --- --- singleL, singleR :: a -> Set a -> Set a -> Set a --- singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3 --- singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3) --- --- doubleL, doubleR :: a -> Set a -> Set a -> Set a --- doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4) --- doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4) --- --- It is only written in such a way that every node is pattern-matched only once. --- --- Only balanceL and balanceR are needed at the moment, so balance is not here anymore. --- In case it is needed, it can be found in Data.Map. - --- Functions balanceL and balanceR are specialised versions of balance. --- balanceL only checks whether the left subtree is too big, --- balanceR only checks whether the right subtree is too big. - --- balanceL is called when left subtree might have been inserted to or when --- right subtree might have been deleted from. -balanceL :: a -> Set a -> Set a -> Set a -balanceL x l r = case r of - Tip -> case l of - Tip -> Bin 1 x Tip Tip - (Bin _ _ Tip Tip) -> Bin 2 x l Tip - (Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip) - (Bin _ lx ll@(Bin _ _ _ _) Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip) - (Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr)) - | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip) - | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip) - - (Bin rs _ _ _) -> case l of - Tip -> Bin (1+rs) x Tip r - - (Bin ls lx ll lr) - | ls > delta*rs -> case (ll, lr) of - (Bin lls _ _ _, Bin lrs lrx lrl lrr) - | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r) - | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r) - (_, _) -> error "Failure in Data.Map.balanceL" - | otherwise -> Bin (1+ls+rs) x l r -{-# NOINLINE balanceL #-} - --- balanceR is called when right subtree might have been inserted to or when --- left subtree might have been deleted from. -balanceR :: a -> Set a -> Set a -> Set a -balanceR x l r = case l of - Tip -> case r of - Tip -> Bin 1 x Tip Tip - (Bin _ _ Tip Tip) -> Bin 2 x Tip r - (Bin _ rx Tip rr@(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr - (Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip) - (Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _)) - | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr - | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr) - - (Bin ls _ _ _) -> case r of - Tip -> Bin (1+ls) x l Tip - - (Bin rs rx rl rr) - | rs > delta*ls -> case (rl, rr) of - (Bin rls rlx rll rlr, Bin rrs _ _ _) - | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr - | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr) - (_, _) -> error "Failure in Data.Map.balanceR" - | otherwise -> Bin (1+ls+rs) x l r -{-# NOINLINE balanceR #-} - -{-------------------------------------------------------------------- - The bin constructor maintains the size of the tree ---------------------------------------------------------------------} -bin :: a -> Set a -> Set a -> Set a -bin x l r - = Bin (size l + size r + 1) x l r -{-# INLINE bin #-} - - -{-------------------------------------------------------------------- - Utilities ---------------------------------------------------------------------} -foldlStrict :: (a -> b -> a) -> a -> [b] -> a -foldlStrict f = go - where - go z [] = z - go z (x:xs) = let z' = f z x in z' `seq` go z' xs -{-# INLINE foldlStrict #-} - -{-------------------------------------------------------------------- - Debugging ---------------------------------------------------------------------} --- | /O(n)/. Show the tree that implements the set. The tree is shown --- in a compressed, hanging format. -showTree :: Show a => Set a -> String -showTree s - = showTreeWith True False s - - -{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows - the tree that implements the set. If @hang@ is - @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If - @wide@ is 'True', an extra wide version is shown. - -> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5] -> 4 -> +--2 -> | +--1 -> | +--3 -> +--5 -> -> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5] -> 4 -> | -> +--2 -> | | -> | +--1 -> | | -> | +--3 -> | -> +--5 -> -> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5] -> +--5 -> | -> 4 -> | -> | +--3 -> | | -> +--2 -> | -> +--1 - --} -showTreeWith :: Show a => Bool -> Bool -> Set a -> String -showTreeWith hang wide t - | hang = (showsTreeHang wide [] t) "" - | otherwise = (showsTree wide [] [] t) "" - -showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS -showsTree wide lbars rbars t - = case t of - Tip -> showsBars lbars . showString "|\n" - Bin _ x Tip Tip - -> showsBars lbars . shows x . showString "\n" - Bin _ x l r - -> showsTree wide (withBar rbars) (withEmpty rbars) r . - showWide wide rbars . - showsBars lbars . shows x . showString "\n" . - showWide wide lbars . - showsTree wide (withEmpty lbars) (withBar lbars) l - -showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS -showsTreeHang wide bars t - = case t of - Tip -> showsBars bars . showString "|\n" - Bin _ x Tip Tip - -> showsBars bars . shows x . showString "\n" - Bin _ x l r - -> showsBars bars . shows x . showString "\n" . - showWide wide bars . - showsTreeHang wide (withBar bars) l . - showWide wide bars . - showsTreeHang wide (withEmpty bars) r - -showWide :: Bool -> [String] -> String -> String -showWide wide bars - | wide = showString (concat (reverse bars)) . showString "|\n" - | otherwise = id - -showsBars :: [String] -> ShowS -showsBars bars - = case bars of - [] -> id - _ -> showString (concat (reverse (tail bars))) . showString node - -node :: String -node = "+--" - -withBar, withEmpty :: [String] -> [String] -withBar bars = "| ":bars -withEmpty bars = " ":bars - -{-------------------------------------------------------------------- - Assertions ---------------------------------------------------------------------} --- | /O(n)/. Test if the internal set structure is valid. -valid :: Ord a => Set a -> Bool -valid t - = balanced t && ordered t && validsize t - -ordered :: Ord a => Set a -> Bool -ordered t - = bounded (const True) (const True) t - where - bounded lo hi t' - = case t' of - Tip -> True - Bin _ x l r -> (lo x) && (hi x) && bounded lo (x) hi r - -balanced :: Set a -> Bool -balanced t - = case t of - Tip -> True - Bin _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) && - balanced l && balanced r - -validsize :: Set a -> Bool -validsize t - = (realsize t == Just (size t)) - where - realsize t' - = case t' of - Tip -> Just 0 - Bin sz _ l r -> case (realsize l,realsize r) of - (Just n,Just m) | n+m+1 == sz -> Just sz - _ -> Nothing diff --git a/containers-0.5.2.1/Darcs/Data/StrictPair.hs b/containers-0.5.2.1/Darcs/Data/StrictPair.hs deleted file mode 100644 --- a/containers-0.5.2.1/Darcs/Data/StrictPair.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE CPP #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 -{-# LANGUAGE Trustworthy #-} -#endif -module Darcs.Data.StrictPair (StrictPair(..), toPair) where - --- | Same as regular Haskell pairs, but (x :*: _|_) = (_|_ :*: y) = --- _|_ -data StrictPair a b = !a :*: !b - -toPair :: StrictPair a b -> (a, b) -toPair (x :*: y) = (x, y) -{-# INLINE toPair #-} diff --git a/contrib/darcs-errors.hlint b/contrib/darcs-errors.hlint --- a/contrib/darcs-errors.hlint +++ b/contrib/darcs-errors.hlint @@ -1,28 +1,3 @@ --- Only report errors, since we use this as part of the testsuite. It needs to --- be easy to see what tripped up the testcase. - -ignore "Eta reduce" = "" -ignore "Use camelCase" = "" -ignore "Use const" = "" -ignore "Use on" = "" -ignore "Use foldr" = "" -ignore "Use String" = "" -ignore "Use string literal" = "" -ignore "Use guards" = "" -ignore "Use :" = "" -ignore "Redundant brackets" = "" -ignore "Redundant do" = "" -ignore "Redundant return" = "" -ignore "Redundant $" = "" -ignore "Redundant lambda" = "" - -ignore "Use fewer imports" = "" -ignore "Use better pragmas" = "" -ignore "Use let" = "" -ignore "Operator rotate" = "" -ignore "Use foldl" = "" -ignore "Unused LANGUAGE pragma" = "" - -- The problem with Prelude readFile is that it's based on hGetContents, which -- is lazy by definition. This also means that unless you force consumption of -- the produced list, it will keep an fd open for the file, possibly diff --git a/contrib/runHLint.sh b/contrib/runHLint.sh new file mode 100644 --- /dev/null +++ b/contrib/runHLint.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +hlint --hint=contrib/darcs-errors.hlint --cpp-simple ./src +hlint --cpp-simple ./src + +# --cpp-simple is to avoid issues with MIN_VERSION +# see https://github.com/ndmitchell/hlint/issues/53 +# using it creates other problems since #if are ignored.. + +# When the above bug is solved we can use: +# hlint --hint=contrib/darcs-errors.hlint --cpp-include=./src ./src +# hlint --cpp-include=./src ./src diff --git a/darcs.cabal b/darcs.cabal --- a/darcs.cabal +++ b/darcs.cabal @@ -1,5 +1,5 @@ Name: darcs -version: 2.10.3 +version: 2.12.0 License: GPL License-file: COPYING Author: David Roundy , @@ -33,7 +33,7 @@ Homepage: http://darcs.net/ Build-Type: Custom -Cabal-Version: >= 1.10 +Cabal-Version: >= 1.16 extra-source-files: -- C headers @@ -44,6 +44,7 @@ contrib/_darcs.zsh, contrib/darcs_completion, contrib/cygwin-wrapper.bash, contrib/update_roundup.pl, contrib/upload.cgi, contrib/darcs-errors.hlint, + contrib/runHLint.sh, README.md, CHANGELOG @@ -61,12 +62,9 @@ tests/network/*.sh tests/lib tests/data/example_binary.png + harness/hstestdata.zip tests/README.test_maintainers.txt - -- hashed-storage - hashed-storage/LICENSE - hashed-storage/testdata.zip - GNUmakefile source-repository head @@ -100,9 +98,6 @@ description: Build darcs executable default: True -flag hpc - default: False - flag rts default: False @@ -116,13 +111,6 @@ manual: True description: Build with warnings-as-errors --- To allow building with containers < 0.5, we keep a local copy of this --- module. -flag use-local-data-map-strict - default: False - description: Support containers < 0.5, by using a local copy of the - Data.Map.Strict module from containers 0.5. - -- Note that the Setup script checks whether -liconv is necessary. This flag -- lets us override that decision. When it is True, we use -liconv. When it -- is False, we run tests to decide. @@ -130,9 +118,6 @@ Description: Explicitly link against the libiconv library. Default: False -flag hashed-storage-diff - default: False - -- with time>=1.5 (needed with GHC 7.10) we get defaultTimeLocale from time:Data.Time -- with time<1.5 we get defaultTimeLocale from old-locale:System.Locale flag use-time-1point5 @@ -165,7 +150,6 @@ Darcs.Patch.Commute Darcs.Patch.CommuteFn Darcs.Patch.Conflict - Darcs.Patch.ConflictMarking Darcs.Patch.Debug Darcs.Patch.Depends Darcs.Patch.Dummy @@ -179,10 +163,10 @@ Darcs.Patch.Invert Darcs.Patch.Match Darcs.Patch.Matchable - Darcs.Patch.MaybeInternal Darcs.Patch.Merge Darcs.Patch.MonadProgress Darcs.Patch.Named + Darcs.Patch.Named.Wrapped Darcs.Patch.OldDate Darcs.Patch.PatchInfoAnd Darcs.Patch.Patchy @@ -198,27 +182,28 @@ Darcs.Patch.Prim.V1.Details Darcs.Patch.Prim.V1.Read Darcs.Patch.Prim.V1.Show - Darcs.Patch.Prim.V3 - Darcs.Patch.Prim.V3.ObjectMap - Darcs.Patch.Prim.V3.Apply - Darcs.Patch.Prim.V3.Coalesce - Darcs.Patch.Prim.V3.Commute - Darcs.Patch.Prim.V3.Core - Darcs.Patch.Prim.V3.Details - Darcs.Patch.Prim.V3.Read - Darcs.Patch.Prim.V3.Show + Darcs.Patch.Prim.FileUUID + Darcs.Patch.Prim.FileUUID.ObjectMap + Darcs.Patch.Prim.FileUUID.Apply + Darcs.Patch.Prim.FileUUID.Coalesce + Darcs.Patch.Prim.FileUUID.Commute + Darcs.Patch.Prim.FileUUID.Core + Darcs.Patch.Prim.FileUUID.Details + Darcs.Patch.Prim.FileUUID.Read + Darcs.Patch.Prim.FileUUID.Show Darcs.Patch.Progress Darcs.Patch.Read Darcs.Patch.Rebase + Darcs.Patch.Rebase.Container Darcs.Patch.Rebase.Fixup + Darcs.Patch.Rebase.Item Darcs.Patch.Rebase.Name - Darcs.Patch.Rebase.NameHack - Darcs.Patch.Rebase.Recontext Darcs.Patch.Rebase.Viewing Darcs.Patch.ReadMonads Darcs.Patch.RegChars Darcs.Patch.Repair Darcs.Patch.RepoPatch + Darcs.Patch.RepoType Darcs.Patch.Set Darcs.Patch.Show Darcs.Patch.Split @@ -237,42 +222,39 @@ Darcs.Patch.V1.Viewing Darcs.Patch.V2 Darcs.Patch.V2.Non - Darcs.Patch.V2.Real + Darcs.Patch.V2.RepoPatch Darcs.Patch.Witnesses.Eq Darcs.Patch.Witnesses.Ordered Darcs.Patch.Witnesses.Sealed Darcs.Patch.Witnesses.Show Darcs.Patch.Witnesses.Unsafe Darcs.Patch.Witnesses.WZipper + Darcs.Prelude Darcs.Repository Darcs.Repository.ApplyPatches Darcs.Repository.Cache + Darcs.Repository.Clone Darcs.Repository.PatchIndex - Darcs.Repository.Compat Darcs.Repository.Diff - Darcs.Repository.External Darcs.Repository.Flags Darcs.Repository.Format Darcs.Repository.HashedIO Darcs.Repository.HashedRepo Darcs.Repository.Internal Darcs.Repository.Job - Darcs.Repository.Lock - Darcs.Repository.LowLevel Darcs.Repository.Merge Darcs.Repository.InternalTypes Darcs.Repository.Match Darcs.Repository.Motd Darcs.Repository.Old + Darcs.Repository.Packs + Darcs.Repository.Pending Darcs.Repository.Prefs Darcs.Repository.Rebase Darcs.Repository.Repair - Darcs.Repository.Read Darcs.Repository.Resolution - Darcs.Repository.Ssh Darcs.Repository.State Darcs.Repository.Test - Darcs.Repository.Util Darcs.UI.ApplyPatches Darcs.UI.Commands Darcs.UI.Commands.Add @@ -306,6 +288,7 @@ Darcs.UI.Commands.ShowAuthors Darcs.UI.Commands.ShowBug Darcs.UI.Commands.ShowContents + Darcs.UI.Commands.ShowDependencies Darcs.UI.Commands.ShowFiles Darcs.UI.Commands.ShowIndex Darcs.UI.Commands.ShowPatchIndex @@ -331,8 +314,8 @@ Darcs.UI.Options.Markdown Darcs.UI.Options.Matching Darcs.UI.Options.Util + Darcs.UI.PatchHeader Darcs.UI.PrintPatch - Darcs.UI.RemoteApply Darcs.UI.RunCommand Darcs.UI.SelectChanges Darcs.UI.TheCommands @@ -342,6 +325,7 @@ Darcs.Util.Bug Darcs.Util.ByteString Darcs.Util.CommandLine + Darcs.Util.Compat Darcs.Util.Crypt.SHA1 Darcs.Util.Crypt.SHA256 Darcs.Util.DateMatcher @@ -356,9 +340,13 @@ Darcs.Util.Environment Darcs.Util.Exception Darcs.Util.Exec + Darcs.Util.External Darcs.Util.File Darcs.Util.Global + Darcs.Util.Hash + Darcs.Util.Index Darcs.Util.IsoDate + Darcs.Util.Lock Darcs.Util.Path Darcs.Util.Printer Darcs.Util.Printer.Color @@ -369,8 +357,13 @@ Darcs.Util.SignalHandler Darcs.Util.Ssh Darcs.Util.Text + Darcs.Util.Tree + Darcs.Util.Tree.Hashed + Darcs.Util.Tree.Monad + Darcs.Util.Tree.Plain Darcs.Util.URL Darcs.Util.Workaround + Bundled.Posix other-modules: Version Darcs.Util.Download.Curl @@ -382,6 +375,7 @@ src/umask.c src/system_encoding.c + -- see http://bugs.darcs.net/issue1037 cc-options: -D_REENTRANT if os(windows) @@ -397,61 +391,48 @@ System.Posix.IO cpp-options: -DWIN32 c-sources: src/win32/send_email.c - build-depends: unix-compat >= 0.1.2 && < 0.5, - Win32 >= 2.2 && < 2.4 + build-depends: Win32 >= 2.3 && < 2.4 else other-modules: Darcs.Util.Encoding.IConv c-sources: src/h_iconv.c - - if flag(use-local-data-map-strict) - build-depends: containers >= 0.4 && < 0.5, - deepseq >= 1.3 && < 1.4 - hs-source-dirs: containers-0.5.2.1 - other-modules: - Darcs.Data.Map.Base - Darcs.Data.Map.Strict - Darcs.Data.Set.Base - Darcs.Data.StrictPair - cpp-options: -DUSE_LOCAL_DATA_MAP_STRICT - else - build-depends: containers >= 0.5 && < 0.6 - - if os(solaris) - cc-options: -DHAVE_SIGINFO_H - - build-depends: base >= 4.5 && < 4.9 + build-depends: unix >= 2.6.0.1 && < 2.8 - build-depends: binary >= 0.5 && < 0.9, + build-depends: base >= 4.6 && < 4.10, + binary >= 0.5 && < 0.9, + containers >= 0.5 && < 0.6, regex-compat-tdfa >= 0.95.1 && < 0.96, regex-applicative >= 0.2 && < 0.4, - mtl >= 2.1 && < 2.3, + mtl >= 2.1.2 && < 2.3, transformers >= 0.3 && < 0.4.0.0 || > 0.4.0.0 && < 0.6, -- for the Control.Monad.Error -> Control.Monad.Except -- transition transformers-compat >= 0.4 && < 0.6, parsec >= 3.1 && < 3.2, - html == 1.0.*, - filepath >= 1.2.0.0 && < 1.5.0.0, + fgl >= 5.5.0.1 && < 5.6, + graphviz >= 2999.17.0.1 && < 2999.19, + html >= 1.0.1.2 && < 1.1, + filepath >= 1.3.0.1 && < 1.5.0.0, haskeline >= 0.6.3 && < 0.8, cryptohash >= 0.4 && < 0.12, base16-bytestring >= 0.1 && < 0.2, - utf8-string >= 0.3.6 && < 1.1, - vector >= 0.7 && < 0.12, + utf8-string >= 0.3.6 && < 1.1, + vector >= 0.10.0.1 && < 0.12, tar >= 0.4 && < 0.6, data-ordlist == 0.4.*, attoparsec >= 0.11 && < 0.14, - zip-archive >= 0.2.3 && < 0.3 - - if !os(windows) - build-depends: unix >= 2.5 && < 2.8 - - build-depends: bytestring >= 0.9.0 && < 0.11, - old-time >= 1.1 && < 1.2, - directory >= 1.1.0.2 && < 1.3.0.0, - process >= 1.1.0.1 && < 1.5.0.0, - array >= 0.4 && < 0.6, - random >= 1.0 && < 1.2, - hashable >= 1.0 && < 1.3 + zip-archive >= 0.2.3 && < 0.4, + async >= 2.0.1.4 && < 2.2, + sandi >= 0.2 && < 0.4, + unix-compat >= 0.1.2 && < 0.5, + bytestring >= 0.10.0.2 && < 0.11, + old-time >= 1.1 && < 1.2, + directory >= 1.2.0.1 && < 1.3.0.0, + process >= 1.1.0.2 && < 1.5.0.0, + array >= 0.4.0.1 && < 0.6, + random >= 1.0.1.1 && < 1.2, + hashable >= 1.1.2.5 && < 1.3, + mmap >= 0.5 && < 0.6, + zlib >= 0.5.4.1 && < 0.7.0.0 -- release notes of GHC 7.10.2 recommends to use text >= 1.2.1.3: -- https://mail.haskell.org/pipermail/haskell/2015-July/024641.html @@ -463,8 +444,8 @@ if flag(use-time-1point5) build-depends: time >= 1.5 && < 1.7 else - build-depends: time >= 1.4 && < 1.5, - old-locale >= 1.0 && < 1.1 + build-depends: time >= 1.4.0.1 && < 1.5, + old-locale >= 1.0.0.5 && < 1.1 if flag(optimize) ghc-options: -O2 @@ -475,16 +456,9 @@ ghc-options: -Werror -- Note: "if true" works around a cabal bug with order of flag composition + -- fixed in Cabal 1.18 https://github.com/haskell/cabal/commit/cf0cf077ab6836584fc3bf51d867e63824811d4d if true - ghc-options: -Wall -funbox-strict-fields -fwarn-tabs - - ghc-prof-options: -prof -auto-all - - if flag(hpc) - ghc-prof-options: -fhpc -hpcdir dist/hpc/libdarcs - - if flag(rts) - ghc-options: -rtsopts + ghc-options: -Wall -funbox-strict-fields -fwarn-tabs -fno-warn-dodgy-imports if flag(curl) cpp-options: -DHAVE_CURL @@ -500,18 +474,14 @@ if flag(network-uri) build-depends: network-uri == 2.6.*, network == 2.6.* else - build-depends: network >= 2.3 && < 2.6 - build-depends: HTTP >= 4000.2.3 && < 4000.4 + build-depends: network >= 2.4.1.2 && < 2.6 + build-depends: HTTP >= 4000.2.8 && < 4000.4 cpp-options: -DHAVE_HTTP x-have-http: if (!flag(curl) && !flag(http)) buildable: False - build-depends: mmap >= 0.5 && < 0.6 - - build-depends: zlib >= 0.5.3.0 && < 0.7.0.0 - -- The terminfo package cannot be built on Windows. if flag(terminfo) && !os(windows) build-depends: terminfo >= 0.3 && < 0.5 @@ -528,52 +498,12 @@ FlexibleInstances ScopedTypeVariables KindSignatures + DataKinds + ConstraintKinds RankNTypes TypeFamilies NoMonoLocalBinds - if impl(ghc>=7.6) - -- in ghc < 7.6 we need to import Prelude hiding (catch) - -- in ghc >= 7.6 catch isn't in Prelude - -- once the minimum version of ghc is >= 7.6 we can remove the hiding - -- clauses and this flag - ghc-options: -fno-warn-dodgy-imports - - - -- hashed-storage inclusion - hs-source-dirs: hashed-storage - - exposed-modules: - Storage.Hashed - Storage.Hashed.AnchoredPath - Storage.Hashed.Index - Storage.Hashed.Monad - Storage.Hashed.Tree - Storage.Hashed.Hash - Storage.Hashed.Packed - - Storage.Hashed.Plain - Storage.Hashed.Darcs - - if flag(hashed-storage-diff) - exposed-modules: - Storage.Hashed.Diff - build-depends: lcs - - other-modules: - Bundled.Posix - Storage.Hashed.Utils - - build-depends: sandi >= 0.2 && < 0.4, - unix-compat >= 0.1.2 && < 0.5, - cryptohash >= 0.4 && < 0.12 - - if os(windows) - cpp-options: -DWIN32 - build-depends: Win32 >= 2.2 && < 2.4 - - -- end of hashed-storage inclusion - -- ---------------------------------------------------------------------- -- darcs itself -- ---------------------------------------------------------------------- @@ -599,28 +529,22 @@ -- Note: "if true" works around a cabal bug with order of flag composition if true - ghc-options: -Wall -funbox-strict-fields -fwarn-tabs + ghc-options: -Wall -funbox-strict-fields -fwarn-tabs -fno-warn-dodgy-imports - ghc-prof-options: -prof -auto-all if flag(threaded) ghc-options: -threaded if flag(static) ghc-options: -static -optl-static -optl-pthread - if flag(hpc) - ghc-prof-options: -fhpc -hpcdir dist/hpc/darcs - if flag(rts) ghc-options: -rtsopts + -- see http://bugs.darcs.net/issue1037 cc-options: -D_REENTRANT - build-depends: base >= 4.5 && < 4.9 - build-depends: darcs, - filepath >= 1.2.0.0 && < 1.5.0.0, - regex-compat-tdfa >= 0.95.1 && < 0.96 + base >= 4.6 && < 4.10 -- if true to work around cabal bug with flag ordering if true @@ -648,30 +572,28 @@ main-is: test.hs hs-source-dirs: harness - build-depends: base >= 4.5 && < 4.9 - if os(windows) cpp-options: -DWIN32 + build-depends: Win32 >= 2.2 && < 2.4 build-depends: darcs, - array >= 0.4 && < 0.6, - bytestring >= 0.9.0 && < 0.11, + base >= 4.6 && < 4.10, + array >= 0.4.0.1 && < 0.6, + bytestring >= 0.10.0.2 && < 0.11, cmdargs >= 0.10 && < 0.11, containers >= 0.1 && < 0.6, - filepath >= 1.2.0.0 && < 1.5.0.0, - html == 1.0.*, + filepath >= 1.3.0.1 && < 1.5.0.0, mtl >= 2.1 && < 2.3, - parsec >= 3.1 && < 3.2, - regex-compat-tdfa >= 0.95.1 && < 0.96, shelly >= 1.6.2 && < 1.7, - split >= 0.1.4.1 && < 0.3, - directory >= 1.1.0.2 && < 1.3.0.0, + split >= 0.2.2 && < 0.3, + directory >= 1.2.0.1 && < 1.3.0.0, FindBin >= 0.0 && < 0.1, - QuickCheck >= 2.3 && < 2.9, - HUnit >= 1.0 && < 1.4, + QuickCheck >= 2.6 && < 2.9, + HUnit >= 1.2.5.2 && < 1.4, test-framework >= 0.4.0 && < 0.9, test-framework-hunit >= 0.2.2 && < 0.4, - test-framework-quickcheck2 >= 0.3 && < 0.4 + test-framework-quickcheck2 >= 0.3 && < 0.4, + zip-archive >= 0.2.3 && < 0.4 -- release notes of GHC 7.10.2 recommends to use text >= 1.2.1.3: -- https://mail.haskell.org/pipermail/haskell/2015-July/024641.html @@ -693,22 +615,24 @@ Darcs.Test.Patch.Properties.Generic Darcs.Test.Patch.Properties.GenericUnwitnessed Darcs.Test.Patch.Properties.Check - Darcs.Test.Patch.Properties.Real + Darcs.Test.Patch.Properties.RepoPatchV2 Darcs.Test.Patch.Arbitrary.Generic - Darcs.Test.Patch.Arbitrary.Real Darcs.Test.Patch.Arbitrary.PrimV1 - Darcs.Test.Patch.Arbitrary.PrimV3 - Darcs.Test.Patch.Arbitrary.PatchV1 + Darcs.Test.Patch.Arbitrary.PrimFileUUID + Darcs.Test.Patch.Arbitrary.RepoPatchV1 + Darcs.Test.Patch.Arbitrary.RepoPatchV2 Darcs.Test.Patch.Rebase Darcs.Test.Patch.RepoModel + Darcs.Test.Patch.Selection Darcs.Test.Patch.Utils Darcs.Test.Patch.V1Model - Darcs.Test.Patch.V3Model + Darcs.Test.Patch.FileUUIDModel Darcs.Test.Patch.WithState Darcs.Test.Patch Darcs.Test.Misc Darcs.Test.Util.TestResult Darcs.Test.Util.QuickCheck + Storage.Hashed.Test if flag(optimize) ghc-options: -O2 @@ -722,16 +646,13 @@ if true ghc-options: -Wall -funbox-strict-fields -fwarn-tabs - ghc-prof-options: -prof -auto-all if flag(threaded) ghc-options: -threaded - if flag(hpc) - ghc-prof-options: -fhpc -hpcdir dist/hpc/darcs-test - if flag(rts) ghc-options: -rtsopts + -- see http://bugs.darcs.net/issue1037 cc-options: -D_REENTRANT -- if true to work around cabal bug with flag ordering @@ -745,65 +666,10 @@ FlexibleInstances ScopedTypeVariables KindSignatures + DataKinds + ConstraintKinds RankNTypes TypeFamilies NoMonoLocalBinds --- hashed-storage inclusion -test-suite hashed-storage-test - buildable: True - type: exitcode-stdio-1.0 - default-language: Haskell2010 - hs-source-dirs: hashed-storage - - ghc-options: -Wall -O2 -fwarn-tabs - ghc-prof-options: -prof -auto-all -O2 - - if flag(hpc) - ghc-prof-options: -fhpc - - if flag(warn-as-error) - ghc-options: -Werror - - if impl(ghc>=7.6) - -- in ghc < 7.6 we need to import Prelude hiding (catch) - -- in ghc >= 7.6 catch isn't in Prelude - -- once the minimum version of ghc is >= 7.6 we can remove the hiding - -- clauses and this flag - ghc-options: -fno-warn-dodgy-imports - - main-is: test.hs - other-modules: Bundled.Posix - Storage.Hashed.Test - - if os(windows) - cpp-options: -DWIN32 - build-depends: Win32 >= 2.2 && < 2.4 - - -- hashed-storage inclusion: duplicated these from the library - - -- probably needed because of the higher cabal-version in darcs.cabal - -- not using version constraints here to save on maintaining duplicates, - -- since these packages are all constrained elsewhere in the cabal file. - build-depends: base, - containers, - mtl, - directory, - filepath, - bytestring, - sandi, - cryptohash, - binary, - zlib, - mmap, - unix-compat - - build-depends: test-framework, - test-framework-hunit, - test-framework-quickcheck2, - QuickCheck, - HUnit, - process, - zip-archive - --- end of hashed-storage inclusion diff --git a/harness/Darcs/Test/Patch.hs b/harness/Darcs/Test/Patch.hs --- a/harness/Darcs/Test/Patch.hs +++ b/harness/Darcs/Test/Patch.hs @@ -39,11 +39,11 @@ import Darcs.Patch.Witnesses.Show import Darcs.Patch.Prim( PrimPatch, coalesce, FromPrim, PrimOf, PrimPatchBase ) import qualified Darcs.Patch.Prim.V1 as V1 ( Prim ) -import qualified Darcs.Patch.Prim.V3 as V3 ( Prim ) +import qualified Darcs.Patch.Prim.FileUUID as FileUUID ( Prim ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.Type ( PatchType(..) ) -import Darcs.Patch.V1 as V1 ( Patch ) -import Darcs.Patch.V2.Real ( isConsistent, isForward, RealPatch ) +import Darcs.Patch.V1 as V1 ( RepoPatchV1 ) +import Darcs.Patch.V2.RepoPatch ( isConsistent, isForward, RepoPatchV2 ) import Darcs.Patch.Patchy ( Commute(..), Patchy ) import Darcs.Patch.Merge( Merge ) import Darcs.Patch.Show ( ShowPatchBasic ) @@ -51,14 +51,15 @@ import Darcs.Test.Patch.Arbitrary.Generic import qualified Darcs.Test.Patch.Arbitrary.PrimV1 as P1 -import Darcs.Test.Patch.Arbitrary.PrimV3() -import Darcs.Test.Patch.Arbitrary.Real -import Darcs.Test.Patch.Arbitrary.PatchV1 () +import Darcs.Test.Patch.Arbitrary.PrimFileUUID() +import Darcs.Test.Patch.Arbitrary.RepoPatchV1 () +import Darcs.Test.Patch.Arbitrary.RepoPatchV2 import Darcs.Test.Patch.Arbitrary.PrimV1 () import Darcs.Test.Patch.RepoModel import Darcs.Test.Patch.WithState( WithState, WithStartState ) import qualified Darcs.Test.Patch.Info +import qualified Darcs.Test.Patch.Selection import qualified Darcs.Test.Patch.Examples.Set1 as Ex import qualified Darcs.Test.Patch.Examples.Set2Unwitnessed as ExU @@ -67,7 +68,7 @@ import qualified Darcs.Test.Patch.Properties.V1Set1 as Prop1 import qualified Darcs.Test.Patch.Properties.V1Set2 as Prop2 import qualified Darcs.Test.Patch.Properties.Generic as PropG -import qualified Darcs.Test.Patch.Properties.Real as PropR +import qualified Darcs.Test.Patch.Properties.RepoPatchV2 as PropR import qualified Darcs.Test.Patch.Properties.GenericUnwitnessed as PropU import qualified Darcs.Test.Patch.Rebase as Rebase @@ -124,29 +125,29 @@ , testCases "FL prim inverses commute" (PropU.commuteInverses WSub.commute) $ ExU.commutablesFL , testCases "fails" (PropU.commuteFails WSub.commute) ([] :: [(V1.Prim WSub.:> V1.Prim) wX wY]) , testCases "read and show work on Prim" PropU.show_read ExU.primPatches - , testCases "read and show work on RealPatch" PropU.show_read ExU.realPatches - , testCases "example flattenings work" PropU.consistentTreeFlattenings ExU.realPatchLoopExamples - , testCases "real merge input consistent" (PropU.mergeArgumentsConsistent isConsistent) ExU.realMergeables - , testCases "real merge input is forward" (PropU.mergeArgumentsConsistent isForward) ExU.realMergeables - , testCases "real merge output is forward" (PropU.mergeConsistent isForward) ExU.realMergeables - , testCases "real merge output consistent" (PropU.mergeConsistent isConsistent) ExU.realMergeables - , testCases "real merge either way" PropU.mergeEitherWay ExU.realMergeables - , testCases "real merge and commute" PropU.mergeCommute ExU.realMergeables + , testCases "read and show work on RepoPatchV2" PropU.show_read ExU.repov2Patches + , testCases "example flattenings work" PropU.consistentTreeFlattenings ExU.repov2PatchLoopExamples + , testCases "V2 merge input consistent" (PropU.mergeArgumentsConsistent isConsistent) ExU.repov2Mergeables + , testCases "V2 merge input is forward" (PropU.mergeArgumentsConsistent isForward) ExU.repov2Mergeables + , testCases "V2 merge output is forward" (PropU.mergeConsistent isForward) ExU.repov2Mergeables + , testCases "V2 merge output consistent" (PropU.mergeConsistent isConsistent) ExU.repov2Mergeables + , testCases "V2 merge either way" PropU.mergeEitherWay ExU.repov2Mergeables + , testCases "V2 merge and commute" PropU.mergeCommute ExU.repov2Mergeables - , testCases "real recommute" (PropU.recommute WSub.commute) ExU.realCommutables - , testCases "real inverses commute" (PropU.commuteInverses WSub.commute) ExU.realCommutables - , testCases "real permutivity" (PropU.permutivity WSub.commute) ExU.realNonduplicateTriples - , testCases "real partial permutivity" (PropU.partialPermutivity WSub.commute) ExU.realNonduplicateTriples + , testCases "V2 recommute" (PropU.recommute WSub.commute) ExU.repov2Commutables + , testCases "V2 inverses commute" (PropU.commuteInverses WSub.commute) ExU.repov2Commutables + , testCases "V2 permutivity" (PropU.permutivity WSub.commute) ExU.repov2NonduplicateTriples + , testCases "V2 partial permutivity" (PropU.partialPermutivity WSub.commute) ExU.repov2NonduplicateTriples ] -instance PrimPatch prim => Check (RealPatch prim) where +instance PrimPatch prim => Check (RepoPatchV2 prim) where checkPatch p = return $ isNothing $ isConsistent p -instance Check V3.Prim where +instance Check FileUUID.Prim where checkPatch _ = return True -- XXX -commuteReals :: PrimPatch prim => (RealPatch prim :> RealPatch prim) wX wY -> Maybe ((RealPatch prim :> RealPatch prim) wX wY) -commuteReals = commute +commuteRepoPatchV2s :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> Maybe ((RepoPatchV2 prim :> RepoPatchV2 prim) wX wY) +commuteRepoPatchV2s = commute qc_prim :: forall prim wX wY wA model. (PrimPatch prim, ArbitraryPrim prim, Show2 prim @@ -183,8 +184,8 @@ [ pair_properties (undefined :: prim wX wY) "arbitrary" arbitraryThing' , pair_properties (undefined :: FL prim wX wY) "arbitrary FL" arbitraryThing' , coalesce_properties (undefined :: prim wX wY) "arbitrary" arbitraryThing' - , nonreal_commute_properties (undefined :: prim wX wY) "arbitrary" arbitraryThing' - , nonreal_commute_properties (undefined :: FL prim wX wY) "arbitrary FL" arbitraryThing' + , nonrpv2_commute_properties (undefined :: prim wX wY) "arbitrary" arbitraryThing' + , nonrpv2_commute_properties (undefined :: FL prim wX wY) "arbitrary FL" arbitraryThing' , patch_properties (undefined :: prim wX wA) "arbitrary" arbitraryThing' , patch_properties (undefined :: FL prim wX wA) "arbitrary FL" arbitraryThing' , patch_repo_properties (undefined :: prim wX wA) "arbitrary" arbitraryThing' @@ -197,41 +198,41 @@ qc_V2P1 :: [Test] qc_V2P1 = [ testProperty "tree flattenings are consistent... " - PropR.propConsistentTreeFlattenings - , testProperty "with quickcheck that real patches are consistent... " + (PropR.propConsistentTreeFlattenings :: Sealed (WithStartState (ModelOf V1.Prim) (Tree V1.Prim)) -> Bool) + , testProperty "with quickcheck that RepoPatchV2 patches are consistent... " (unseal $ P1.patchFromTree $ fromMaybe . isConsistent) -- permutivity ---------------------------------------------------------------------------- , testConditional "permutivity" (unseal $ P1.commuteTripleFromTree notDuplicatestriple) - (unseal $ P1.commuteTripleFromTree $ PropG.permutivity commuteReals) + (unseal $ P1.commuteTripleFromTree $ PropG.permutivity commuteRepoPatchV2s) , testConditional "partial permutivity" (unseal $ P1.commuteTripleFromTree notDuplicatestriple) - (unseal $ P1.commuteTripleFromTree $ PropG.partialPermutivity commuteReals) + (unseal $ P1.commuteTripleFromTree $ PropG.partialPermutivity commuteRepoPatchV2s) , testConditional "nontrivial permutivity" (unseal $ P1.commuteTripleFromTree (\t -> nontrivialTriple t && notDuplicatestriple t)) - (unseal $ P1.commuteTripleFromTree $ (PropG.permutivity commuteReals)) + (unseal $ P1.commuteTripleFromTree $ (PropG.permutivity commuteRepoPatchV2s)) ] qc_V2 :: forall prim wXx wYy . (PrimPatch prim, Show1 (ModelOf prim), RepoModel (ModelOf prim), - Check (RealPatch prim), ArbitraryPrim prim, Show2 prim, + Check (RepoPatchV2 prim), ArbitraryPrim prim, Show2 prim, RepoState (ModelOf prim) ~ ApplyState prim) => prim wXx wYy -> [Test] qc_V2 _ = - [ testProperty "readPatch and showPatch work on RealPatch... " - (unseal $ patchFromTree $ (PropG.show_read :: RealPatch prim wX wY -> TestResult)) - , testProperty "readPatch and showPatch work on FL RealPatch... " - (unseal2 $ (PropG.show_read :: FL (RealPatch prim) wX wY -> TestResult)) + [ testProperty "readPatch and showPatch work on RepoPatchV2... " + (unseal $ patchFromTree $ (PropG.show_read :: RepoPatchV2 prim wX wY -> TestResult)) + , testProperty "readPatch and showPatch work on FL RepoPatchV2... " + (unseal2 $ (PropG.show_read :: FL (RepoPatchV2 prim) wX wY -> TestResult)) , testProperty "we can do merges using QuickCheck" (isNothing . (PropG.propIsMergeable :: Sealed (WithStartState (ModelOf prim) (Tree prim)) - -> Maybe (Tree (RealPatch prim) wX))) + -> Maybe (Tree (RepoPatchV2 prim) wX))) ] ++ concat - [ merge_properties (undefined :: RealPatch prim wX wY) "tree" mergePairFromTree - , merge_properties (undefined :: RealPatch prim wX wY) "twfp" mergePairFromTWFP - , pair_properties (undefined :: RealPatch prim wX wY) "tree" commutePairFromTree - , pair_properties (undefined :: RealPatch prim wX wY) "twfp" commutePairFromTWFP - , patch_properties (undefined :: RealPatch prim wX wY) "tree" patchFromTree + [ merge_properties (undefined :: RepoPatchV2 prim wX wY) "tree" mergePairFromTree + , merge_properties (undefined :: RepoPatchV2 prim wX wY) "twfp" mergePairFromTWFP + , pair_properties (undefined :: RepoPatchV2 prim wX wY) "tree" commutePairFromTree + , pair_properties (undefined :: RepoPatchV2 prim wX wY) "twfp" commutePairFromTWFP + , patch_properties (undefined :: RepoPatchV2 prim wX wY) "tree" patchFromTree ] properties :: forall thing gen. (Show1 gen, Arbitrary (Sealed gen)) => @@ -272,12 +273,12 @@ properties gen "commute" genname (if runCoalesceTests p then [ ("coalesce commutes with commute", const True, PropG.coalesceCommute coalesce) ] else []) --- The following properties do not hold for "Real" patches (conflictors and +-- The following properties do not hold for "RepoPatchV2" patches (conflictors and -- duplicates, specifically) . -nonreal_commute_properties :: forall p gen x y +nonrpv2_commute_properties :: forall p gen x y . (Show1 gen, Arbitrary (Sealed gen), Patchy p, ShowPatchBasic p, MyEq p) => p x y -> PropList (p :> p) gen -nonreal_commute_properties _ genname gen = +nonrpv2_commute_properties _ genname gen = properties gen "commute" genname [ ("patch & inverse commute", const True , PropG.patchAndInverseCommute commute) , ("patch & inverse commute", nontrivialCommute, PropG.patchAndInverseCommute commute) @@ -356,13 +357,13 @@ ] -- the following properties are disabled, because they routinely lead to -- exponential cases, making the tests run for ever and ever; nevertheless, -- we would expect them to hold - {- ++ merge_properties (undefined :: V1.Patch Prim wX wY) "tree" mergePairFromTree - ++ merge_properties (undefined :: V1.Patch Prim wX wY) "twfp" mergePairFromTWFP - ++ commute_properties (undefined :: V1.Patch Prim wX wY) "tree" commutePairFromTree - ++ commute_properties (undefined :: V1.Patch Prim wX wY) "twfp" commutePairFromTWFP -} + {- ++ merge_properties (undefined :: V1.RepoPatchV1 Prim wX wY) "tree" mergePairFromTree + ++ merge_properties (undefined :: V1.RepoPatchV1 Prim wX wY) "twfp" mergePairFromTWFP + ++ commute_properties (undefined :: V1.RepoPatchV1 Prim wX wY) "tree" commutePairFromTree + ++ commute_properties (undefined :: V1.RepoPatchV1 Prim wX wY) "twfp" commutePairFromTWFP -} -- tests (either QuickCheck or Unit) that should be run on any type of patch -general_patchTests :: (RepoPatch p, ArbitraryPrim (PrimOf p), Show2 (PrimOf p)) => PatchType p -> [Test] +general_patchTests :: (RepoPatch p, ArbitraryPrim (PrimOf p), Show2 (PrimOf p)) => PatchType rt p -> [Test] general_patchTests pt = [ testGroup "Rebase patches" $ Rebase.testSuite pt ] @@ -371,13 +372,14 @@ testSuite :: [Test] testSuite = [ testGroup "Darcs.Patch.Prim.V1" $ qc_prim (undefined :: V1.Prim wX wY) , testGroup "Darcs.Patch.V1 (using Prim.V1)" $ - unit_V1P1 ++ qc_V1P1 ++ general_patchTests (PatchType :: PatchType (V1.Patch V1.Prim)) + unit_V1P1 ++ qc_V1P1 ++ general_patchTests (PatchType :: PatchType rt (V1.RepoPatchV1 V1.Prim)) , testGroup "Darcs.Patch.V2 (using Prim.V1)" $ unit_V2P1 ++ qc_V2 (undefined :: V1.Prim wX wY) ++ qc_V2P1 ++ - general_patchTests (PatchType :: PatchType (RealPatch V1.Prim)) - -- , testGroup "Darcs.Patch.Prim.V3" $ qc_prim (undefined :: V3.Prim wX wY) - , testGroup "Darcs.Patch.V2 (using Prim.V3)" $ - qc_V2 (undefined :: V3.Prim wX wY) ++ - general_patchTests (PatchType :: PatchType (RealPatch V3.Prim)) + general_patchTests (PatchType :: PatchType rt (RepoPatchV2 V1.Prim)) + -- , testGroup "Darcs.Patch.Prim.FileUUID" $ qc_prim (undefined :: FileUUID.Prim wX wY) + , testGroup "Darcs.Patch.V2 (using Prim.FileUUID)" $ + qc_V2 (undefined :: FileUUID.Prim wX wY) ++ + general_patchTests (PatchType :: PatchType rt (RepoPatchV2 FileUUID.Prim)) , Darcs.Test.Patch.Info.testSuite + , Darcs.Test.Patch.Selection.testSuite ] diff --git a/harness/Darcs/Test/Patch/Arbitrary/Generic.hs b/harness/Darcs/Test/Patch/Arbitrary/Generic.hs --- a/harness/Darcs/Test/Patch/Arbitrary/Generic.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/Generic.hs @@ -27,7 +27,7 @@ import Darcs.Patch.Patchy ( Invert(..), Commute(..) ) import Darcs.Patch.Prim ( PrimOf, PrimPatch, PrimPatchBase, FromPrim(..), PrimConstruct( anIdentity ) ) import Darcs.Patch.Prim.V1 () -import Darcs.Patch.V2 ( RealPatch ) -- XXX this is more or less a hack +import Darcs.Patch.V2 ( RepoPatchV2 ) -- XXX this is more or less a hack --import Darcs.ColorPrinter ( errorDoc ) --import Darcs.ColorPrinter ( traceDoc ) import Darcs.Patch.Witnesses.Show @@ -119,7 +119,7 @@ instance MightBeEmptyHunk (FL p) class MightHaveDuplicate p where - -- |"duplicates" in V2 patches (RealPatch) have lots of bugs + -- |"duplicates" in V2 patches (RepoPatchV2) have lots of bugs -- that break various commute/merge properties. hasDuplicate :: p wX wY -> Bool hasDuplicate _ = False @@ -261,6 +261,6 @@ else do n <- choose (0, num - 1) return $ Sealed $ WithStartState rm $ TWFP n t where -- just used to get the length. In principle this should be independent of the patch type. - flattenOneRP :: Tree prim wX -> Sealed (FL (RealPatch prim) wX) + flattenOneRP :: Tree prim wX -> Sealed (FL (RepoPatchV2 prim) wX) flattenOneRP = flattenOne diff --git a/harness/Darcs/Test/Patch/Arbitrary/PatchV1.hs b/harness/Darcs/Test/Patch/Arbitrary/PatchV1.hs deleted file mode 100644 --- a/harness/Darcs/Test/Patch/Arbitrary/PatchV1.hs +++ /dev/null @@ -1,290 +0,0 @@ --- Copyright (C) 2002-2003,2007 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. - -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-} - - -module Darcs.Test.Patch.Arbitrary.PatchV1 () where - -import Prelude hiding ( pi ) -import System.IO.Unsafe ( unsafePerformIO ) -import Test.QuickCheck -import Control.Applicative -import Control.Monad ( liftM, liftM2, liftM3, liftM4, replicateM ) - -import Darcs.Patch.Info ( PatchInfo, patchinfo ) -import qualified Data.ByteString as B ( ByteString ) -import qualified Data.ByteString.Char8 as BC ( pack ) - -import Darcs.Patch ( addfile, adddir, move, - hunk, tokreplace, binary, - changepref, invert, merge ) -import Darcs.Patch.V1 () -import qualified Darcs.Patch.V1.Core as V1 ( Patch(..) ) -import Darcs.Patch.Prim.V1 () -import Darcs.Patch.Prim.V1.Core ( Prim(..) ) -import Darcs.Patch.Witnesses.Ordered -import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), unseal, mapSeal, Sealed2(..) ) -import Darcs.Patch.Witnesses.Unsafe - --- This definitely feels a bit weird to be importing Properties here, and --- probably means we want to move this elsewhere, but Darcs.Test.Patch.Check is --- already taken with something apparently only semi-related -import Darcs.Test.Patch.Properties.Check( checkAPatch ) -import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate ) - -#include "impossible.h" - -type Patch = V1.Patch Prim - -class ArbitraryP p where - arbitraryP :: Gen (Sealed (p wX)) - -{- -TODO: there is a lot of overlap in testing between between this module -and Darcs.Test.Patch.QuickCheck - -This module tests Prim and V1 patches, and Darcs.Test.Patch.QuickCheck -tests Prim and V2 patches - -This module's generator covers a wider set of patch types, but is less -likely to generate conflicts than Darcs.Test.Patch.QuickCheck. - -Until this is cleaned up, we take some care that the Arbitrary instances -do not overlap and are only used for tests from the respective -modules. - -(There are also tests in other modules that probably depend on the -Arbitrary instances in this module.) --} - -instance Arbitrary (Sealed (Prim wX)) where - arbitrary = arbitraryP - -instance Arbitrary (Sealed (FL Patch wX)) where - arbitrary = arbitraryP - --- instance Arbitrary (Sealed2 (Prim :> Prim)) where - -- arbitrary = unseal Sealed2 <$> arbitraryP - -instance Arbitrary (Sealed2 (FL Patch)) where - arbitrary = unseal Sealed2 <$> arbitraryP - -instance Arbitrary (Sealed2 (FL Patch :\/: FL Patch)) where - arbitrary = unseal Sealed2 <$> arbitraryP - -instance Arbitrary (Sealed2 (FL Patch :> FL Patch)) where - arbitrary = unseal Sealed2 <$> arbitraryP - -instance Arbitrary (Sealed2 (FL Patch :> FL Patch :> FL Patch)) where - arbitrary = unseal Sealed2 <$> arbitraryP - - -instance (ArbitraryP p1, ArbitraryP p2) => ArbitraryP (p1 :> p2) where - arbitraryP = do Sealed p1 <- arbitraryP - Sealed p2 <- arbitraryP - return (Sealed (p1 :> p2)) - -instance (ArbitraryP p1, ArbitraryP p2) => ArbitraryP (p1 :\/: p2) where - arbitraryP = do Sealed p1 <- arbitraryP - Sealed p2 <- arbitraryP - return (Sealed (unsafeCoercePEnd p1 :\/: p2)) - -instance ArbitraryP (FL Patch) where - arbitraryP = sized arbpatch - -instance ArbitraryP Prim where - arbitraryP = onepatchgen - -instance MightHaveDuplicate (V1.Patch prim) - -hunkgen :: Gen (Sealed (Prim wX)) -hunkgen = do - i <- frequency [(1,choose (0,5)),(1,choose (0,35)), - (2,return 0),(3,return 1),(2,return 2),(1,return 3)] - j <- frequency [(1,choose (0,5)),(1,choose (0,35)), - (2,return 0),(3,return 1),(2,return 2),(1,return 3)] - if i == 0 && j == 0 then hunkgen - else Sealed <$> - liftM4 hunk filepathgen linenumgen - (replicateM i filelinegen) - (replicateM j filelinegen) - -tokreplacegen :: Gen (Sealed (Prim wX)) -tokreplacegen = do - f <- filepathgen - o <- tokengen - n <- tokengen - if o == n - then return $ Sealed $ tokreplace f "A-Za-z" "old" "new" - else return $ Sealed $ tokreplace f "A-Za-z_" o n - -twofilegen :: (forall wY . FilePath -> FilePath -> Prim wX wY) -> Gen (Sealed (Prim wX)) -twofilegen p = do - n1 <- filepathgen - n2 <- filepathgen - if n1 /= n2 && checkAPatch (p n1 n2) - then return $ Sealed $ p n1 n2 - else twofilegen p - -chprefgen :: Gen (Sealed (Prim wX)) -chprefgen = do - f <- oneof [return "color", return "movie"] - o <- tokengen - n <- tokengen - if o == n then return $ Sealed $ changepref f "old" "new" - else return $ Sealed $ changepref f o n - -simplepatchgen :: Gen (Sealed (Prim wX)) -simplepatchgen = frequency [(1,liftM (Sealed . addfile) filepathgen), - (1,liftM (Sealed . adddir) filepathgen), - (1,liftM3 (\x y z -> Sealed (binary x y z)) filepathgen arbitrary arbitrary), - (1,twofilegen move), - (1,tokreplacegen), - (1,chprefgen), - (7,hunkgen) - ] - -onepatchgen :: Gen (Sealed (Prim wX)) -onepatchgen = oneof [simplepatchgen, mapSeal (invert . unsafeCoerceP) `fmap` simplepatchgen] - -norecursgen :: Int -> Gen (Sealed (FL Patch wX)) -norecursgen 0 = mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen -norecursgen n = oneof [mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen,flatcompgen n] - -arbpatch :: Int -> Gen (Sealed (FL Patch wX)) -arbpatch 0 = mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen -arbpatch n = frequency [(3,mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen), - (2,flatcompgen n), - (0,rawMergeGen n), - (0,mergegen n), - (1,mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen) - ] - --- | Generate an arbitrary list of at least one element -unempty :: Arbitrary a => Gen [a] -unempty = do - a <- arbitrary - as <- arbitrary - return (a:as) - -rawMergeGen :: Int -> Gen (Sealed (FL Patch wX)) -rawMergeGen n = do Sealed p1 <- arbpatch len - Sealed p2 <- arbpatch len - if checkAPatch (invert p1:>:p2:>:NilFL) && - checkAPatch (invert p2:>:p1:>:NilFL) - then case merge (p2 :\/: p1) of - _ :/\: p2' -> return (Sealed (unsafeCoercePStart p2')) - else rawMergeGen n - where len = if n < 15 then n`div`3 else 3 - -mergegen :: Int -> Gen (Sealed (FL Patch wX)) -mergegen n = do - Sealed p1 <- norecursgen len - Sealed p2 <- norecursgen len - if checkAPatch (invert p1:>:p2:>:NilFL) && - checkAPatch (invert p2:>:p1:>:NilFL) - then case merge (p2:\/:p1) of - _ :/\: p2' -> - if checkAPatch (p1+>+p2') - then return $ Sealed $ p1+>+p2' - else impossible - else mergegen n - where len = if n < 15 then n`div`3 else 3 - -arbpi :: Gen PatchInfo -arbpi = do n <- unempty - a <- unempty - l <- unempty - d <- unempty - return $ unsafePerformIO $ patchinfo n d a l - -instance Arbitrary PatchInfo where - arbitrary = arbpi - -instance Arbitrary B.ByteString where - arbitrary = liftM BC.pack arbitrary - -flatlistgen :: Int -> Gen (Sealed (FL Patch wX)) -flatlistgen 0 = return $ Sealed NilFL -flatlistgen n = do Sealed x <- onepatchgen - Sealed xs <- flatlistgen (n-1) - return (Sealed (V1.PP x :>: xs)) - -flatcompgen :: Int -> Gen (Sealed (FL Patch wX)) -flatcompgen n = do - Sealed ps <- flatlistgen n - let myp = regularizePatches $ ps - if checkAPatch myp - then return $ Sealed myp - else flatcompgen n - --- resize to size 25, that means we'll get line numbers no greater --- than 1025 using QuickCheck 2.1 -linenumgen :: Gen Int -linenumgen = frequency [(1,return 1), (1,return 2), (1,return 3), - (3,liftM (\n->1+abs n) (resize 25 arbitrary)) ] - -tokengen :: Gen String -tokengen = oneof [return "hello", return "world", return "this", - return "is", return "a", return "silly", - return "token", return "test"] - -toklinegen :: Gen String -toklinegen = liftM unwords $ replicateM 3 tokengen - -filelinegen :: Gen B.ByteString -filelinegen = liftM BC.pack $ - frequency [(1,map fromSafeChar `fmap` arbitrary),(5,toklinegen), - (1,return ""), (1,return "{"), (1,return "}") ] - -filepathgen :: Gen String -filepathgen = liftM fixpath badfpgen - -fixpath :: String -> String -fixpath "" = "test" -fixpath p = fpth p - -fpth :: String -> String -fpth ('/':'/':cs) = fpth ('/':cs) -fpth (c:cs) = c : fpth cs -fpth [] = [] - -newtype SafeChar = SS Char -instance Arbitrary SafeChar where - arbitrary = oneof $ map (return . SS) (['a'..'z']++['A'..'Z']++['1'..'9']++"0") - -fromSafeChar :: SafeChar -> Char -fromSafeChar (SS s) = s - -badfpgen :: Gen String -badfpgen = frequency [(1,return "test"), (1,return "hello"), (1,return "world"), - (1,map fromSafeChar `fmap` arbitrary), - (1,liftM2 (\a b-> a++"/"++b) filepathgen filepathgen) ] - -regularizePatches :: FL Patch wX wY -> FL Patch wX wY -regularizePatches patches = rpint (unsafeCoerceP NilFL) patches - where -- this reverses the list, which seems odd and causes - -- the witness unsafety - rpint :: FL Patch wX wY -> FL Patch wA wB -> FL Patch wX wY - rpint ok_ps NilFL = ok_ps - rpint ok_ps (p:>:ps) = - if checkAPatch (unsafeCoerceP p:>:ok_ps) - then rpint (unsafeCoerceP p:>:ok_ps) ps - else rpint ok_ps ps - diff --git a/harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs b/harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs new file mode 100644 --- /dev/null +++ b/harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs @@ -0,0 +1,259 @@ +-- TODO: Remove these warning disabling flags... +{-# OPTIONS_GHC -w #-} +{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings #-} +module Darcs.Test.Patch.Arbitrary.PrimFileUUID where + +import qualified Darcs.Test.Patch.Arbitrary.Generic as T + ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP + , mergePairFromTree, mergePairFromTWFP + , patchFromTree ) +import Darcs.Test.Patch.Arbitrary.Generic +import Darcs.Test.Patch.RepoModel + +import Control.Monad ( liftM ) +import Test.QuickCheck +import Darcs.Test.Patch.WithState +import Darcs.Patch.Witnesses.Sealed +import Darcs.Patch.Witnesses.Eq +import Darcs.Patch.Witnesses.Unsafe +import Darcs.Patch.Witnesses.Ordered +import Darcs.Patch.Prim.FileUUID () +import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Location, Hunk(..), UUID(..) ) +import Darcs.Patch.RepoPatch ( RepoPatch ) + +import Darcs.Test.Patch.FileUUIDModel +import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf ) + +import Darcs.UI.Commands.Replace ( defaultToks ) +import Darcs.Patch.Prim + +import Control.Applicative ( (<$>) ) +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString as BS +import Data.Maybe ( isJust ) +import qualified Data.Map as M +import Darcs.Util.Hash( Hash(..) ) + +#include "impossible.h" + +patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t +patchFromTree = T.patchFromTree + +mergePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t +mergePairFromTree = T.mergePairFromTree + +mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState FileUUIDModel (TreeWithFlattenPos Prim) wX -> t +mergePairFromTWFP = T.mergePairFromTWFP + +commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState FileUUIDModel (TreeWithFlattenPos Prim) wX -> t +commutePairFromTWFP = T.commutePairFromTWFP + +commutePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t +commutePairFromTree = T.commutePairFromTree + +commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p :> p) wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t +commuteTripleFromTree = T.commuteTripleFromTree + +type instance ModelOf Prim = FileUUIDModel +instance ArbitraryPrim Prim where + runCoalesceTests _ = False + hasPrimConstruct _ = False + +hunkIdentity (Hunk _ old new) | old == new = unsafeCoerceP IsEq +hunkIdentity _ = NotEq + +instance NullPatch Prim where + nullPatch (BinaryHunk _ x) = hunkIdentity x + nullPatch (TextHunk _ x) = hunkIdentity x + nullPatch _ = NotEq + +instance Arbitrary (Sealed2 (FL (WithState FileUUIDModel Prim))) where + arbitrary = do repo <- ourSmallRepo + liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo + +-- instance Show1 (TreeWithFlattenPos Prim) where +-- showDict1 = ShowDictClass + +-- WithState and propFail are handy for debugging arbitrary code +propFail :: Int -> Tree Prim wX -> Bool +propFail n xs = sizeTree xs < n + +---------------------------------------------------------------------- +-- * QuickCheck generators + +aHunk :: forall wX wY . BS.ByteString -> Gen (Hunk wX wY) +aHunk content + = sized $ \n -> + do pos <- choose (0, BS.length content) + let prefixLen = pos + restLen = BS.length content - prefixLen + oldLen <- frequency + [ (75, choose (0, min restLen n)) + , (25, choose (0, min 10 restLen)) + ] + let nonempty x = if oldLen /= 0 then x else 0 + newLen <- frequency + [ ( 54, choose (1,min 1 n) ) + , ( nonempty 42, choose (1,min 1 oldLen) ) + , ( nonempty 2, return oldLen ) + , ( nonempty 2, return 0 ) + ] + new <- BS.concat <$> vectorOf newLen aLine + let old = BS.take oldLen $ BS.drop prefixLen $ content + return $ Hunk pos old new + +aTextHunk :: forall wX wY . (UUID, Object Fail) -> Gen (Prim wX wY) +aTextHunk (uuid, (Blob text _)) = + do hunk <- aHunk (unFail text) + return $ TextHunk uuid hunk + +aManifest :: forall wX wY . UUID -> Location -> Object Fail -> Gen (Prim wX wY) +aManifest uuid loc (Directory dir) = + do newFilename <- aFilename `notIn` (M.keys dir) + return $ Manifest uuid loc + +aDemanifest :: forall wX wY . UUID -> Location -> Gen (Prim wX wY) +aDemanifest uuid loc = return $ Demanifest uuid loc + +-- | Generates any type of 'Prim' patch, except binary and setpref patches. +aPrim :: forall wX wY . FileUUIDModel wX -> Gen (WithEndState FileUUIDModel (Prim wX) wY) +aPrim repo + = do mbFile <- maybeOf repoFiles + mbDir <- maybeOf repoDirs + mbExisting <- maybeOf $ repoObjects repo + mbManifested <- maybeOf manifested + fresh <- anUUID + filename <- aFilename + dir <- elements (rootDir:repoDirs) + mbOtherDir <- maybeOf repoDirs + let whenfile x = if isJust mbFile then x else 0 + whendir x = if isJust mbDir then x else 0 + whenexisting x = if isJust mbExisting then x else 0 + whenmanifested x = if isJust mbManifested then x else 0 + patch <- frequency + [ ( whenfile 12, aTextHunk $ fromJust mbFile ) + , ( 2, aTextHunk (fresh, Blob (return "") NoHash) ) -- create an empty thing + , ( whenexisting (whendir 2), -- manifest an existing object + aManifest (fst $ fromJust mbExisting) + (fst $ fromJust mbDir, filename) + (snd $ fromJust mbDir)) + , ( whenmanifested 2, uncurry aDemanifest $ fromJust mbManifested ) + -- TODO: demanifest + ] + let repo' = unFail $ repoApply repo patch + return $ WithEndState patch repo' + where + manifested = [ (id, (dirid, name)) | (dirid, Directory dir) <- repoDirs + , (name, id) <- M.toList dir ] + repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ] + repoDirs = [ (id, Directory x) | (id, Directory x) <- repoObjects repo ] + rootDir = (UUID "ROOT", root repo) + +---------------------------------------------------------------------- +-- *** Pairs of primitive patches + +-- Try to generate commutable pairs of hunks +hunkPair :: forall wX wY . (UUID, Object Fail) -> Gen ((Prim :> Prim) wX wY) +hunkPair (uuid, (Blob file _)) = + do h1@(Hunk l1 old1 new1) <- aHunk (unFail file) + (delta, content') <- selectChunk h1 (unFail file) + Hunk l2' old2 new2 <- aHunk content' + let l2 = l2'+delta + return (TextHunk uuid (Hunk l1 old1 new1) :> TextHunk uuid (Hunk l2 old2 new2)) + where + selectChunk (Hunk l old new) content = elements [prefix, suffix] + where start = l - 1 + prefix = (0, BS.take start content) + suffix = (start + BS.length new, BS.drop (start + BS.length old) content) + selectChunk _ _ = impossible + +aPrimPair :: forall wX wY . FileUUIDModel wX -> Gen (WithEndState FileUUIDModel ((Prim :> Prim) wX) wY) +aPrimPair repo + = do mbFile <- maybeOf repoFiles + frequency + [ ( if isJust mbFile then 1 else 0 + , do p1 :> p2 <- hunkPair $ fromJust mbFile + let repo' = unFail $ repoApply repo p1 + repo'' = unFail $ repoApply repo' p2 + return $ WithEndState (p1 :> p2) repo'' + ) + , ( 1 + , do Sealed wesP <- arbitraryState repo + return $ unsafeCoerceP1 wesP + ) + ] + where + repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ] + +---------------------------------------------------------------------- +-- Arbitrary instances + +ourSmallRepo :: Gen (FileUUIDModel wX) +ourSmallRepo = aSmallRepo + +instance ArbitraryState FileUUIDModel Prim where + arbitraryState s = seal <$> aPrim s + + +instance Arbitrary (Sealed2 Prim) where + arbitrary = makeS2Gen ourSmallRepo + +instance Arbitrary (Sealed (Prim x)) where + arbitrary = makeSGen ourSmallRepo + +instance Arbitrary (Sealed2 (Prim :> Prim)) where + arbitrary = do repo <- ourSmallRepo + WithEndState pp _ <- aPrimPair repo + return $ seal2 pp + +instance Arbitrary (Sealed ((Prim :> Prim) wA)) where + arbitrary = do repo <- ourSmallRepo + WithEndState pp _ <- aPrimPair repo + return $ seal pp + +instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where + arbitrary = makeS2Gen ourSmallRepo + +instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where + arbitrary = makeSGen ourSmallRepo + +instance Arbitrary (Sealed2 (FL Prim)) where + arbitrary = makeS2Gen ourSmallRepo + +instance Arbitrary (Sealed ((FL Prim) wA)) where + arbitrary = makeSGen ourSmallRepo + +instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where + arbitrary = makeS2Gen ourSmallRepo + +instance Arbitrary (Sealed ((FL Prim :> FL Prim) wA)) where + arbitrary = makeSGen ourSmallRepo + +instance Arbitrary (Sealed2 (WithState FileUUIDModel Prim)) where + arbitrary = makeWS2Gen ourSmallRepo + +instance Arbitrary (Sealed (WithState FileUUIDModel Prim wA)) where + arbitrary = makeWSGen ourSmallRepo + +instance Arbitrary (Sealed (WithState FileUUIDModel (FL Prim) wA)) where + arbitrary = makeWSGen ourSmallRepo + +instance Arbitrary (Sealed2 (WithState FileUUIDModel (Prim :> Prim))) where + arbitrary = do repo <- ourSmallRepo + WithEndState pp repo' <- aPrimPair repo + return $ seal2 $ WithState repo pp repo' + +instance Arbitrary (Sealed (WithState FileUUIDModel (Prim :> Prim) a)) where + arbitrary = do repo <- ourSmallRepo + WithEndState pp repo' <- aPrimPair repo + return $ seal $ WithState repo pp repo' + + +instance Arbitrary (Sealed2 (WithState FileUUIDModel (FL Prim))) where + arbitrary = makeWS2Gen ourSmallRepo + +instance Arbitrary (Sealed2 (WithState FileUUIDModel (FL Prim :> FL Prim))) where + arbitrary = makeWS2Gen ourSmallRepo + +instance Arbitrary (Sealed (WithState FileUUIDModel (FL Prim :> FL Prim) a)) where + arbitrary = makeWSGen ourSmallRepo diff --git a/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs b/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs --- a/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs @@ -6,6 +6,10 @@ ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP , mergePairFromTree, mergePairFromTWFP , patchFromTree ) + +import Prelude () +import Darcs.Prelude + import Darcs.Test.Patch.Arbitrary.Generic import Darcs.Test.Patch.RepoModel @@ -22,12 +26,12 @@ import Darcs.Patch.FileHunk( IsHunk( isHunk ), FileHunk(..) ) import Darcs.Test.Patch.V1Model +import Darcs.Util.Path import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf ) import Darcs.UI.Commands.Replace ( defaultToks ) import Darcs.Patch.Prim -import Control.Applicative ( (<$>) ) import qualified Data.ByteString.Char8 as BC import Data.Maybe ( isJust ) diff --git a/harness/Darcs/Test/Patch/Arbitrary/PrimV3.hs b/harness/Darcs/Test/Patch/Arbitrary/PrimV3.hs deleted file mode 100644 --- a/harness/Darcs/Test/Patch/Arbitrary/PrimV3.hs +++ /dev/null @@ -1,259 +0,0 @@ --- TODO: Remove these warning disabling flags... -{-# OPTIONS_GHC -w #-} -{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings #-} -module Darcs.Test.Patch.Arbitrary.PrimV3 where - -import qualified Darcs.Test.Patch.Arbitrary.Generic as T - ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP - , mergePairFromTree, mergePairFromTWFP - , patchFromTree ) -import Darcs.Test.Patch.Arbitrary.Generic -import Darcs.Test.Patch.RepoModel - -import Control.Monad ( liftM ) -import Test.QuickCheck -import Darcs.Test.Patch.WithState -import Darcs.Patch.Witnesses.Sealed -import Darcs.Patch.Witnesses.Eq -import Darcs.Patch.Witnesses.Unsafe -import Darcs.Patch.Witnesses.Ordered -import Darcs.Patch.Prim.V3 () -import Darcs.Patch.Prim.V3.Core ( Prim(..), Location, Hunk(..), UUID(..) ) -import Darcs.Patch.RepoPatch ( RepoPatch ) - -import Darcs.Test.Patch.V3Model -import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf ) - -import Darcs.UI.Commands.Replace ( defaultToks ) -import Darcs.Patch.Prim - -import Control.Applicative ( (<$>) ) -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString as BS -import Data.Maybe ( isJust ) -import qualified Data.Map as M -import Storage.Hashed.Hash( Hash(..) ) - -#include "impossible.h" - -patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState V3Model (Tree Prim) wX -> t -patchFromTree = T.patchFromTree - -mergePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V3Model (Tree Prim) wX -> t -mergePairFromTree = T.mergePairFromTree - -mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V3Model (TreeWithFlattenPos Prim) wX -> t -mergePairFromTWFP = T.mergePairFromTWFP - -commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V3Model (TreeWithFlattenPos Prim) wX -> t -commutePairFromTWFP = T.commutePairFromTWFP - -commutePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V3Model (Tree Prim) wX -> t -commutePairFromTree = T.commutePairFromTree - -commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p :> p) wY wZ -> t) -> WithStartState V3Model (Tree Prim) wX -> t -commuteTripleFromTree = T.commuteTripleFromTree - -type instance ModelOf Prim = V3Model -instance ArbitraryPrim Prim where - runCoalesceTests _ = False - hasPrimConstruct _ = False - -hunkIdentity (Hunk _ old new) | old == new = unsafeCoerceP IsEq -hunkIdentity _ = NotEq - -instance NullPatch Prim where - nullPatch (BinaryHunk _ x) = hunkIdentity x - nullPatch (TextHunk _ x) = hunkIdentity x - nullPatch _ = NotEq - -instance Arbitrary (Sealed2 (FL (WithState V3Model Prim))) where - arbitrary = do repo <- ourSmallRepo - liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo - --- instance Show1 (TreeWithFlattenPos Prim) where --- showDict1 = ShowDictClass - --- WithState and propFail are handy for debugging arbitrary code -propFail :: Int -> Tree Prim wX -> Bool -propFail n xs = sizeTree xs < n - ----------------------------------------------------------------------- --- * QuickCheck generators - -aHunk :: forall wX wY . BS.ByteString -> Gen (Hunk wX wY) -aHunk content - = sized $ \n -> - do pos <- choose (0, BS.length content) - let prefixLen = pos - restLen = BS.length content - prefixLen - oldLen <- frequency - [ (75, choose (0, min restLen n)) - , (25, choose (0, min 10 restLen)) - ] - let nonempty x = if oldLen /= 0 then x else 0 - newLen <- frequency - [ ( 54, choose (1,min 1 n) ) - , ( nonempty 42, choose (1,min 1 oldLen) ) - , ( nonempty 2, return oldLen ) - , ( nonempty 2, return 0 ) - ] - new <- BS.concat <$> vectorOf newLen aLine - let old = BS.take oldLen $ BS.drop prefixLen $ content - return $ Hunk pos old new - -aTextHunk :: forall wX wY . (UUID, Object Fail) -> Gen (Prim wX wY) -aTextHunk (uuid, (Blob text _)) = - do hunk <- aHunk (unFail text) - return $ TextHunk uuid hunk - -aManifest :: forall wX wY . UUID -> Location -> Object Fail -> Gen (Prim wX wY) -aManifest uuid loc (Directory dir) = - do newFilename <- aFilename `notIn` (M.keys dir) - return $ Manifest uuid loc - -aDemanifest :: forall wX wY . UUID -> Location -> Gen (Prim wX wY) -aDemanifest uuid loc = return $ Demanifest uuid loc - --- | Generates any type of 'Prim' patch, except binary and setpref patches. -aPrim :: forall wX wY . V3Model wX -> Gen (WithEndState V3Model (Prim wX) wY) -aPrim repo - = do mbFile <- maybeOf repoFiles - mbDir <- maybeOf repoDirs - mbExisting <- maybeOf $ repoObjects repo - mbManifested <- maybeOf manifested - fresh <- anUUID - filename <- aFilename - dir <- elements (rootDir:repoDirs) - mbOtherDir <- maybeOf repoDirs - let whenfile x = if isJust mbFile then x else 0 - whendir x = if isJust mbDir then x else 0 - whenexisting x = if isJust mbExisting then x else 0 - whenmanifested x = if isJust mbManifested then x else 0 - patch <- frequency - [ ( whenfile 12, aTextHunk $ fromJust mbFile ) - , ( 2, aTextHunk (fresh, Blob (return "") NoHash) ) -- create an empty thing - , ( whenexisting (whendir 2), -- manifest an existing object - aManifest (fst $ fromJust mbExisting) - (fst $ fromJust mbDir, filename) - (snd $ fromJust mbDir)) - , ( whenmanifested 2, uncurry aDemanifest $ fromJust mbManifested ) - -- TODO: demanifest - ] - let repo' = unFail $ repoApply repo patch - return $ WithEndState patch repo' - where - manifested = [ (id, (dirid, name)) | (dirid, Directory dir) <- repoDirs - , (name, id) <- M.toList dir ] - repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ] - repoDirs = [ (id, Directory x) | (id, Directory x) <- repoObjects repo ] - rootDir = (UUID "ROOT", root repo) - ----------------------------------------------------------------------- --- *** Pairs of primitive patches - --- Try to generate commutable pairs of hunks -hunkPair :: forall wX wY . (UUID, Object Fail) -> Gen ((Prim :> Prim) wX wY) -hunkPair (uuid, (Blob file _)) = - do h1@(Hunk l1 old1 new1) <- aHunk (unFail file) - (delta, content') <- selectChunk h1 (unFail file) - Hunk l2' old2 new2 <- aHunk content' - let l2 = l2'+delta - return (TextHunk uuid (Hunk l1 old1 new1) :> TextHunk uuid (Hunk l2 old2 new2)) - where - selectChunk (Hunk l old new) content = elements [prefix, suffix] - where start = l - 1 - prefix = (0, BS.take start content) - suffix = (start + BS.length new, BS.drop (start + BS.length old) content) - selectChunk _ _ = impossible - -aPrimPair :: forall wX wY . V3Model wX -> Gen (WithEndState V3Model ((Prim :> Prim) wX) wY) -aPrimPair repo - = do mbFile <- maybeOf repoFiles - frequency - [ ( if isJust mbFile then 1 else 0 - , do p1 :> p2 <- hunkPair $ fromJust mbFile - let repo' = unFail $ repoApply repo p1 - repo'' = unFail $ repoApply repo' p2 - return $ WithEndState (p1 :> p2) repo'' - ) - , ( 1 - , do Sealed wesP <- arbitraryState repo - return $ unsafeCoerceP1 wesP - ) - ] - where - repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ] - ----------------------------------------------------------------------- --- Arbitrary instances - -ourSmallRepo :: Gen (V3Model wX) -ourSmallRepo = aSmallRepo - -instance ArbitraryState V3Model Prim where - arbitraryState s = seal <$> aPrim s - - -instance Arbitrary (Sealed2 Prim) where - arbitrary = makeS2Gen ourSmallRepo - -instance Arbitrary (Sealed (Prim x)) where - arbitrary = makeSGen ourSmallRepo - -instance Arbitrary (Sealed2 (Prim :> Prim)) where - arbitrary = do repo <- ourSmallRepo - WithEndState pp _ <- aPrimPair repo - return $ seal2 pp - -instance Arbitrary (Sealed ((Prim :> Prim) wA)) where - arbitrary = do repo <- ourSmallRepo - WithEndState pp _ <- aPrimPair repo - return $ seal pp - -instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where - arbitrary = makeS2Gen ourSmallRepo - -instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where - arbitrary = makeSGen ourSmallRepo - -instance Arbitrary (Sealed2 (FL Prim)) where - arbitrary = makeS2Gen ourSmallRepo - -instance Arbitrary (Sealed ((FL Prim) wA)) where - arbitrary = makeSGen ourSmallRepo - -instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where - arbitrary = makeS2Gen ourSmallRepo - -instance Arbitrary (Sealed ((FL Prim :> FL Prim) wA)) where - arbitrary = makeSGen ourSmallRepo - -instance Arbitrary (Sealed2 (WithState V3Model Prim)) where - arbitrary = makeWS2Gen ourSmallRepo - -instance Arbitrary (Sealed (WithState V3Model Prim wA)) where - arbitrary = makeWSGen ourSmallRepo - -instance Arbitrary (Sealed (WithState V3Model (FL Prim) wA)) where - arbitrary = makeWSGen ourSmallRepo - -instance Arbitrary (Sealed2 (WithState V3Model (Prim :> Prim))) where - arbitrary = do repo <- ourSmallRepo - WithEndState pp repo' <- aPrimPair repo - return $ seal2 $ WithState repo pp repo' - -instance Arbitrary (Sealed (WithState V3Model (Prim :> Prim) a)) where - arbitrary = do repo <- ourSmallRepo - WithEndState pp repo' <- aPrimPair repo - return $ seal $ WithState repo pp repo' - - -instance Arbitrary (Sealed2 (WithState V3Model (FL Prim))) where - arbitrary = makeWS2Gen ourSmallRepo - -instance Arbitrary (Sealed2 (WithState V3Model (FL Prim :> FL Prim))) where - arbitrary = makeWS2Gen ourSmallRepo - -instance Arbitrary (Sealed (WithState V3Model (FL Prim :> FL Prim) a)) where - arbitrary = makeWSGen ourSmallRepo diff --git a/harness/Darcs/Test/Patch/Arbitrary/Real.hs b/harness/Darcs/Test/Patch/Arbitrary/Real.hs deleted file mode 100644 --- a/harness/Darcs/Test/Patch/Arbitrary/Real.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE UndecidableInstances #-} -module Darcs.Test.Patch.Arbitrary.Real where -import Darcs.Test.Patch.Arbitrary.Generic -import Darcs.Test.Patch.Arbitrary.PrimV1 () -import Darcs.Test.Patch.RepoModel - -import Darcs.Patch.Witnesses.Ordered -import Darcs.Patch.Merge ( Merge(..) ) -import Darcs.Patch.Patchy ( Patchy, Commute(..) ) -import Darcs.Patch.Prim ( PrimPatch, anIdentity ) -import Darcs.Patch.V2 ( RealPatch ) -import Darcs.Patch.V2.Real ( isDuplicate ) - -import Test.QuickCheck -import Darcs.Test.Patch.WithState -import Darcs.Patch.Witnesses.Sealed -import Darcs.Patch.Witnesses.Eq -import Darcs.Patch.Prim ( FromPrim(..) ) - - -nontrivialReals :: PrimPatch prim => (RealPatch prim :> RealPatch prim) wX wY -> Bool -nontrivialReals = nontrivialCommute - -nontrivialCommute :: (Patchy p, MyEq p) => (p :> p) wX wY -> Bool -nontrivialCommute (x :> y) = case commute (x :> y) of - Just (y' :> x') -> not (y' `unsafeCompare` y) || - not (x' `unsafeCompare` x) - Nothing -> False - -nontrivialMergeReals :: PrimPatch prim => (RealPatch prim :\/: RealPatch prim) wX wY -> Bool -nontrivialMergeReals = nontrivialMerge - -nontrivialMerge :: (Patchy p, MyEq p, Merge p) => (p :\/: p) wX wY -> Bool -nontrivialMerge (x :\/: y) = case merge (x :\/: y) of - y' :/\: x' -> not (y' `unsafeCompare` y) || - not (x' `unsafeCompare` x) - -instance MightHaveDuplicate (RealPatch prim) where - hasDuplicate = isDuplicate - -instance (RepoModel (ModelOf prim), ArbitraryPrim prim) - => Arbitrary (Sealed2 (FL (RealPatch prim))) where - arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim))) - return $ unseal seal2 (flattenOne tree) - -instance (RepoModel (ModelOf prim), ArbitraryPrim prim) - => Arbitrary (Sealed2 (RealPatch prim)) where - arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim))) - case mapFL seal2 `unseal` flattenOne tree of - [] -> return $ seal2 $ fromPrim anIdentity - ps -> elements ps - -notDuplicatestriple :: (RealPatch prim :> RealPatch prim :> RealPatch prim) wX wY -> Bool -notDuplicatestriple (a :> b :> c) = not (isDuplicate a || isDuplicate b || isDuplicate c) - -nontrivialTriple :: PrimPatch prim => (RealPatch prim :> RealPatch prim :> RealPatch prim) wX wY -> Bool -nontrivialTriple (a :> b :> c) = - case commute (a :> b) of - Nothing -> False - Just (b' :> a') -> - case commute (a' :> c) of - Nothing -> False - Just (c'' :> a'') -> - case commute (b :> c) of - Nothing -> False - Just (c' :> b'') -> (not (a `unsafeCompare` a') || not (b `unsafeCompare` b')) && - (not (c' `unsafeCompare` c) || not (b'' `unsafeCompare` b)) && - (not (c'' `unsafeCompare` c) || not (a'' `unsafeCompare` a')) diff --git a/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs b/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs new file mode 100644 --- /dev/null +++ b/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs @@ -0,0 +1,291 @@ +-- Copyright (C) 2002-2003,2007 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. + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-} + + +module Darcs.Test.Patch.Arbitrary.RepoPatchV1 () where + +import Prelude () +import Darcs.Prelude + +import System.IO.Unsafe ( unsafePerformIO ) +import Test.QuickCheck +import Control.Monad ( liftM, liftM2, liftM3, liftM4, replicateM ) + +import Darcs.Patch.Info ( PatchInfo, patchinfo ) +import qualified Data.ByteString as B ( ByteString ) +import qualified Data.ByteString.Char8 as BC ( pack ) + +import Darcs.Patch ( addfile, adddir, move, + hunk, tokreplace, binary, + changepref, invert, merge ) +import Darcs.Patch.V1 () +import qualified Darcs.Patch.V1.Core as V1 ( RepoPatchV1(..) ) +import Darcs.Patch.Prim.V1 () +import Darcs.Patch.Prim.V1.Core ( Prim(..) ) +import Darcs.Patch.Witnesses.Ordered +import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), unseal, mapSeal, Sealed2(..) ) +import Darcs.Patch.Witnesses.Unsafe + +-- This definitely feels a bit weird to be importing Properties here, and +-- probably means we want to move this elsewhere, but Darcs.Test.Patch.Check is +-- already taken with something apparently only semi-related +import Darcs.Test.Patch.Properties.Check( checkAPatch ) +import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate ) + +#include "impossible.h" + +type Patch = V1.RepoPatchV1 Prim + +class ArbitraryP p where + arbitraryP :: Gen (Sealed (p wX)) + +{- +TODO: there is a lot of overlap in testing between between this module +and Darcs.Test.Patch.QuickCheck + +This module tests Prim and V1 patches, and Darcs.Test.Patch.QuickCheck +tests Prim and V2 patches + +This module's generator covers a wider set of patch types, but is less +likely to generate conflicts than Darcs.Test.Patch.QuickCheck. + +Until this is cleaned up, we take some care that the Arbitrary instances +do not overlap and are only used for tests from the respective +modules. + +(There are also tests in other modules that probably depend on the +Arbitrary instances in this module.) +-} + +instance Arbitrary (Sealed (Prim wX)) where + arbitrary = arbitraryP + +instance Arbitrary (Sealed (FL Patch wX)) where + arbitrary = arbitraryP + +-- instance Arbitrary (Sealed2 (Prim :> Prim)) where + -- arbitrary = unseal Sealed2 <$> arbitraryP + +instance Arbitrary (Sealed2 (FL Patch)) where + arbitrary = unseal Sealed2 <$> arbitraryP + +instance Arbitrary (Sealed2 (FL Patch :\/: FL Patch)) where + arbitrary = unseal Sealed2 <$> arbitraryP + +instance Arbitrary (Sealed2 (FL Patch :> FL Patch)) where + arbitrary = unseal Sealed2 <$> arbitraryP + +instance Arbitrary (Sealed2 (FL Patch :> FL Patch :> FL Patch)) where + arbitrary = unseal Sealed2 <$> arbitraryP + + +instance (ArbitraryP p1, ArbitraryP p2) => ArbitraryP (p1 :> p2) where + arbitraryP = do Sealed p1 <- arbitraryP + Sealed p2 <- arbitraryP + return (Sealed (p1 :> p2)) + +instance (ArbitraryP p1, ArbitraryP p2) => ArbitraryP (p1 :\/: p2) where + arbitraryP = do Sealed p1 <- arbitraryP + Sealed p2 <- arbitraryP + return (Sealed (unsafeCoercePEnd p1 :\/: p2)) + +instance ArbitraryP (FL Patch) where + arbitraryP = sized arbpatch + +instance ArbitraryP Prim where + arbitraryP = onepatchgen + +instance MightHaveDuplicate (V1.RepoPatchV1 prim) + +hunkgen :: Gen (Sealed (Prim wX)) +hunkgen = do + i <- frequency [(1,choose (0,5)),(1,choose (0,35)), + (2,return 0),(3,return 1),(2,return 2),(1,return 3)] + j <- frequency [(1,choose (0,5)),(1,choose (0,35)), + (2,return 0),(3,return 1),(2,return 2),(1,return 3)] + if i == 0 && j == 0 then hunkgen + else Sealed <$> + liftM4 hunk filepathgen linenumgen + (replicateM i filelinegen) + (replicateM j filelinegen) + +tokreplacegen :: Gen (Sealed (Prim wX)) +tokreplacegen = do + f <- filepathgen + o <- tokengen + n <- tokengen + if o == n + then return $ Sealed $ tokreplace f "A-Za-z" "old" "new" + else return $ Sealed $ tokreplace f "A-Za-z_" o n + +twofilegen :: (forall wY . FilePath -> FilePath -> Prim wX wY) -> Gen (Sealed (Prim wX)) +twofilegen p = do + n1 <- filepathgen + n2 <- filepathgen + if n1 /= n2 && checkAPatch (p n1 n2) + then return $ Sealed $ p n1 n2 + else twofilegen p + +chprefgen :: Gen (Sealed (Prim wX)) +chprefgen = do + f <- oneof [return "color", return "movie"] + o <- tokengen + n <- tokengen + if o == n then return $ Sealed $ changepref f "old" "new" + else return $ Sealed $ changepref f o n + +simplepatchgen :: Gen (Sealed (Prim wX)) +simplepatchgen = frequency [(1,liftM (Sealed . addfile) filepathgen), + (1,liftM (Sealed . adddir) filepathgen), + (1,liftM3 (\x y z -> Sealed (binary x y z)) filepathgen arbitrary arbitrary), + (1,twofilegen move), + (1,tokreplacegen), + (1,chprefgen), + (7,hunkgen) + ] + +onepatchgen :: Gen (Sealed (Prim wX)) +onepatchgen = oneof [simplepatchgen, mapSeal (invert . unsafeCoerceP) `fmap` simplepatchgen] + +norecursgen :: Int -> Gen (Sealed (FL Patch wX)) +norecursgen 0 = mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen +norecursgen n = oneof [mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen,flatcompgen n] + +arbpatch :: Int -> Gen (Sealed (FL Patch wX)) +arbpatch 0 = mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen +arbpatch n = frequency [(3,mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen), + (2,flatcompgen n), + (0,rawMergeGen n), + (0,mergegen n), + (1,mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen) + ] + +-- | Generate an arbitrary list of at least one element +unempty :: Arbitrary a => Gen [a] +unempty = do + a <- arbitrary + as <- arbitrary + return (a:as) + +rawMergeGen :: Int -> Gen (Sealed (FL Patch wX)) +rawMergeGen n = do Sealed p1 <- arbpatch len + Sealed p2 <- arbpatch len + if checkAPatch (invert p1:>:p2:>:NilFL) && + checkAPatch (invert p2:>:p1:>:NilFL) + then case merge (p2 :\/: p1) of + _ :/\: p2' -> return (Sealed (unsafeCoercePStart p2')) + else rawMergeGen n + where len = if n < 15 then n`div`3 else 3 + +mergegen :: Int -> Gen (Sealed (FL Patch wX)) +mergegen n = do + Sealed p1 <- norecursgen len + Sealed p2 <- norecursgen len + if checkAPatch (invert p1:>:p2:>:NilFL) && + checkAPatch (invert p2:>:p1:>:NilFL) + then case merge (p2:\/:p1) of + _ :/\: p2' -> + if checkAPatch (p1+>+p2') + then return $ Sealed $ p1+>+p2' + else impossible + else mergegen n + where len = if n < 15 then n`div`3 else 3 + +arbpi :: Gen PatchInfo +arbpi = do n <- unempty + a <- unempty + l <- unempty + d <- unempty + return $ unsafePerformIO $ patchinfo n d a l + +instance Arbitrary PatchInfo where + arbitrary = arbpi + +instance Arbitrary B.ByteString where + arbitrary = liftM BC.pack arbitrary + +flatlistgen :: Int -> Gen (Sealed (FL Patch wX)) +flatlistgen 0 = return $ Sealed NilFL +flatlistgen n = do Sealed x <- onepatchgen + Sealed xs <- flatlistgen (n-1) + return (Sealed (V1.PP x :>: xs)) + +flatcompgen :: Int -> Gen (Sealed (FL Patch wX)) +flatcompgen n = do + Sealed ps <- flatlistgen n + let myp = regularizePatches $ ps + if checkAPatch myp + then return $ Sealed myp + else flatcompgen n + +-- resize to size 25, that means we'll get line numbers no greater +-- than 1025 using QuickCheck 2.1 +linenumgen :: Gen Int +linenumgen = frequency [(1,return 1), (1,return 2), (1,return 3), + (3,liftM (\n->1+abs n) (resize 25 arbitrary)) ] + +tokengen :: Gen String +tokengen = oneof [return "hello", return "world", return "this", + return "is", return "a", return "silly", + return "token", return "test"] + +toklinegen :: Gen String +toklinegen = liftM unwords $ replicateM 3 tokengen + +filelinegen :: Gen B.ByteString +filelinegen = liftM BC.pack $ + frequency [(1,map fromSafeChar `fmap` arbitrary),(5,toklinegen), + (1,return ""), (1,return "{"), (1,return "}") ] + +filepathgen :: Gen String +filepathgen = liftM fixpath badfpgen + +fixpath :: String -> String +fixpath "" = "test" +fixpath p = fpth p + +fpth :: String -> String +fpth ('/':'/':cs) = fpth ('/':cs) +fpth (c:cs) = c : fpth cs +fpth [] = [] + +newtype SafeChar = SS Char +instance Arbitrary SafeChar where + arbitrary = oneof $ map (return . SS) (['a'..'z']++['A'..'Z']++['1'..'9']++"0") + +fromSafeChar :: SafeChar -> Char +fromSafeChar (SS s) = s + +badfpgen :: Gen String +badfpgen = frequency [(1,return "test"), (1,return "hello"), (1,return "world"), + (1,map fromSafeChar `fmap` arbitrary), + (1,liftM2 (\a b-> a++"/"++b) filepathgen filepathgen) ] + +regularizePatches :: FL Patch wX wY -> FL Patch wX wY +regularizePatches patches = rpint (unsafeCoerceP NilFL) patches + where -- this reverses the list, which seems odd and causes + -- the witness unsafety + rpint :: FL Patch wX wY -> FL Patch wA wB -> FL Patch wX wY + rpint ok_ps NilFL = ok_ps + rpint ok_ps (p:>:ps) = + if checkAPatch (unsafeCoerceP p:>:ok_ps) + then rpint (unsafeCoerceP p:>:ok_ps) ps + else rpint ok_ps ps + diff --git a/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs b/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs new file mode 100644 --- /dev/null +++ b/harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} +module Darcs.Test.Patch.Arbitrary.RepoPatchV2 where +import Darcs.Test.Patch.Arbitrary.Generic +import Darcs.Test.Patch.Arbitrary.PrimV1 () +import Darcs.Test.Patch.RepoModel + +import Darcs.Patch.Witnesses.Ordered +import Darcs.Patch.Merge ( Merge(..) ) +import Darcs.Patch.Patchy ( Patchy, Commute(..) ) +import Darcs.Patch.Prim ( PrimPatch, anIdentity ) +import Darcs.Patch.V2 ( RepoPatchV2 ) +import Darcs.Patch.V2.RepoPatch ( isDuplicate ) + +import Test.QuickCheck +import Darcs.Test.Patch.WithState +import Darcs.Patch.Witnesses.Sealed +import Darcs.Patch.Witnesses.Eq +import Darcs.Patch.Prim ( FromPrim(..) ) + + +nontrivialRepoPatchV2s :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> Bool +nontrivialRepoPatchV2s = nontrivialCommute + +nontrivialCommute :: (Patchy p, MyEq p) => (p :> p) wX wY -> Bool +nontrivialCommute (x :> y) = case commute (x :> y) of + Just (y' :> x') -> not (y' `unsafeCompare` y) || + not (x' `unsafeCompare` x) + Nothing -> False + +nontrivialMergerepoPatchV2s :: PrimPatch prim => (RepoPatchV2 prim :\/: RepoPatchV2 prim) wX wY -> Bool +nontrivialMergerepoPatchV2s = nontrivialMerge + +nontrivialMerge :: (Patchy p, MyEq p, Merge p) => (p :\/: p) wX wY -> Bool +nontrivialMerge (x :\/: y) = case merge (x :\/: y) of + y' :/\: x' -> not (y' `unsafeCompare` y) || + not (x' `unsafeCompare` x) + +instance MightHaveDuplicate (RepoPatchV2 prim) where + hasDuplicate = isDuplicate + +instance (RepoModel (ModelOf prim), ArbitraryPrim prim) + => Arbitrary (Sealed2 (FL (RepoPatchV2 prim))) where + arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim))) + return $ unseal seal2 (flattenOne tree) + +instance (RepoModel (ModelOf prim), ArbitraryPrim prim) + => Arbitrary (Sealed2 (RepoPatchV2 prim)) where + arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim))) + case mapFL seal2 `unseal` flattenOne tree of + [] -> return $ seal2 $ fromPrim anIdentity + ps -> elements ps + +notDuplicatestriple :: (RepoPatchV2 prim :> RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> Bool +notDuplicatestriple (a :> b :> c) = not (isDuplicate a || isDuplicate b || isDuplicate c) + +nontrivialTriple :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> Bool +nontrivialTriple (a :> b :> c) = + case commute (a :> b) of + Nothing -> False + Just (b' :> a') -> + case commute (a' :> c) of + Nothing -> False + Just (c'' :> a'') -> + case commute (b :> c) of + Nothing -> False + Just (c' :> b'') -> (not (a `unsafeCompare` a') || not (b `unsafeCompare` b')) && + (not (c' `unsafeCompare` c) || not (b'' `unsafeCompare` b)) && + (not (c'' `unsafeCompare` c) || not (a'' `unsafeCompare` a')) diff --git a/harness/Darcs/Test/Patch/Examples/Set1.hs b/harness/Darcs/Test/Patch/Examples/Set1.hs --- a/harness/Darcs/Test/Patch/Examples/Set1.hs +++ b/harness/Darcs/Test/Patch/Examples/Set1.hs @@ -35,7 +35,7 @@ , adddir, addfile, hunk, binary, rmdir, rmfile, tokreplace ) import Darcs.Patch.Prim ( PrimOf, FromPrim ) import Darcs.Patch.Prim.V1 ( Prim ) -import qualified Darcs.Patch.V1 as V1 ( Patch ) +import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 ) import Darcs.Test.Patch.Properties.Check( checkAPatch ) import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed ( unsafeUnseal ) @@ -43,7 +43,7 @@ #include "impossible.h" -type Patch = V1.Patch Prim +type Patch = V1.RepoPatchV1 Prim -- The unit tester function is really just a glorified map for functions that -- return lists, in which the lists get concatenated (where map would end up @@ -132,68 +132,68 @@ -- ---------------------------------------------------------------------- -- | Here we provide a set of known interesting commutes. -knownCommutes :: [((FL Patch: FL Patch) wX wY,(FL Patch :> FL Patch) wX wY)] knownCommutes = [ - (testhunk 1 [] ["A"]:< - testhunk 2 [] ["B"], - testhunk 3 [] ["B"]:< - testhunk 1 [] ["A"]), - (fromPrim (tokreplace "test" "A-Za-z_" "old" "new"):< - testhunk 2 + (testhunk 2 [] ["B"]:> + testhunk 1 [] ["A"], + testhunk 1 [] ["A"]:> + testhunk 3 [] ["B"]), + (testhunk 2 ["hello world all that is old is good old_"] - ["I don't like old things"], + ["I don't like old things"]:> + fromPrim (tokreplace "test" "A-Za-z_" "old" "new"), + fromPrim (tokreplace "test" "A-Za-z_" "old" "new"):> testhunk 2 ["hello world all that is new is good old_"] - ["I don't like new things"]:< - fromPrim (tokreplace "test" "A-Za-z_" "old" "new")), - (testhunk 1 ["A"] ["B"]:< - testhunk 2 ["C"] ["D"], - testhunk 2 ["C"] ["D"]:< - testhunk 1 ["A"] ["B"]), - (fromPrim (rmfile "NwNSO"):< - (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))), - (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))):< - fromPrim (rmfile "NwNSO")), + ["I don't like new things"]), + (testhunk 2 ["C"] ["D"]:> + testhunk 1 ["A"] ["B"], + testhunk 1 ["A"] ["B"]:> + testhunk 2 ["C"] ["D"]), + ((quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))):> + fromPrim (rmfile "NwNSO"), + fromPrim (rmfile "NwNSO"):> + (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello")))), - (quickmerge (testhunk 3 ["o"] ["n"]:\/: - testhunk 3 ["o"] ["v"]):< - testhunk 1 [] ["a"], - testhunk 1 [] ["a"]:< + (testhunk 1 [] ["a"]:> + quickmerge (testhunk 3 ["o"] ["n"]:\/: + testhunk 3 ["o"] ["v"]), quickmerge (testhunk 2 ["o"] ["n"]:\/: - testhunk 2 ["o"] ["v"])), + testhunk 2 ["o"] ["v"]):> + testhunk 1 [] ["a"]), - (testhunk 1 ["A"] []:< - testhunk 3 ["B"] [], - testhunk 2 ["B"] []:< - testhunk 1 ["A"] []), + (testhunk 3 ["B"] []:> + testhunk 1 ["A"] [], + testhunk 1 ["A"] []:> + testhunk 2 ["B"] []), - (testhunk 1 ["A"] ["B"]:< - testhunk 2 ["B"] ["C"], - testhunk 2 ["B"] ["C"]:< - testhunk 1 ["A"] ["B"]), + (testhunk 2 ["B"] ["C"]:> + testhunk 1 ["A"] ["B"], + testhunk 1 ["A"] ["B"]:> + testhunk 2 ["B"] ["C"]), - (testhunk 1 ["A"] ["B"]:< - testhunk 3 ["B"] ["C"], - testhunk 3 ["B"] ["C"]:< - testhunk 1 ["A"] ["B"]), + (testhunk 3 ["B"] ["C"]:> + testhunk 1 ["A"] ["B"], + testhunk 1 ["A"] ["B"]:> + testhunk 3 ["B"] ["C"]), - (testhunk 1 ["A"] ["B","C"]:< - testhunk 2 ["B"] ["C","D"], - testhunk 3 ["B"] ["C","D"]:< - testhunk 1 ["A"] ["B","C"])] + (testhunk 2 ["B"] ["C","D"]:> + testhunk 1 ["A"] ["B","C"], + testhunk 1 ["A"] ["B","C"]:> + testhunk 3 ["B"] ["C","D"])] where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n) -knownCantCommutes :: [(FL Patch:< FL Patch) wX wY] +knownCantCommutes :: [(FL Patch :> FL Patch) wX wY] knownCantCommutes = [ - (testhunk 2 ["o"] ["n"]:< + (testhunk 1 [] ["A"]:> + testhunk 2 ["o"] ["n"]), + (testhunk 1 ["o"] ["n"]:> testhunk 1 [] ["A"]), - (testhunk 1 [] ["A"]:< - testhunk 1 ["o"] ["n"]), - (quickmerge (testhunk 2 ["o"] ["n"]:\/: - testhunk 2 ["o"] ["v"]):< - testhunk 1 [] ["a"]), - (fromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])):< - fromPrim (addfile "test"))] + (testhunk 1 [] ["a"]:> + quickmerge (testhunk 2 ["o"] ["n"]:\/: + testhunk 2 ["o"] ["v"])), + (fromPrim (addfile "test"):> + fromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])))] where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n) -- ---------------------------------------------------------------------- diff --git a/harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs b/harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs --- a/harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs +++ b/harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs @@ -22,8 +22,8 @@ module Darcs.Test.Patch.Examples.Set2Unwitnessed ( primPermutables, primPatches , commutables, commutablesFL - , realCommutables , realMergeables, realTriples - , realNonduplicateTriples, realPatches, realPatchLoopExamples + , repov2Commutables , repov2Mergeables, repov2Triples + , repov2NonduplicateTriples, repov2Patches, repov2PatchLoopExamples ) where import Data.Maybe ( catMaybes ) @@ -33,12 +33,12 @@ import Darcs.Patch.Patchy ( Invert(..) ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Prim.V1 ( Prim ) -import Darcs.Patch.V2 ( RealPatch ) -import Darcs.Patch.V2.Real ( prim2real ) +import Darcs.Patch.V2 ( RepoPatchV2 ) +import Darcs.Patch.V2.RepoPatch ( prim2repopatchV2 ) -- import Darcs.Test.Patch.Test () -- for instance Eq Patch -- import Darcs.Test.Patch.Examples.Set2Unwitnessed import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -import qualified Darcs.Test.Patch.Arbitrary.Real as W ( notDuplicatestriple ) +import qualified Darcs.Test.Patch.Arbitrary.RepoPatchV2 as W ( notDuplicatestriple ) --import Darcs.Util.Printer ( greenText ) --import Darcs.Util.Printer.Color ( traceDoc ) --import Darcs.Util.Printer.Color ( errorDoc ) @@ -48,10 +48,10 @@ import qualified Darcs.Patch.Witnesses.Ordered as W ( (:>), (:\/:) ) import qualified Data.ByteString as B ( ByteString ) import Darcs.Test.Patch.V1Model ( V1Model, Content - , makeRepo, makeName, makeFile) + , makeRepo, makeFile) import Darcs.Test.Patch.WithState ( WithStartState(..) ) import Darcs.Patch.Prim.V1.Core ( Prim(FP), FilePatchType(Hunk) ) -import Darcs.Util.Path ( FileName, fp2fn ) +import Darcs.Util.Path ( FileName, fp2fn, makeName ) import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim ) import Darcs.Patch.Merge ( Merge ) import Darcs.Test.Patch.Arbitrary.Generic @@ -237,8 +237,8 @@ packStringLetters :: String -> [B.ByteString] packStringLetters = map (BC.pack . (:[])) -w_realPatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))] -w_realPatchLoopExamples = +w_repov2PatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))] +w_repov2PatchLoopExamples = [Sealed (WithStartState (makeSimpleRepo fx_name []) $ canonizeTree (ParTree @@ -304,19 +304,19 @@ fx = fp2fn "./F" -mergeExamples :: [Sealed2 (RealPatch Prim :\/: RealPatch Prim)] +mergeExamples :: [Sealed2 (RepoPatchV2 Prim :\/: RepoPatchV2 Prim)] mergeExamples = map (mapSeal2 fromW) w_mergeExamples -realPatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))] -realPatchLoopExamples = w_realPatchLoopExamples +repov2PatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))] +repov2PatchLoopExamples = w_repov2PatchLoopExamples -commuteExamples :: [Sealed2 (RealPatch Prim :> RealPatch Prim)] +commuteExamples :: [Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim)] commuteExamples = map (mapSeal2 fromW) w_commuteExamples -tripleExamples :: [Sealed2 (RealPatch Prim :> RealPatch Prim :> RealPatch Prim)] +tripleExamples :: [Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim)] tripleExamples = map (mapSeal2 fromW) w_tripleExamples -notDuplicatestriple :: (RealPatch Prim :> RealPatch Prim :> RealPatch Prim) wX wY -> Bool +notDuplicatestriple :: (RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim) wX wY -> Bool notDuplicatestriple = W.notDuplicatestriple . toW quickhunk :: PrimPatch prim => Int -> String -> String -> prim wX wY @@ -355,45 +355,45 @@ primPatches = concatMap mergeable2patches mergeables where mergeable2patches (x:\/:y) = [x,y] -realPatches :: [RealPatch Prim wX wY] -realPatches = concatMap commutable2patches realCommutables +repov2Patches :: [RepoPatchV2 Prim wX wY] +repov2Patches = concatMap commutable2patches repov2Commutables where commutable2patches (x:>y) = [x,y] -realTriples :: [(RealPatch Prim :> RealPatch Prim :> RealPatch Prim) wX wY] -realTriples = [ob' :> oa2 :> a2'', - oa' :> oa2 :> a2''] +repov2Triples :: [(RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim) wX wY] +repov2Triples = [ob' :> oa2 :> a2'', + oa' :> oa2 :> a2''] ++ map unsafeUnseal2 tripleExamples - ++ map unsafeUnseal2 (concatMap getTriples realFLs) - where oa = prim2real $ quickhunk 1 "o" "aa" + ++ map unsafeUnseal2 (concatMap getTriples repov2FLs) + where oa = prim2repopatchV2 $ quickhunk 1 "o" "aa" oa2 = oa - a2 = prim2real $ quickhunk 2 "a34" "2xx" - ob = prim2real $ quickhunk 1 "o" "bb" + a2 = prim2repopatchV2 $ quickhunk 2 "a34" "2xx" + ob = prim2repopatchV2 $ quickhunk 1 "o" "bb" ob' :/\: oa' = merge (oa :\/: ob) a2' :/\: _ = merge (ob' :\/: a2) a2'' :/\: _ = merge (oa2 :\/: a2') -realNonduplicateTriples :: [(RealPatch Prim :> RealPatch Prim :> RealPatch Prim) wX wY] -realNonduplicateTriples = filter (notDuplicatestriple) realTriples +repov2NonduplicateTriples :: [(RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim) wX wY] +repov2NonduplicateTriples = filter (notDuplicatestriple) repov2Triples -realFLs :: [FL (RealPatch Prim) wX wY] -realFLs = [oa :>: invert oa :>: oa :>: invert oa :>: ps +>+ oa :>: invert oa :>: NilFL] - where oa = prim2real $ quickhunk 1 "o" "a" +repov2FLs :: [FL (RepoPatchV2 Prim) wX wY] +repov2FLs = [oa :>: invert oa :>: oa :>: invert oa :>: ps +>+ oa :>: invert oa :>: NilFL] + where oa = prim2repopatchV2 $ quickhunk 1 "o" "a" ps :/\: _ = merge (oa :>: invert oa :>: NilFL :\/: oa :>: invert oa :>: NilFL) -realCommutables :: [(RealPatch Prim :> RealPatch Prim) wX wY] -realCommutables = map unsafeUnseal2 commuteExamples++ - map mergeable2commutable realMergeables++ - [invert oa :> ob'] ++ map unsafeUnseal2 (concatMap getPairs realFLs) - where oa = prim2real $ quickhunk 1 "o" "a" - ob = prim2real $ quickhunk 1 "o" "b" +repov2Commutables :: [(RepoPatchV2 Prim :> RepoPatchV2 Prim) wX wY] +repov2Commutables = map unsafeUnseal2 commuteExamples++ + map mergeable2commutable repov2Mergeables++ + [invert oa :> ob'] ++ map unsafeUnseal2 (concatMap getPairs repov2FLs) + where oa = prim2repopatchV2 $ quickhunk 1 "o" "a" + ob = prim2repopatchV2 $ quickhunk 1 "o" "b" _ :/\: ob' = mergeFL (ob :\/: oa :>: invert oa :>: NilFL) -realMergeables :: [(RealPatch Prim :\/: RealPatch Prim) wX wY] -realMergeables = map (\ (x :\/: y) -> prim2real x :\/: prim2real y) mergeables - ++ realIglooMergeables - ++ realQuickcheckMergeables +repov2Mergeables :: [(RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY] +repov2Mergeables = map (\ (x :\/: y) -> prim2repopatchV2 x :\/: prim2repopatchV2 y) mergeables + ++ repov2IglooMergeables + ++ repov2QuickcheckMergeables ++ map unsafeUnseal2 mergeExamples - ++ catMaybes (map pair2m (concatMap getPairs realFLs)) + ++ catMaybes (map pair2m (concatMap getPairs repov2FLs)) ++ [(oa :\/: od), (oa :\/: a2'), (ob' :\/: od''), @@ -410,16 +410,16 @@ (ob'' :\/: og''), (ob'' :\/: oc''), (oc' :\/: od'')] - where oa = prim2real $ quickhunk 1 "o" "aa" - a2 = prim2real $ quickhunk 2 "a34" "2xx" - og = prim2real $ quickhunk 3 "4" "g" - ob = prim2real $ quickhunk 1 "o" "bb" - b2 = prim2real $ quickhunk 2 "b" "2" - oc = prim2real $ quickhunk 1 "o" "cc" - od = prim2real $ quickhunk 7 "x" "d" - oe = prim2real $ quickhunk 7 "x" "e" - pf = prim2real $ quickhunk 7 "x" "f" - od'' = prim2real $ quickhunk 8 "x" "d" + where oa = prim2repopatchV2 $ quickhunk 1 "o" "aa" + a2 = prim2repopatchV2 $ quickhunk 2 "a34" "2xx" + og = prim2repopatchV2 $ quickhunk 3 "4" "g" + ob = prim2repopatchV2 $ quickhunk 1 "o" "bb" + b2 = prim2repopatchV2 $ quickhunk 2 "b" "2" + oc = prim2repopatchV2 $ quickhunk 1 "o" "cc" + od = prim2repopatchV2 $ quickhunk 7 "x" "d" + oe = prim2repopatchV2 $ quickhunk 7 "x" "e" + pf = prim2repopatchV2 $ quickhunk 7 "x" "f" + od'' = prim2repopatchV2 $ quickhunk 8 "x" "d" ob' :>: b2' :>: NilFL :/\: _ = mergeFL (oa :\/: ob :>: b2 :>: NilFL) a2' :/\: _ = merge (ob' :\/: a2) ob'' :/\: _ = merge (a2 :\/: ob') @@ -431,13 +431,13 @@ oc''' :/\: _ = merge (ob' :\/: oc') oe' :/\: _ = merge (od :\/: oe) of' :/\: _ = merge (od :\/: pf) - pair2m :: Sealed2 (RealPatch Prim :> RealPatch Prim) - -> Maybe ((RealPatch Prim :\/: RealPatch Prim) wX wY) + pair2m :: Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim) + -> Maybe ((RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY) pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y) return $ unsafeCoerceP (xx :\/: y') -realIglooMergeables :: [(RealPatch Prim :\/: RealPatch Prim) wX wY] -realIglooMergeables = [(a :\/: b), +repov2IglooMergeables :: [(RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY] +repov2IglooMergeables = [(a :\/: b), (b :\/: c), (a :\/: c), (x :\/: a), @@ -447,18 +447,18 @@ (z' :\/: y'), (x' :\/: z'), (a :\/: a)] - where a = prim2real $ quickhunk 1 "1" "A" - b = prim2real $ quickhunk 2 "2" "B" - c = prim2real $ quickhunk 3 "3" "C" - x = prim2real $ quickhunk 1 "1BC" "xbc" - y = prim2real $ quickhunk 1 "A2C" "ayc" - z = prim2real $ quickhunk 1 "AB3" "abz" + where a = prim2repopatchV2 $ quickhunk 1 "1" "A" + b = prim2repopatchV2 $ quickhunk 2 "2" "B" + c = prim2repopatchV2 $ quickhunk 3 "3" "C" + x = prim2repopatchV2 $ quickhunk 1 "1BC" "xbc" + y = prim2repopatchV2 $ quickhunk 1 "A2C" "ayc" + z = prim2repopatchV2 $ quickhunk 1 "AB3" "abz" x' :/\: _ = merge (a :\/: x) y' :/\: _ = merge (b :\/: y) z' :/\: _ = merge (c :\/: z) -realQuickcheckMergeables :: [(RealPatch Prim :\/: RealPatch Prim) wX wY] -realQuickcheckMergeables = [-- invert k1 :\/: n1 +repov2QuickcheckMergeables :: [(RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY] +repov2QuickcheckMergeables = [-- invert k1 :\/: n1 --, invert k2 :\/: n2 hb :\/: k , b' :\/: b' @@ -467,25 +467,25 @@ , k' :\/: k' , k3 :\/: k3 ] ++ catMaybes (map pair2m pairs) - where hb = prim2real $ quickhunk 0 "" "hb" - k = prim2real $ quickhunk 0 "" "k" - n = prim2real $ quickhunk 0 "" "n" - b = prim2real $ quickhunk 1 "b" "" - d = prim2real $ quickhunk 2 "" "d" + where hb = prim2repopatchV2 $ quickhunk 0 "" "hb" + k = prim2repopatchV2 $ quickhunk 0 "" "k" + n = prim2repopatchV2 $ quickhunk 0 "" "n" + b = prim2repopatchV2 $ quickhunk 1 "b" "" + d = prim2repopatchV2 $ quickhunk 2 "" "d" d':/\:_ = merge (b :\/: d) --k1 :>: n1 :>: NilFL :/\: _ = mergeFL (hb :\/: k :>: n :>: NilFL) --k2 :>: n2 :>: NilFL :/\: _ = -- merge (hb :>: b :>: NilFL :\/: k :>: n :>: NilFL) k' :>: n' :>: NilFL :/\: _ :>: b' :>: _ = merge (hb :>: b :>: d' :>: NilFL :\/: k :>: n :>: NilFL) pairs = getPairs (hb :>: b :>: d' :>: k' :>: n' :>: NilFL) - pair2m :: Sealed2 (RealPatch Prim :> RealPatch Prim) - -> Maybe ((RealPatch Prim :\/: RealPatch Prim) wX wY) + pair2m :: Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim) + -> Maybe ((RepoPatchV2 Prim :\/: RepoPatchV2 Prim) wX wY) pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y) return $ unsafeCoerceP (xx :\/: y') - i = prim2real $ quickhunk 0 "" "i" - x = prim2real $ quickhunk 0 "" "x" - xi = prim2real $ quickhunk 0 "xi" "" + i = prim2repopatchV2 $ quickhunk 0 "" "i" + x = prim2repopatchV2 $ quickhunk 0 "" "x" + xi = prim2repopatchV2 $ quickhunk 0 "xi" "" d3 :/\: _ = merge (xi :\/: d) _ :/\: k3 = mergeFL (k :\/: i :>: x :>: xi :>: d3 :>: NilFL) diff --git a/harness/Darcs/Test/Patch/FileUUIDModel.hs b/harness/Darcs/Test/Patch/FileUUIDModel.hs new file mode 100644 --- /dev/null +++ b/harness/Darcs/Test/Patch/FileUUIDModel.hs @@ -0,0 +1,214 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-imports -fno-warn-orphans #-} +{-# LANGUAGE CPP, OverloadedStrings, MultiParamTypeClasses, StandaloneDeriving #-} + + +-- | Repository model +module Darcs.Test.Patch.FileUUIDModel + ( FileUUIDModel + , Object(..) + , repoApply + , emptyFile + , emptyDir + , nullRepo + , isEmpty + , root, repoObjects + , aFilename, aDirname + , aLine, aContent + , aFile, aDir + , aRepo + , anUUID + ) where + + +import Darcs.Test.Util.QuickCheck ( alpha, uniques, bSized ) +import Darcs.Test.Patch.RepoModel + +import Darcs.Patch.Apply( Apply(..), applyToState ) +import Darcs.Patch.ApplyMonad( ApplyMonad(..) ) +import Darcs.Patch.Prim.FileUUID.Core( UUID(..), Hunk(..), Prim(..), Object(..) ) +import Darcs.Patch.Prim.FileUUID.Apply( ObjectMap(..) ) +import Darcs.Patch.Witnesses.Sealed ( Sealed, seal ) +import Darcs.Patch.Witnesses.Show + +import Darcs.Util.Path +import Darcs.Util.Tree( Tree, TreeItem ) +import qualified Darcs.Util.Tree as T +import Darcs.Util.Hash( Hash(..) ) +import Darcs.Util.Tree.Hashed ( darcsUpdateHashes ) + +import Control.Applicative ( (<$>) ) +import Control.Arrow ( second ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.List ( intercalate, sort ) +import qualified Data.Map as M +import Test.QuickCheck + ( Arbitrary(..) + , Gen, choose, vectorOf, frequency, oneof ) + +#include "impossible.h" + + +---------------------------------------------------------------------- +-- * Model definition + +newtype FileUUIDModel wX = FileUUIDModel { repoMap :: ObjectMap Fail } + +---------------------------------------- +-- Instances + +instance Show (Object Fail) where + show (Directory l) = show l + show (Blob c _) = show c + +deriving instance Eq (Object Fail) + +instance Show (FileUUIDModel x) where + show = showModel + +instance Show1 FileUUIDModel where + showDict1 = ShowDictClass + +---------------------------------------------------------------------- +-- * Constructors + +objectMap :: (Monad m) => M.Map UUID (Object m) -> ObjectMap m +objectMap map = ObjectMap { getObject = get, putObject = put, listObjects = list } + where list = return $ M.keys map + put k o = return $ objectMap (M.insert k o map) + get k = return $ M.lookup k map + +emptyRepo :: FileUUIDModel wX +emptyRepo = FileUUIDModel (objectMap M.empty) + +emptyFile :: (Monad m) => Object m +emptyFile = Blob (return BS.empty) NoHash + +emptyDir :: Object m +emptyDir = Directory M.empty + +---------------------------------------------------------------------- +-- * Queries + +nullRepo :: FileUUIDModel wX -> Bool +nullRepo = null . repoObjects + +-- | @isEmpty file@ <=> file content is empty +-- @isEmpty dir@ <=> dir has no child +isEmpty :: Object Fail -> Bool +isEmpty (Directory d) = M.null d +isEmpty (Blob f _) = BS.null $ unFail f + +-- | The root directory of a repository. +root :: FileUUIDModel wX -> Object Fail +root (FileUUIDModel repo) = fromJust $ unFail $ getObject repo (UUID "ROOT") + +repoObjects :: FileUUIDModel wX -> [(UUID, Object Fail)] +repoObjects (FileUUIDModel repo) = [ (id, obj id) | + id <- unFail $ listObjects repo, not $ isEmpty $ obj id ] + where obj id = fromJust $ unFail $ getObject repo id + +---------------------------------------------------------------------- +-- * Comparing repositories + +---------------------------------------------------------------------- +-- * QuickCheck generators + +-- Testing code assumes that aFilename and aDirname generators +-- will always be able to generate a unique name given a list of +-- existing names. This should be OK as long as the number of possible +-- file/dirnames is much bigger than the number of files/dirs per repository. + +-- 'Arbitrary' 'FileUUIDModel' instance is based on the 'aSmallRepo' generator. + + +-- | Files are distinguish by ending their names with ".txt". +aFilename :: Gen BS.ByteString +aFilename = do len <- choose (1,maxLength) + name <- vectorOf len alpha + return $ BC.pack $ name ++ ".txt" + where + maxLength = 3 + +aDirname :: Gen BS.ByteString +aDirname = do len <- choose (1,maxLength) + BC.pack <$> vectorOf len alpha + where + maxLength = 3 + +aWord :: Gen BS.ByteString +aWord = do c <- alpha + return $ BC.pack[c] + +aLine :: Gen BS.ByteString +aLine = do wordsNo <- choose (1,2) + ws <- vectorOf wordsNo aWord + return $ BC.unwords ws + +aContent :: Gen BS.ByteString +aContent = bSized 0 0.5 80 $ \k -> + do n <- choose (0,k) + BC.intercalate "\n" <$> vectorOf n aLine + +aFile :: (Monad m) => Gen (Object m) +aFile = aContent >>= \c -> return $ Blob (return c) NoHash + +aDir :: (Monad m) => [UUID] -> [UUID] -> Gen [(UUID, Object m)] +aDir [] _ = return [] +aDir (dirid:dirids) fileids = + do dirsplit <- choose (1, length dirids) + filesplit <- choose (1, length fileids) + let ids = take filesplit fileids + rem = drop filesplit fileids + files <- vectorOf filesplit aFile + names <- vectorOf filesplit aFilename + dirnames <- vectorOf dirsplit aDirname + dirs <- subdirs (take dirsplit dirids) + (drop dirsplit dirids) + (drop filesplit fileids) + return $ (dirid, Directory $ M.fromList $ names `zip` ids ++ dirnames `zip` dirids) + : (fileids `zip` files) ++ dirs + where subdirs [] _ _ = return [] + subdirs tomake dirs files = do + dirsplit <- choose (1, length dirs) + filesplit <- choose (1, length files) + dir <- aDir (head tomake : take dirsplit dirs) (take filesplit files) + rem <- subdirs (tail tomake) (drop dirsplit dirs) (drop filesplit files) + return $ dir ++ rem + + +anUUID :: Gen UUID +anUUID = UUID . BC.pack <$> vectorOf 32 (oneof $ map return "0123456789") + +-- | @aRepo filesNo dirsNo@ produces repositories with *at most* +-- @filesNo@ files and @dirsNo@ directories. +-- The structure of the repository is aleatory. +aRepo :: Int -- ^ Maximum number of files + -> Int -- ^ Maximum number of directories + -> Gen (FileUUIDModel wX) +aRepo maxFiles maxDirs + = do let minFiles = if maxDirs == 0 && maxFiles > 0 then 1 else 0 + filesNo <- choose (minFiles,maxFiles) + let minDirs = if filesNo == 0 && maxDirs > 0 then 1 else 0 + dirsNo <- choose (minDirs,maxDirs) + dirids <- (UUID "ROOT":) <$> uniques dirsNo anUUID + fileids <- uniques filesNo anUUID + objectmap <- aDir dirids fileids + return $ FileUUIDModel $ objectMap $ M.fromList objectmap + +-- | Generate small repositories. +-- Small repositories help generating (potentially) conflicting patches. +instance RepoModel FileUUIDModel where + type RepoState FileUUIDModel = ObjectMap + aSmallRepo = do filesNo <- frequency [(3, return 1), (1, return 2)] + dirsNo <- frequency [(3, return 1), (1, return 0)] + aRepo filesNo dirsNo + repoApply (FileUUIDModel state) patch = FileUUIDModel <$> applyToState patch state + showModel model = "FileUUIDModel{\n" ++ unlines (map entry $ repoObjects model) ++ "}" + where entry (id, obj) = show id ++ " -> " ++ show obj + eqModel r1 r2 = repoObjects r1 == repoObjects r2 + +instance Arbitrary (Sealed FileUUIDModel) where + arbitrary = seal <$> aSmallRepo diff --git a/harness/Darcs/Test/Patch/Properties/Check.hs b/harness/Darcs/Test/Patch/Properties/Check.hs --- a/harness/Darcs/Test/Patch/Properties/Check.hs +++ b/harness/Darcs/Test/Patch/Properties/Check.hs @@ -20,7 +20,7 @@ effect ) import Darcs.Patch.Invert ( Invert ) import Darcs.Patch.V1 () -import qualified Darcs.Patch.V1.Core as V1 ( Patch(..) ) +import qualified Darcs.Patch.V1.Core as V1 ( RepoPatchV1(..) ) import Darcs.Patch.V1.Core ( isMerger ) import Darcs.Patch.Prim.V1 () import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) ) @@ -39,7 +39,7 @@ checkAPatch p = doCheck $ do _ <- checkPatch p checkPatch $ invert p -instance Check (V1.Patch Prim) where +instance Check (V1.RepoPatchV1 Prim) where checkPatch p | isMerger p = do checkPatch $ effect p checkPatch (V1.Merger _ _ _ _) = impossible diff --git a/harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs b/harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs --- a/harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs +++ b/harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs @@ -10,7 +10,7 @@ import Darcs.Test.Patch.RepoModel( RepoModel, RepoState ) import Darcs.Test.Patch.WithState( WithStartState ) -import qualified Darcs.Test.Patch.Properties.Real as W ( propConsistentTreeFlattenings ) +import qualified Darcs.Test.Patch.Properties.RepoPatchV2 as W ( propConsistentTreeFlattenings ) import Darcs.Test.Patch.WSub import Darcs.Test.Util.TestResult @@ -24,7 +24,7 @@ import Darcs.Patch.Merge ( Merge ) import Darcs.Patch ( Patchy ) import Darcs.Util.Printer ( Doc, redText, ($$) ) -import qualified Storage.Hashed.Tree as HST ( Tree ) +import qualified Darcs.Util.Tree as T ( Tree ) permutivity :: (Patchy wp, ShowPatchBasic wp, MyEq wp, WSub wp p) @@ -78,7 +78,7 @@ -> (Prim :> Prim :> Prim) wA wB -> TestResult coalesceCommute f = W.coalesceCommute (fmap toW . f . fromW) . toW -consistentTreeFlattenings :: (RepoState model ~ HST.Tree, RepoModel model) +consistentTreeFlattenings :: (RepoState model ~ T.Tree, RepoModel model) => Sealed (WithStartState model (Tree Prim)) -> TestResult consistentTreeFlattenings = (\x -> if W.propConsistentTreeFlattenings x then succeeded diff --git a/harness/Darcs/Test/Patch/Properties/Real.hs b/harness/Darcs/Test/Patch/Properties/Real.hs deleted file mode 100644 --- a/harness/Darcs/Test/Patch/Properties/Real.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE CPP #-} -module Darcs.Test.Patch.Properties.Real - ( propConsistentTreeFlattenings ) where - -import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenTree, G2(..), mapTree ) -import Darcs.Test.Patch.WithState -import Darcs.Test.Patch.RepoModel ( RepoModel, repoApply, showModel, eqModel, RepoState - , Fail, maybeFail ) -import qualified Storage.Hashed.Tree as HST ( Tree ) - -import Darcs.Patch.Witnesses.Sealed( Sealed(..) ) -import Darcs.Patch.V2.Real( prim2real ) -import Darcs.Patch.Prim.V1 ( Prim ) - -#include "impossible.h" - -assertEqualFst :: (RepoModel a, Show b, Show c) => (Fail (a x), b) -> (Fail (a x), c) -> Bool -assertEqualFst (x,bx) (y,by) - | Just x' <- maybeFail x, Just y' <- maybeFail y, x' `eqModel` y' = True - | Nothing <- maybeFail x, Nothing <- maybeFail y = True - | otherwise = error ("Not really equal:\n" ++ showx ++ "\nand\n" ++ showy - ++ "\ncoming from\n" ++ show bx ++ "\nand\n" ++ show by) - where showx | Just x' <- maybeFail x = showModel x' - | otherwise = "Nothing" - showy | Just y' <- maybeFail y = showModel y' - | otherwise = "Nothing" - -propConsistentTreeFlattenings :: (RepoState model ~ HST.Tree, RepoModel model) - => Sealed (WithStartState model (Tree Prim)) -> Bool -propConsistentTreeFlattenings (Sealed (WithStartState start t)) - = fromJust $ - do Sealed (G2 flat) <- return $ flattenTree $ mapTree prim2real t - rms <- return $ map (start `repoApply`) flat - return $ and $ zipWith assertEqualFst (zip rms flat) (tail $ zip rms flat) - diff --git a/harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs b/harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs new file mode 100644 --- /dev/null +++ b/harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE CPP #-} +module Darcs.Test.Patch.Properties.RepoPatchV2 + ( propConsistentTreeFlattenings ) where + +import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenTree, G2(..), mapTree ) +import Darcs.Test.Patch.WithState +import Darcs.Test.Patch.RepoModel ( RepoModel, repoApply, showModel, eqModel, RepoState + , Fail, maybeFail ) +import qualified Darcs.Util.Tree as T ( Tree ) + +import Darcs.Patch.Witnesses.Sealed( Sealed(..) ) +import Darcs.Patch.V2.RepoPatch( prim2repopatchV2 ) +import Darcs.Patch.Prim.V1 ( Prim ) + +#include "impossible.h" + +assertEqualFst :: (RepoModel a, Show b, Show c) => (Fail (a x), b) -> (Fail (a x), c) -> Bool +assertEqualFst (x,bx) (y,by) + | Just x' <- maybeFail x, Just y' <- maybeFail y, x' `eqModel` y' = True + | Nothing <- maybeFail x, Nothing <- maybeFail y = True + | otherwise = error ("Not really equal:\n" ++ showx ++ "\nand\n" ++ showy + ++ "\ncoming from\n" ++ show bx ++ "\nand\n" ++ show by) + where showx | Just x' <- maybeFail x = showModel x' + | otherwise = "Nothing" + showy | Just y' <- maybeFail y = showModel y' + | otherwise = "Nothing" + +propConsistentTreeFlattenings :: (RepoState model ~ T.Tree, RepoModel model) + => Sealed (WithStartState model (Tree Prim)) -> Bool +propConsistentTreeFlattenings (Sealed (WithStartState start t)) + = fromJust $ + do Sealed (G2 flat) <- return $ flattenTree $ mapTree prim2repopatchV2 t + rms <- return $ map (start `repoApply`) flat + return $ and $ zipWith assertEqualFst (zip rms flat) (tail $ zip rms flat) + diff --git a/harness/Darcs/Test/Patch/Properties/V1Set1.hs b/harness/Darcs/Test/Patch/Properties/V1Set1.hs --- a/harness/Darcs/Test/Patch/Properties/V1Set1.hs +++ b/harness/Darcs/Test/Patch/Properties/V1Set1.hs @@ -14,7 +14,7 @@ import Darcs.Patch.Merge ( Merge ) import Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.Show ( ShowPatchBasic ) -import qualified Darcs.Patch.V1 as V1 ( Patch ) +import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 ) import Darcs.Test.Patch.Properties.Check ( checkAPatch, Check ) import Darcs.Util.Printer ( renderPS, RenderMode(..) ) import Darcs.Patch.Witnesses.Eq @@ -27,15 +27,13 @@ import Darcs.Util.Printer ( text ) -type Patch = V1.Patch Prim +type Patch = V1.RepoPatchV1 Prim quickmerge :: (Patchy p, Merge p) => (p :\/: p ) wX wY -> p wY wZ quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of _ :/\: p1' -> unsafeCoercePEnd p1' -instance Show2 p => Show ((p :< p) wX wY) where - show (x :< y) = show2 x ++ " :< " ++ show2 y instance MyEq p => Eq ((p :/\: p) wX wY) where (x :/\: y) == (x' :/\: y') = isIsEq (x =\/= x') && isIsEq (y =\/= y') @@ -74,8 +72,8 @@ _ :/\: p2' -> case merge (p1:\/:p2) of _ :/\: p1' -> - case commute (p1:>p2') of - Just (_:>p1'b) -> + case commute (p1 :> p2') of + Just (_ :> p1'b) -> if not $ p1'b `eqFLUnsafe` p1' then failed $ text $ "Merge swapping problem with...\np1 "++ show p1++"merged with\np2 "++ @@ -102,28 +100,28 @@ where p1_ = mapFL_FL fromPrim $ concatFL $ mapFL_FL (canonize D.MyersDiff) $ sortCoalesceFL $ effect p1 p1_p = mapFL_FL fromPrim $ concatFL $ mapFL_FL (canonize D.PatienceDiff) $ sortCoalesceFL $ effect p1 -checkCommute :: ((FL Patch:< FL Patch) wX wY, (FL Patch:< FL Patch) wX wY) -> TestResult -checkCommute (p1:p1) of - Just (p1a:>p2a) -> - if (p2a:< p1a) == (p2':< p1') +checkCommute :: ((FL Patch :> FL Patch) wX wY, (FL Patch :> FL Patch) wX wY) -> TestResult +checkCommute (p2 :> p1,p1' :> p2') = + case commute (p2 :> p1) of + Just (p1a :> p2a) -> + if (p1a :> p2a) == (p1' :> p2') then succeeded else failed $ text $ "Commute gave wrong value!\n"++show p1++"\n"++show p2 ++"should be\n"++show p2'++"\n"++show p1' ++"but is\n"++show p2a++"\n"++show p1a Nothing -> failed $ text $ "Commute failed!\n"++show p1++"\n"++show p2 <&&> - case commute (p1':>p2') of - Just (p2a:>p1a) -> - if (p1a:< p2a) == (p1:< p2) + case commute (p1' :> p2') of + Just (p2a :> p1a) -> + if (p2a :> p1a) == (p2 :> p1) then succeeded else failed $ text $ "Commute gave wrong value!\n"++show p2a++"\n"++show p1a ++"should have been\n"++show p2'++"\n"++show p1' Nothing -> failed $ text $ "Commute failed!\n"++show p2'++"\n"++show p1' -checkCantCommute :: (FL Patch:< FL Patch) wX wY -> TestResult -checkCantCommute (p1:p1) of +checkCantCommute :: (FL Patch :> FL Patch) wX wY -> TestResult +checkCantCommute (p2 :> p1) = + case commute (p2 :> p1) of Nothing -> succeeded _ -> failed $ text $ show p1 ++ "\n\n" ++ show p2 ++ "\nArgh, these guys shouldn't commute!\n" diff --git a/harness/Darcs/Test/Patch/Properties/V1Set2.hs b/harness/Darcs/Test/Patch/Properties/V1Set2.hs --- a/harness/Darcs/Test/Patch/Properties/V1Set2.hs +++ b/harness/Darcs/Test/Patch/Properties/V1Set2.hs @@ -49,7 +49,7 @@ fromPrim, showPatch ) import Darcs.Patch.Commute ( Commute ) import Darcs.Patch.Invert ( Invert ) -import qualified Darcs.Patch.V1 as V1 ( Patch ) +import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 ) import Darcs.Patch.V1.Commute ( unravel, merger ) import Darcs.Patch.Prim.V1 () import Darcs.Patch.Prim.V1.Core ( Prim(..) ) @@ -63,7 +63,7 @@ #include "impossible.h" -type Patch = V1.Patch Prim +type Patch = V1.RepoPatchV1 Prim -- | Groups a set of tests by giving them the same prefix in their description. @@ -241,14 +241,14 @@ where (names, cs) = unzip subcommutes prop_subcommute c (Sealed2 (p1:>p2)) = does c p1 p2 ==> - case runWrappedCommuteFunction c (p2:< p1) of - Succeeded (p1': - case runWrappedCommuteFunction c (invert p2:< p1') of - Succeeded (p1'': isIsEq (p1'' =/\= p1) && - case runWrappedCommuteFunction c (invert p1:< invert p2) of - Succeeded (ip2':< ip1') -> - case runWrappedCommuteFunction c (p2':< invert p1) of - Succeeded (ip1o':< p2o) -> isJust ((do + case runWrappedCommuteFunction c (p1 :> p2) of + Succeeded (p2' :> p1') -> + case runWrappedCommuteFunction c (p1' :> invert p2) of + Succeeded (ip2x' :> p1'') -> isIsEq (p1'' =/\= p1) && + case runWrappedCommuteFunction c (invert p2 :> invert p1 ) of + Succeeded (ip1' :> ip2') -> + case runWrappedCommuteFunction c (invert p1 :> p2') of + Succeeded (p2o :> ip1o') -> isJust ((do IsEq <- return $ invert ip1' =/\= p1' IsEq <- return $ invert ip2' =/\= p2' IsEq <- return $ ip1o' =/\= ip1' @@ -267,14 +267,14 @@ (names, cs) = unzip . filter ((/= "speedyCommute") . fst) $ subcommutes prop_subcommute c (Sealed2 (p1 :> p2)) = nontrivial c p1 p2 ==> - case runWrappedCommuteFunction c (p2:< p1) of - Succeeded (p1': - case runWrappedCommuteFunction c (invert p2:< p1') of - Succeeded (p1'': isIsEq (p1'' =/\= p1) && - case runWrappedCommuteFunction c (invert p1:< invert p2) of - Succeeded (ip2':< ip1') -> - case runWrappedCommuteFunction c (p2':< invert p1) of - Succeeded (ip1o':< p2o) -> isJust ((do + case runWrappedCommuteFunction c (p1 :> p2) of + Succeeded (p2' :> p1') -> + case runWrappedCommuteFunction c (p1' :> invert p2) of + Succeeded (ip2x' :> p1'') -> isIsEq (p1'' =/\= p1) && + case runWrappedCommuteFunction c (invert p2 :> invert p1) of + Succeeded (ip1' :> ip2') -> + case runWrappedCommuteFunction c (invert p1 :> p2') of + Succeeded (p2o :> ip1o') -> isJust ((do IsEq <- return $ invert ip1' =/\= p1' IsEq <- return $ invert ip2' =/\= p2' IsEq <- return $ ip1o' =/\= ip1' @@ -293,24 +293,24 @@ (names, cs) = unzip . filter ((/= "speedyCommute") . fst) $ subcommutes prop c (Sealed2 (p1 :> p2)) = doesFail c p1 p2 ==> - case runWrappedCommuteFunction c (invert p1 :< invert p2) of + case runWrappedCommuteFunction c (invert p2 :> invert p1 ) of Failed -> True _ -> False doesFail :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool doesFail c p1 p2 = - fails (runWrappedCommuteFunction c (p2:: p2 :>: NilFL) + fails (runWrappedCommuteFunction c (p1 :> p2)) && checkAPatch (p1 :>: p2 :>: NilFL) where fails Failed = True fails _ = False does :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool does c p1 p2 = - succeeds (runWrappedCommuteFunction c (p2:: p2 :>: NilFL) + succeeds (runWrappedCommuteFunction c (p1 :> p2)) && checkAPatch (p1 :>: p2 :>: NilFL) where succeeds (Succeeded _) = True succeeds _ = False nontrivial :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool nontrivial c p1 p2 = - succeeds (runWrappedCommuteFunction c (p2:: p2 :>: NilFL) - where succeeds (Succeeded (p1' :< p2')) = not (p1' `unsafeCompare` p1 && p2' `unsafeCompare` p2) + succeeds (runWrappedCommuteFunction c (p1 :> p2)) && checkAPatch (p1 :>: p2 :>: NilFL) + where succeeds (Succeeded (p2' :> p1' )) = not (p1' `unsafeCompare` p1 && p2' `unsafeCompare` p2) succeeds _ = False diff --git a/harness/Darcs/Test/Patch/Rebase.hs b/harness/Darcs/Test/Patch/Rebase.hs --- a/harness/Darcs/Test/Patch/Rebase.hs +++ b/harness/Darcs/Test/Patch/Rebase.hs @@ -9,7 +9,7 @@ import Darcs.Patch import Darcs.Patch.Conflict -import Darcs.Patch.Rebase +import Darcs.Patch.Rebase.Fixup import Darcs.Patch.Rebase.Viewing import Darcs.Patch.Type import Darcs.Patch.Witnesses.Ordered @@ -17,7 +17,7 @@ import Darcs.Test.Patch.Arbitrary.Generic -testSuite :: forall p . (RepoPatch p, ArbitraryPrim (PrimOf p), Show2 (PrimOf p)) => PatchType p -> [Test] +testSuite :: forall rt p . (RepoPatch p, ArbitraryPrim (PrimOf p), Show2 (PrimOf p)) => PatchType rt p -> [Test] testSuite pt = if hasPrimConstruct (undefined :: PrimOf p WX WX) then @@ -29,7 +29,7 @@ data WX -duplicateConflictedEffect :: forall p . (RepoPatch p, Show2 (PrimOf p)) => PatchType p -> Test +duplicateConflictedEffect :: forall rt p . (RepoPatch p, Show2 (PrimOf p)) => PatchType rt p -> Test duplicateConflictedEffect _ = testCase "duplicate in rebase fixup has a conflicted effect" $ unless (all (/= Okay) cStatuses) $ diff --git a/harness/Darcs/Test/Patch/Selection.hs b/harness/Darcs/Test/Patch/Selection.hs new file mode 100644 --- /dev/null +++ b/harness/Darcs/Test/Patch/Selection.hs @@ -0,0 +1,60 @@ +-- Copyright (C) 2016 G. Hoffmann + +module Darcs.Test.Patch.Selection ( testSuite ) where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit ( testCase ) + +import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..) ) +import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) + +import Darcs.Patch.Prim.V1 ( Prim ) +import Darcs.Patch.V2 ( RepoPatchV2 ) +import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) + +import Darcs.UI.SelectChanges + ( PatchSelectionOptions(..) + , selectionContext + , runSelection + , WhichChanges(..) + ) +import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd(..) ) +import Darcs.Patch.Info ( rawPatchInfo ) +import Darcs.UI.Options.All + ( Verbosity(..), Summary(..) + , WithContext(..), SelectDeps(..), MatchFlag(..) ) + +-- A test module for interactive patch selection. + +type Patch = RepoPatchV2 Prim + +testSuite :: Test +testSuite = testGroup "Darcs.Patch.Selection" $ + [ dontReadContents whch | whch <- [Last, LastReversed, First, FirstReversed] ] + +dontReadContents :: WhichChanges -> Test +dontReadContents whch = + testCase ("Matching on patch metadata does not open patch contents: " ++ show whch) + $ do + let -- here is an FL of patches whose metadata can be read but whose contents + -- should NEVER be read, otherwise something really bad would happen. + launchNuclearMissilesPatches = unsafeCoerceP $ lnmPatches [ "P " ++ show i | i <- [1..5::Int] ] + lnmPatches [] = NilFL + lnmPatches (n:names) = buildPatch n :>: lnmPatches names + buildPatch :: String -> PatchInfoAnd ('RepoType 'NoRebase) Patch wX wY + buildPatch name = PIAP (rawPatchInfo "1999" name "harness" [] False) (error "Patch content read!") + pso = PatchSelectionOptions + { verbosity = Quiet + , matchFlags = [OnePatch "."] -- match on every patch + , interactive = False + , selectDeps = AutoDeps + , summary = NoSummary + , withContext = NoContext + } + context = selectionContext whch "select" pso Nothing Nothing + (unselected :> selected) <- runSelection launchNuclearMissilesPatches context + -- Forcing selection to happen (at least to the point of knowing whether unselected + -- and unselected are NilFL or not) should not evaluate the `undefined` inside of our + -- patches, ie, we don't need to read too much. + unselected `seq` selected `seq` return () + diff --git a/harness/Darcs/Test/Patch/V1Model.hs b/harness/Darcs/Test/Patch/V1Model.hs --- a/harness/Darcs/Test/Patch/V1Model.hs +++ b/harness/Darcs/Test/Patch/V1Model.hs @@ -3,8 +3,7 @@ -- | Repository model module Darcs.Test.Patch.V1Model - ( module Storage.Hashed.AnchoredPath - , V1Model, repoTree + ( V1Model, repoTree , RepoItem, File, Dir, Content , makeRepo, emptyRepo , makeFile, emptyFile @@ -25,6 +24,9 @@ ) where +import Prelude () +import Darcs.Prelude + import Darcs.Test.Util.QuickCheck ( alpha, uniques, bSized ) import Darcs.Test.Patch.RepoModel @@ -32,12 +34,11 @@ import Darcs.Patch.Witnesses.Sealed ( Sealed, seal ) import Darcs.Patch.Witnesses.Show -import Storage.Hashed.AnchoredPath -import Storage.Hashed.Tree( Tree, TreeItem ) -import Storage.Hashed.Darcs ( darcsUpdateHashes ) -import qualified Storage.Hashed.Tree as T +import Darcs.Util.Path +import Darcs.Util.Tree( Tree, TreeItem ) +import Darcs.Util.Tree.Hashed ( darcsUpdateHashes ) +import qualified Darcs.Util.Tree as T -import Control.Applicative ( (<$>) ) import Control.Arrow ( second ) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC diff --git a/harness/Darcs/Test/Patch/V3Model.hs b/harness/Darcs/Test/Patch/V3Model.hs deleted file mode 100644 --- a/harness/Darcs/Test/Patch/V3Model.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-imports -fno-warn-orphans #-} -{-# LANGUAGE CPP, OverloadedStrings, MultiParamTypeClasses, StandaloneDeriving #-} - - --- | Repository model -module Darcs.Test.Patch.V3Model - ( module Storage.Hashed.AnchoredPath - , V3Model - , Object(..) - , repoApply - , emptyFile - , emptyDir - , nullRepo - , isEmpty - , root, repoObjects - , aFilename, aDirname - , aLine, aContent - , aFile, aDir - , aRepo - , anUUID - ) where - - -import Darcs.Test.Util.QuickCheck ( alpha, uniques, bSized ) -import Darcs.Test.Patch.RepoModel - -import Darcs.Patch.Apply( Apply(..), applyToState ) -import Darcs.Patch.ApplyMonad( ApplyMonad(..) ) -import Darcs.Patch.Prim.V3.Core( UUID(..), Hunk(..), Prim(..), Object(..) ) -import Darcs.Patch.Prim.V3.Apply( ObjectMap(..) ) -import Darcs.Patch.Witnesses.Sealed ( Sealed, seal ) -import Darcs.Patch.Witnesses.Show - -import Storage.Hashed.AnchoredPath -import Storage.Hashed.Tree( Tree, TreeItem ) -import Storage.Hashed.Darcs ( darcsUpdateHashes ) -import Storage.Hashed.Hash( Hash(..) ) -import qualified Storage.Hashed.Tree as T - -import Control.Applicative ( (<$>) ) -import Control.Arrow ( second ) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC -import Data.List ( intercalate, sort ) -import qualified Data.Map as M -import Test.QuickCheck - ( Arbitrary(..) - , Gen, choose, vectorOf, frequency, oneof ) - -#include "impossible.h" - - ----------------------------------------------------------------------- --- * Model definition - -newtype V3Model wX = V3Model { repoMap :: ObjectMap Fail } - ----------------------------------------- --- Instances - -instance Show (Object Fail) where - show (Directory l) = show l - show (Blob c _) = show c - -deriving instance Eq (Object Fail) - -instance Show (V3Model x) where - show = showModel - -instance Show1 V3Model where - showDict1 = ShowDictClass - ----------------------------------------------------------------------- --- * Constructors - -objectMap :: (Monad m) => M.Map UUID (Object m) -> ObjectMap m -objectMap map = ObjectMap { getObject = get, putObject = put, listObjects = list } - where list = return $ M.keys map - put k o = return $ objectMap (M.insert k o map) - get k = return $ M.lookup k map - -emptyRepo :: V3Model wX -emptyRepo = V3Model (objectMap M.empty) - -emptyFile :: (Monad m) => Object m -emptyFile = Blob (return BS.empty) NoHash - -emptyDir :: Object m -emptyDir = Directory M.empty - ----------------------------------------------------------------------- --- * Queries - -nullRepo :: V3Model wX -> Bool -nullRepo = null . repoObjects - --- | @isEmpty file@ <=> file content is empty --- @isEmpty dir@ <=> dir has no child -isEmpty :: Object Fail -> Bool -isEmpty (Directory d) = M.null d -isEmpty (Blob f _) = BS.null $ unFail f - --- | The root directory of a repository. -root :: V3Model wX -> Object Fail -root (V3Model repo) = fromJust $ unFail $ getObject repo (UUID "ROOT") - -repoObjects :: V3Model wX -> [(UUID, Object Fail)] -repoObjects (V3Model repo) = [ (id, obj id) | - id <- unFail $ listObjects repo, not $ isEmpty $ obj id ] - where obj id = fromJust $ unFail $ getObject repo id - ----------------------------------------------------------------------- --- * Comparing repositories - ----------------------------------------------------------------------- --- * QuickCheck generators - --- Testing code assumes that aFilename and aDirname generators --- will always be able to generate a unique name given a list of --- existing names. This should be OK as long as the number of possible --- file/dirnames is much bigger than the number of files/dirs per repository. - --- 'Arbitrary' 'V3Model' instance is based on the 'aSmallRepo' generator. - - --- | Files are distinguish by ending their names with ".txt". -aFilename :: Gen BS.ByteString -aFilename = do len <- choose (1,maxLength) - name <- vectorOf len alpha - return $ BC.pack $ name ++ ".txt" - where - maxLength = 3 - -aDirname :: Gen BS.ByteString -aDirname = do len <- choose (1,maxLength) - BC.pack <$> vectorOf len alpha - where - maxLength = 3 - -aWord :: Gen BS.ByteString -aWord = do c <- alpha - return $ BC.pack[c] - -aLine :: Gen BS.ByteString -aLine = do wordsNo <- choose (1,2) - ws <- vectorOf wordsNo aWord - return $ BC.unwords ws - -aContent :: Gen BS.ByteString -aContent = bSized 0 0.5 80 $ \k -> - do n <- choose (0,k) - BC.intercalate "\n" <$> vectorOf n aLine - -aFile :: (Monad m) => Gen (Object m) -aFile = aContent >>= \c -> return $ Blob (return c) NoHash - -aDir :: (Monad m) => [UUID] -> [UUID] -> Gen [(UUID, Object m)] -aDir [] _ = return [] -aDir (dirid:dirids) fileids = - do dirsplit <- choose (1, length dirids) - filesplit <- choose (1, length fileids) - let ids = take filesplit fileids - rem = drop filesplit fileids - files <- vectorOf filesplit aFile - names <- vectorOf filesplit aFilename - dirnames <- vectorOf dirsplit aDirname - dirs <- subdirs (take dirsplit dirids) - (drop dirsplit dirids) - (drop filesplit fileids) - return $ (dirid, Directory $ M.fromList $ names `zip` ids ++ dirnames `zip` dirids) - : (fileids `zip` files) ++ dirs - where subdirs [] _ _ = return [] - subdirs tomake dirs files = do - dirsplit <- choose (1, length dirs) - filesplit <- choose (1, length files) - dir <- aDir (head tomake : take dirsplit dirs) (take filesplit files) - rem <- subdirs (tail tomake) (drop dirsplit dirs) (drop filesplit files) - return $ dir ++ rem - - -anUUID :: Gen UUID -anUUID = UUID . BC.pack <$> vectorOf 32 (oneof $ map return "0123456789") - --- | @aRepo filesNo dirsNo@ produces repositories with *at most* --- @filesNo@ files and @dirsNo@ directories. --- The structure of the repository is aleatory. -aRepo :: Int -- ^ Maximum number of files - -> Int -- ^ Maximum number of directories - -> Gen (V3Model wX) -aRepo maxFiles maxDirs - = do let minFiles = if maxDirs == 0 && maxFiles > 0 then 1 else 0 - filesNo <- choose (minFiles,maxFiles) - let minDirs = if filesNo == 0 && maxDirs > 0 then 1 else 0 - dirsNo <- choose (minDirs,maxDirs) - dirids <- (UUID "ROOT":) <$> uniques dirsNo anUUID - fileids <- uniques filesNo anUUID - objectmap <- aDir dirids fileids - return $ V3Model $ objectMap $ M.fromList objectmap - --- | Generate small repositories. --- Small repositories help generating (potentially) conflicting patches. -instance RepoModel V3Model where - type RepoState V3Model = ObjectMap - aSmallRepo = do filesNo <- frequency [(3, return 1), (1, return 2)] - dirsNo <- frequency [(3, return 1), (1, return 0)] - aRepo filesNo dirsNo - repoApply (V3Model state) patch = V3Model <$> applyToState patch state - showModel model = "V3Model{\n" ++ unlines (map entry $ repoObjects model) ++ "}" - where entry (id, obj) = show id ++ " -> " ++ show obj - eqModel r1 r2 = repoObjects r1 == repoObjects r2 - -instance Arbitrary (Sealed V3Model) where - arbitrary = seal <$> aSmallRepo diff --git a/harness/Darcs/Test/Patch/WSub.hs b/harness/Darcs/Test/Patch/WSub.hs --- a/harness/Darcs/Test/Patch/WSub.hs +++ b/harness/Darcs/Test/Patch/WSub.hs @@ -31,7 +31,7 @@ import Darcs.Patch.Merge ( Merge ) import Darcs.Patch.Prim.V1 ( Prim ) -import Darcs.Patch.V2 ( RealPatch ) +import Darcs.Patch.V2 ( RepoPatchV2 ) import Darcs.Patch.Patchy ( Commute, Invert(..) ) @@ -81,7 +81,7 @@ toW NilFL = unsafeCoerceP W.NilFL toW (x :>: xs) = unsafeCoercePEnd (toW x) W.:>: unsafeCoercePStart (toW xs) -instance WSub prim prim => WSub (RealPatch prim) (RealPatch prim) where +instance WSub prim prim => WSub (RepoPatchV2 prim) (RepoPatchV2 prim) where fromW = id toW = id @@ -126,10 +126,10 @@ commute :: (WSub wp p, Commute wp) => (p :> p) wX wY -> Maybe ((p :> p) wX wY) commute = fmap fromW . W.commute . toW -getPairs :: FL (RealPatch Prim) wX wY -> [Sealed2 (RealPatch Prim :> RealPatch Prim)] +getPairs :: FL (RepoPatchV2 Prim) wX wY -> [Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim)] getPairs = map (mapSeal2 fromW) . W.getPairs . toW -getTriples :: FL (RealPatch Prim) wX wY -> [Sealed2 (RealPatch Prim :> RealPatch Prim :> RealPatch Prim)] +getTriples :: FL (RepoPatchV2 Prim) wX wY -> [Sealed2 (RepoPatchV2 Prim :> RepoPatchV2 Prim :> RepoPatchV2 Prim)] getTriples = map (mapSeal2 fromW) . W.getTriples . toW coalesce :: (Prim :> Prim) wX wY -> Maybe (FL Prim wX wY) diff --git a/harness/Darcs/Test/Util/QuickCheck.hs b/harness/Darcs/Test/Util/QuickCheck.hs --- a/harness/Darcs/Test/Util/QuickCheck.hs +++ b/harness/Darcs/Test/Util/QuickCheck.hs @@ -11,7 +11,9 @@ where -import Control.Applicative +import Prelude () +import Darcs.Prelude + import Test.QuickCheck.Gen diff --git a/harness/Storage/Hashed/Test.hs b/harness/Storage/Hashed/Test.hs new file mode 100644 --- /dev/null +++ b/harness/Storage/Hashed/Test.hs @@ -0,0 +1,542 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Storage.Hashed.Test( tests ) where + +import Prelude hiding ( filter, readFile, writeFile, lookup, (<$>) ) +import qualified Prelude +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.ByteString.Char8 as BS +import System.Directory( doesFileExist, removeFile, doesDirectoryExist + , createDirectory, removeDirectoryRecursive + , setCurrentDirectory ) +import System.FilePath( () ) +import Control.Monad.Identity +import Control.Monad.Trans( lift ) +import Control.Applicative( (<$>) ) +import Control.Exception ( catch, IOException ) +import Codec.Archive.Zip( extractFilesFromArchive, toArchive ) + +import Data.Maybe +import Data.Word +import Data.List( sort, intercalate, intersperse ) + +import Darcs.Util.Path hiding ( setCurrentDirectory ) +import Darcs.Util.Tree hiding ( lookup ) +import Darcs.Util.Index +import Darcs.Util.Tree.Hashed +import Darcs.Util.Hash +import Darcs.Util.Tree.Monad hiding ( tree, createDirectory ) +import Darcs.Util.Tree.Plain + +import System.Mem( performGC ) + +import qualified Data.Set as S +import qualified Data.Map as M + +import qualified Bundled.Posix as Posix + ( getFileStatus, getSymbolicLinkStatus, fileSize, fileExists ) + +import Test.HUnit hiding ( path ) +import Test.Framework( testGroup ) +import qualified Test.Framework as TF ( Test ) +import Test.QuickCheck + +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 + +------------------------ +-- Test Data +-- + +blobs :: [(AnchoredPath, BL.ByteString)] +blobs = [ (floatPath "foo_a", BL.pack "a\n") + , (floatPath "foo_dir/foo_a", BL.pack "a\n") + , (floatPath "foo_dir/foo_b", BL.pack "b\n") + , (floatPath "foo_dir/foo_subdir/foo_a", BL.pack "a\n") + , (floatPath "foo space/foo\nnewline", BL.pack "newline\n") + , (floatPath "foo space/foo\\backslash", BL.pack "backslash\n") + , (floatPath "foo space/foo_a", BL.pack "a\n") ] + +files :: [AnchoredPath] +files = map fst blobs + +dirs :: [AnchoredPath] +dirs = [ floatPath "foo_dir" + , floatPath "foo_dir/foo_subdir" + , floatPath "foo space" ] + +emptyStub :: TreeItem IO +emptyStub = Stub (return emptyTree) NoHash + +testTree :: Tree IO +testTree = + makeTree [ (makeName "foo", emptyStub) + , (makeName "subtree", SubTree sub) + , (makeName "substub", Stub getsub NoHash) ] + where sub = makeTree [ (makeName "stub", emptyStub) + , (makeName "substub", Stub getsub2 NoHash) + , (makeName "x", SubTree emptyTree) ] + getsub = return sub + getsub2 = return $ makeTree [ (makeName "file", File emptyBlob) + , (makeName "file2", + File $ Blob (return $ BL.pack "foo") NoHash) ] + +equals_testdata :: Tree IO -> IO () +equals_testdata t = sequence_ [ + do isJust (findFile t p) @? show p ++ " in tree" + ours <- readBlob (fromJust $ findFile t p) + ours @?= stored + | (p, stored) <- blobs ] >> + sequence_ [ isJust (Prelude.lookup p blobs) @? show p ++ " extra in tree" + | (p, File _) <- list t ] + +--------------------------- +-- Test list +-- + +tests :: [TF.Test] +tests = [ testGroup "Bundled.Posix" posix + , testGroup "Darcs.Util.Hash" hash + , testGroup "Darcs.Util.Tree" tree + , testGroup "Darcs.Util.Index" index + , testGroup "Darcs.Util.Tree.Monad" monad + , testGroup "Hashed Storage" hashed ] + +-------------------------- +-- Tests +-- + +hashed :: [TF.Test] +hashed = [ testCase "plain has all files" have_files + , testCase "pristine has all files" have_pristine_files + , testCase "pristine has no extras" pristine_no_extra + , testCase "pristine file contents match" pristine_contents + , testCase "plain file contents match" plain_contents + , testCase "writePlainTree works" write_plain ] + where + check_file t f = assertBool + ("path " ++ show f ++ " is missing in tree " ++ show t) + (isJust $ find t f) + check_files = forM_ files . check_file + + pristine_no_extra = extractRepoAndRun $ + do + t <- readDarcsPristine "." >>= expand + forM_ (list t) $ \(path,_) -> assertBool (show path ++ " is extraneous in tree") + (path `elem` (dirs ++ files)) + have_files = extractRepoAndRun ( readPlainTree "." >>= expand >>= check_files ) + have_pristine_files = extractRepoAndRun ( readDarcsPristine "." >>= expand >>= check_files ) + + pristine_contents = extractRepoAndRun $ + do + t <- readDarcsPristine "." >>= expand + equals_testdata t + + plain_contents = extractRepoAndRun $ + do + t <- expand =<< filter nondarcs `fmap` readPlainTree "." + equals_testdata t + + write_plain = extractRepoAndRun $ + do + orig <- readDarcsPristine "." >>= expand + writePlainTree orig "_darcs/plain" + t <- expand =<< readPlainTree "_darcs/plain" + equals_testdata t + +index :: [TF.Test] +index = [ testCase "index versioning" check_index_versions + , testCase "index listing" check_index + , testCase "index content" check_index_content + , testProperty "xlate32" prop_xlate32 + , testProperty "xlate64" prop_xlate64 + , testProperty "align bounded" prop_align_bounded + , testProperty "align aligned" prop_align_aligned ] + where pristine = readDarcsPristine "." >>= expand + build_index = + do x <- pristine + exist <- doesFileExist "_darcs/index" + performGC -- required in win32 to trigger file close + when exist $ removeFile "_darcs/index" + idx <- updateIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash x + return (x, idx) + check_index = extractRepoAndRun $ + do (pris, idx) <- build_index + (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris) + check_blob_pair p x y = + do a <- readBlob x + b <- readBlob y + assertEqual ("content match on " ++ show p) a b + check_index_content = extractRepoAndRun $ + do (_, idx) <- build_index + plain <- readPlainTree "." + x <- sequence $ zipCommonFiles check_blob_pair plain idx + assertBool "files match" (length x > 0) + check_index_versions = extractRepoAndRun $ + do performGC -- required in win32 to trigger file close + Prelude.writeFile "_darcs/index" "nonsense index... do not crash!" + valid <- indexFormatValid "_darcs/index" + assertBool "index format invalid" $ not valid + prop_xlate32 x = (xlate32 . xlate32) x == x where _types = x :: Word32 + prop_xlate64 x = (xlate64 . xlate64) x == x where _types = x :: Word64 + prop_align_bounded (bound, x) = + bound > 0 && bound < 1024 && x >= 0 ==> + align bound x >= x && align bound x < x + bound + where _types = (bound, x) :: (Int, Int) + prop_align_aligned (bound, x) = + bound > 0 && bound < 1024 && x >= 0 ==> + align bound x `rem` bound == 0 + where _types = (bound, x) :: (Int, Int) + +tree :: [TF.Test] +tree = [ testCase "modifyTree" check_modify + , testCase "complex modifyTree" check_modify_complex + , testCase "modifyTree removal" check_modify_remove + , testCase "expand" check_expand + , testCase "expandPath" check_expand_path + , testCase "expandPath of sub" check_expand_path_sub + , testCase "diffTrees" check_diffTrees + , testCase "diffTrees identical" check_diffTrees_ident + , testProperty "expandPath" prop_expandPath + , testProperty "shapeEq" prop_shape_eq + , testProperty "expandedShapeEq" prop_expanded_shape_eq + , testProperty "expand is identity" prop_expand_id + , testProperty "filter True is identity" prop_filter_id + , testProperty "filter False is empty" prop_filter_empty + , testProperty "restrict both ways keeps shape" prop_restrict_shape_commutative + , testProperty "restrict is a subtree of both" prop_restrict_subtree + , testProperty "overlay keeps shape" prop_overlay_shape + , testProperty "overlay is superset of over" prop_overlay_super ] + where blob x = File $ Blob (return (BL.pack x)) (sha256 $ BL.pack x) + name = Name . BS.pack + check_modify = + let t = makeTree [(name "foo", blob "bar")] + modify = modifyTree t (floatPath "foo") (Just $ blob "bla") + in do x <- readBlob $ fromJust $ findFile t (floatPath "foo") + y <- readBlob $ fromJust $ findFile modify (floatPath "foo") + assertEqual "old version" x (BL.pack "bar") + assertEqual "new version" y (BL.pack "bla") + assertBool "list has foo" $ + isJust (Prelude.lookup (floatPath "foo") $ list modify) + length (list modify) @?= 1 + check_modify_complex = + let t = makeTree [ (name "foo", blob "bar") + , (name "bar", SubTree t1) ] + t1 = makeTree [ (name "foo", blob "bar") ] + modify = modifyTree t (floatPath "bar/foo") (Just $ blob "bla") + in do foo <- readBlob $ fromJust $ findFile t (floatPath "foo") + foo' <- readBlob $ fromJust $ findFile modify (floatPath "foo") + bar_foo <- readBlob $ fromJust $ + findFile t (floatPath "bar/foo") + bar_foo' <- readBlob $ fromJust $ + findFile modify (floatPath "bar/foo") + assertEqual "old foo" foo (BL.pack "bar") + assertEqual "old bar/foo" bar_foo (BL.pack "bar") + assertEqual "new foo" foo' (BL.pack "bar") + assertEqual "new bar/foo" bar_foo' (BL.pack "bla") + assertBool "list has bar/foo" $ + isJust (Prelude.lookup (floatPath "bar/foo") $ list modify) + assertBool "list has foo" $ + isJust (Prelude.lookup (floatPath "foo") $ list modify) + length (list modify) @?= length (list t) + check_modify_remove = + let t1 = makeTree [(name "foo", blob "bar")] + t2 :: Tree Identity = makeTree [ (name "foo", blob "bar") + , (name "bar", SubTree t1) ] + modify1 = modifyTree t1 (floatPath "foo") Nothing + modify2 = modifyTree t2 (floatPath "bar") Nothing + file = findFile modify1 (floatPath "foo") + subtree = findTree modify2 (floatPath "bar") + in do assertBool "file is gone" (isNothing file) + assertBool "subtree is gone" (isNothing subtree) + + no_stubs t = null [ () | (_, Stub _ _) <- list t ] + path = floatPath "substub/substub/file" + badpath = floatPath "substub/substub/foo" + check_expand = do + x <- expand testTree + assertBool "no stubs in testTree" $ not (no_stubs testTree) + assertBool "stubs in expanded tree" $ no_stubs x + assertBool "path reachable" $ path `elem` (map fst $ list x) + assertBool "badpath not reachable" $ + badpath `notElem` (map fst $ list x) + check_expand_path = do + test_exp <- expand testTree + t <- expandPath testTree path + t' <- expandPath test_exp path + t'' <- expandPath testTree $ floatPath "substub/x" + assertBool "path not reachable in testTree" $ path `notElem` (map fst $ list testTree) + assertBool "path reachable in t" $ path `elem` (map fst $ list t) + assertBool "path reachable in t'" $ path `elem` (map fst $ list t') + assertBool "path reachable in t (with findFile)" $ + isJust $ findFile t path + assertBool "path reachable in t' (with findFile)" $ + isJust $ findFile t' path + assertBool "path not reachable in t''" $ path `notElem` (map fst $ list t'') + assertBool "badpath not reachable in t" $ + badpath `notElem` (map fst $ list t) + assertBool "badpath not reachable in t'" $ + badpath `notElem` (map fst $ list t') + + check_expand_path_sub = do + t <- expandPath testTree $ floatPath "substub" + t' <- expandPath testTree $ floatPath "substub/stub" + t'' <- expandPath testTree $ floatPath "subtree/stub" + assertBool "leaf is not a Stub" $ + isNothing (findTree testTree $ floatPath "substub") + assertBool "leaf is not a Stub" $ isJust (findTree t $ floatPath "substub") + assertBool "leaf is not a Stub (2)" $ isJust (findTree t' $ floatPath "substub/stub") + assertBool "leaf is not a Stub (3)" $ isJust (findTree t'' $ floatPath "subtree/stub") + + check_diffTrees = extractRepoAndRun $ + do Prelude.writeFile "foo_dir/foo_a" "b\n" + working_plain <- filter nondarcs `fmap` readPlainTree "." + working <- updateIndex =<< + updateIndexFrom "_darcs/index" darcsTreeHash working_plain + pristine <- readDarcsPristine "." + (working', pristine') <- diffTrees working pristine + let foo_work = findFile working' (floatPath "foo_dir/foo_a") + foo_pris = findFile pristine' (floatPath "foo_dir/foo_a") + working' `shapeEq` pristine' + @? show working' ++ " `shapeEq` " ++ show pristine' + assertBool "foo_dir/foo_a is in working'" $ isJust foo_work + assertBool "foo_dir/foo_a is in pristine'" $ isJust foo_pris + foo_work_c <- readBlob (fromJust foo_work) + foo_pris_c <- readBlob (fromJust foo_pris) + BL.unpack foo_work_c @?= "b\n" + BL.unpack foo_pris_c @?= "a\n" + assertEqual "working' tree is minimal" 2 (length $ list working') + assertEqual "pristine' tree is minimal" 2 (length $ list pristine') + + check_diffTrees_ident = do + pristine <- readDarcsPristine "." + (t1, t2) <- diffTrees pristine pristine + assertBool "t1 is empty" $ null (list t1) + assertBool "t2 is empty" $ null (list t2) + + prop_shape_eq x = no_stubs x ==> x `shapeEq` x + where _types = x :: Tree Identity + prop_expanded_shape_eq x = runIdentity $ expandedShapeEq x x + where _types = x :: Tree Identity + prop_expand_id x = no_stubs x ==> runIdentity (expand x) `shapeEq` x + where _types = x :: Tree Identity + prop_filter_id x = runIdentity $ expandedShapeEq x $ filter (\_ _ -> True) x + where _types = x :: Tree Identity + prop_filter_empty x = runIdentity $ expandedShapeEq emptyTree $ filter (\_ _ -> False) x + where _types = x :: Tree Identity + prop_restrict_shape_commutative (t1, t2) = + no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `shapeEq` emptyTree) ==> + restrict t1 t2 `shapeEq` restrict t2 t1 + where _types = (t1 :: Tree Identity, t2 :: Tree Identity) + prop_restrict_subtree (t1, t2) = + no_stubs t1 && not (restrict t1 t2 `shapeEq` emptyTree) ==> + let restricted = S.fromList (map fst $ list $ restrict t1 t2) + orig1 = S.fromList (map fst $ list t1) + orig2 = S.fromList (map fst $ list t2) + in and [restricted `S.isSubsetOf` orig1, restricted `S.isSubsetOf` orig2] + where _types = (t1 :: Tree Identity, t2 :: Tree Identity) + prop_overlay_shape (t1 :: Tree Identity, t2) = + (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==> + runIdentity $ (t1 `overlay` t2) `expandedShapeEq` t1 + prop_overlay_super (t1 :: Tree Identity, t2) = + (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) && no_stubs t2 ==> + Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2) + prop_expandPath (TreeWithPath t p) = + notStub $ find (runIdentity $ expandPath t p) p + where notStub (Just (Stub _ _)) = False + notStub Nothing = error "Did not exist." + notStub _ = True + +hash :: [TF.Test] +hash = [ testProperty "decodeBase16 . encodeBase16 == id" prop_base16 ] + where prop_base16 x = (decodeBase16 . encodeBase16) x == x + +monad :: [TF.Test] +monad = [ testCase "path expansion" check_virtual + , testCase "rename" check_rename ] + where check_virtual = virtualTreeMonad run testTree >> return () + where run = do file <- readFile (floatPath "substub/substub/file") + file2 <- readFile (floatPath "substub/substub/file2") + lift $ BL.unpack file @?= "" + lift $ BL.unpack file2 @?= "foo" + check_rename = do (_, t) <- virtualTreeMonad run testTree + t' <- darcsAddMissingHashes =<< expand t + forM_ [ (p, i) | (p, i) <- list t' ] $ \(p,i) -> + assertBool ("have hash: " ++ show p) $ itemHash i /= NoHash + where run = do rename (floatPath "substub/substub/file") (floatPath "substub/file2") + +posix :: [TF.Test] +posix = [ testCase "getFileStatus" $ check_stat Posix.getFileStatus + , testCase "getSymbolicLinkStatus" $ check_stat Posix.getSymbolicLinkStatus ] + where check_stat fun = extractRepoAndRun $ do + x <- Posix.fileSize `fmap` fun "foo_a" + Prelude.writeFile "test_empty" "" + y <- Posix.fileSize `fmap` fun "test_empty" + exist_nonexistent <- Posix.fileExists `fmap` fun "test_does_not_exist" + exist_existent <- Posix.fileExists `fmap` fun "test_empty" + assertEqual "file size" x 2 + assertEqual "file size" y 0 + assertBool "existence check" $ not exist_nonexistent + assertBool "existence check" exist_existent + +---------------------------------- +-- Arbitrary instances +-- + +#if !MIN_VERSION_QuickCheck(2,8,2) +-- these instances were added to QuickCheck itself in version 2.8.2 +instance (Arbitrary a, Ord a) => Arbitrary (S.Set a) + where arbitrary = S.fromList `fmap` arbitrary + +instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) + where arbitrary = M.fromList `fmap` arbitrary +#endif + +instance Arbitrary BL.ByteString where + arbitrary = BL.pack `fmap` arbitrary + +instance Arbitrary Hash where + arbitrary = sized hash' + where hash' 0 = return NoHash + hash' _ = do + tag <- oneof [return False, return True] + case tag of + False -> SHA256 . BS.pack <$> sequence [ arbitrary | _ <- [1..32] :: [Int] ] + True -> SHA1 . BS.pack <$> sequence [ arbitrary | _ <- [1..20] :: [Int] ] + +instance (Monad m) => Arbitrary (TreeItem m) where + arbitrary = sized tree' + where tree' 0 = oneof [ return (File emptyBlob), return (SubTree emptyTree) ] + tree' n = oneof [ file n, subtree n ] + file 0 = return (File emptyBlob) + file _ = do content <- arbitrary + return (File $ Blob (return content) NoHash) + subtree n = do branches <- choose (1, n) + let sub name = do t <- tree' ((n - 1) `div` branches) + return (makeName $ show name, t) + sublist <- mapM sub [0..branches] + oneof [ tree' 0 + , return (SubTree $ makeTree sublist) + , return $ (Stub $ return (makeTree sublist)) NoHash ] + +instance (Monad m) => Arbitrary (Tree m) where + arbitrary = do item <- arbitrary + case item of + File _ -> arbitrary + Stub _ _ -> arbitrary + SubTree t -> return t + +data TreeWithPath = TreeWithPath (Tree Identity) AnchoredPath deriving (Show) + +instance Arbitrary TreeWithPath where + arbitrary = do t <- arbitrary + p <- oneof $ return (AnchoredPath []) : + (map (return . fst) $ list (runIdentity $ expand t)) + return $ TreeWithPath t p + +--------------------------- +-- Other instances +-- + +instance Show (Blob m) where + show (Blob _ h) = "Blob " ++ show h + +instance Show (TreeItem m) where + show (File f) = "File (" ++ show f ++ ")" + show (Stub _ h) = "Stub _ " ++ show h + show (SubTree s) = "SubTree (" ++ show s ++ ")" + +instance Show (Tree m) where + show t = "Tree " ++ show (treeHash t) ++ " { " ++ + (concat . intersperse ", " $ itemstrs) ++ " }" + where itemstrs = map show $ listImmediate t + +instance Show (Int -> Int) where + show f = "[" ++ intercalate ", " (map val [1..20]) ++ " ...]" + where val x = show x ++ " -> " ++ show (f x) + +----------------------- +-- Test utilities +-- + +shapeEq :: Tree m -> Tree m -> Bool +shapeEq a b = Just EQ == cmpShape a b + +expandedShapeEq :: (Monad m, Functor m) => Tree m -> Tree m -> m Bool +expandedShapeEq a b = (Just EQ ==) <$> cmpExpandedShape a b + +cmpcat :: [Maybe Ordering] -> Maybe Ordering +cmpcat (x:y:rest) | x == y = cmpcat (x:rest) + | x == Just EQ = cmpcat (y:rest) + | y == Just EQ = cmpcat (x:rest) + | otherwise = Nothing +cmpcat [x] = x +cmpcat [] = Just EQ -- empty things are equal + +cmpTree :: (Monad m, Functor m) => Tree m -> Tree m -> m (Maybe Ordering) +cmpTree x y = do x' <- expand x + y' <- expand y + con <- contentsEq x' y' + return $ cmpcat [cmpShape x' y', con] + where contentsEq a b = cmpcat <$> sequence (zipTrees cmp a b) + cmp _ (Just (File a)) (Just (File b)) = do a' <- readBlob a + b' <- readBlob b + return $ Just (compare a' b') + cmp _ _ _ = return (Just EQ) -- neutral + +cmpShape :: Tree m -> Tree m -> Maybe Ordering +cmpShape t r = cmpcat $ zipTrees cmp t r + where cmp _ (Just a) (Just b) = a `item` b + cmp _ Nothing (Just _) = Just LT + cmp _ (Just _) Nothing = Just GT + cmp _ Nothing Nothing = Just EQ + item (File _) (File _) = Just EQ + item (SubTree s) (SubTree p) = s `cmpShape` p + item _ _ = Nothing + +cmpExpandedShape :: (Monad m) => Tree m -> Tree m -> m (Maybe Ordering) +cmpExpandedShape a b = do x <- expand a + y <- expand b + return $ x `cmpShape` y + +nondarcs :: AnchoredPath -> TreeItem m -> Bool +nondarcs (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False + | otherwise = True +nondarcs (AnchoredPath []) _ = True + +readDarcsPristine :: FilePath -> IO (Tree IO) +readDarcsPristine dir = do + let darcs = dir "_darcs" + h_inventory = darcs "hashed_inventory" + repo <- doesDirectoryExist darcs + unless repo $ fail $ "Not a darcs repository: " ++ dir + isHashed <- doesFileExist h_inventory + if isHashed + then do inv <- BS.readFile h_inventory + let thelines = BS.split '\n' inv + case thelines of + [] -> return emptyTree + (pris_line:_) -> do + let thehash = decodeDarcsHash $ BS.drop 9 pris_line + thesize = decodeDarcsSize $ BS.drop 9 pris_line + when (thehash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line + readDarcsHashed (darcs "pristine.hashed") (thesize, thehash) + else do have_pristine <- doesDirectoryExist $ darcs "pristine" + have_current <- doesDirectoryExist $ darcs "current" + case (have_pristine, have_current) of + (True, _) -> readPlainTree $ darcs "pristine" + (False, True) -> readPlainTree $ darcs "current" + (_, _) -> fail "No pristine tree is available!" + +extractRepoAndRun :: IO a -> IO a +extractRepoAndRun action = + do zipFile <- toArchive `fmap` BL.readFile "harness/hstestdata.zip" + removeDirectoryRecursive "_test_playground" `catch` \(_ :: IOException) -> return () + createDirectory "_test_playground" + setCurrentDirectory "_test_playground" + extractFilesFromArchive [] zipFile + result <- action + setCurrentDirectory ".." + removeDirectoryRecursive "_test_playground" + return result + diff --git a/harness/hstestdata.zip b/harness/hstestdata.zip new file mode 100644 Binary files /dev/null and b/harness/hstestdata.zip differ diff --git a/harness/test.hs b/harness/test.hs --- a/harness/test.hs +++ b/harness/test.hs @@ -12,6 +12,7 @@ import qualified Darcs.Test.Misc import qualified Darcs.Test.Patch import qualified Darcs.Test.Email +import qualified Storage.Hashed.Test import Control.Monad ( filterM ) import Control.Exception ( SomeException ) @@ -37,6 +38,10 @@ doUnit :: IO [Test] doUnit = return unitTests +-- | TODO make runnable in parallel +doHashed :: IO [Test] +doHashed = return Storage.Hashed.Test.tests + -- | This is the big list of tests that will be run using testrunner. unitTests :: [Test] unitTests = @@ -138,6 +143,7 @@ runtest t = withTmp $ \dir -> do cp "tests/lib" dir + cp "tests/network/sshlib" dir cp ("tests" testfile t) (dir "test") srcdir <- pwd silently $ sub $ cd dir >> runtest' t (toTextIgnore srcdir) @@ -208,7 +214,8 @@ -- harness -- ---------------------------------------------------------------------- -data Config = Config { failing :: Bool +data Config = Config { hashed :: Bool + , failing :: Bool , shell :: Bool , network :: Bool , unit :: Bool @@ -230,9 +237,10 @@ defaultConfig :: Annotate Ann defaultConfig = record Config{} - [ failing := False += help "Run the failing (shell) tests [no]" + [ hashed := False += help "Run hashed-storage tests [no]" + , failing := False += help "Run the failing (shell) tests [no]" , shell := True += help "Run the passing, non-network shell tests [yes]" - , network := False += help "Run the network shell tests [no]" + , network := True += help "Run the network shell tests [yes]" , unit := True += help "Run the unit tests [yes]" , myers := False += help "Use myers diff [no]" , patience := True += help "Use patience diff [yes]" += name "p" @@ -302,7 +310,8 @@ stests <- shelly $ if shell conf then findShell darcsBin (testDir conf) False diffAlgorithm repoFormat else return [] utests <- if unit conf then doUnit else return [] ntests <- shelly $ if network conf then findNetwork darcsBin (testDir conf) diffAlgorithm repoFormat else return [] - defaultMainWithArgs (ftests ++ stests ++ utests ++ ntests) args + hstests <- if hashed conf then doHashed else return [] + defaultMainWithArgs (ftests ++ stests ++ utests ++ ntests ++ hstests) args where exeSuffix :: String #ifdef WIN32 diff --git a/hashed-storage/Bundled/Posix.hsc b/hashed-storage/Bundled/Posix.hsc deleted file mode 100644 --- a/hashed-storage/Bundled/Posix.hsc +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE CPP, RankNTypes #-} - -module Bundled.Posix( getFdStatus, getSymbolicLinkStatus, getFileStatus - , getFileStatusBS - , fileExists - , modificationTime, fileSize, FileStatus - , EpochTime, isDirectory, isRegularFile ) where - -import qualified Data.ByteString.Char8 as BS -#if mingw32_HOST_OS -#else -import Data.ByteString.Unsafe( unsafeUseAsCString ) -#endif -import Foreign.Marshal.Alloc ( allocaBytes ) -import Foreign.C.Error ( throwErrno, getErrno, eNOENT ) -import Foreign.C.Types ( CTime, CInt ) -import Foreign.Ptr ( Ptr ) - -import System.Posix.Internals - ( CStat, c_fstat, sizeof_stat - , st_mode, st_size, st_mtime, s_isdir, s_isreg ) -#if mingw32_HOST_OS -import System.Posix.Internals ( c_stat, CFilePath ) -#endif - -import System.Posix.Types ( Fd(..), CMode, EpochTime ) - -#if mingw32_HOST_OS -import Foreign.C.String( withCWString, CWString ) -#else -import Foreign.C.String ( withCString, CString ) -#endif - -#if mingw32_HOST_OS -import Data.Int ( Int64 ) - -type FileOffset = Int64 -lstat :: CFilePath -> Ptr CStat -> IO CInt -lstat = c_stat -#else -import System.Posix.Types ( FileOffset ) -import System.Posix.Internals( lstat ) -#endif - -#if mingw32_HOST_OS -bsToPath :: forall a. BS.ByteString -> (CWString -> IO a) -> IO a -bsToPath s f = withCWString (BS.unpack s) f -strToPath :: forall a. String -> (CWString -> IO a) -> IO a -strToPath = withCWString -#else -bsToPath :: forall a. BS.ByteString -> (CString -> IO a) -> IO a -bsToPath = unsafeUseAsCString -strToPath :: forall a. String -> (CString -> IO a) -> IO a -strToPath = withCString -#endif - -data FileStatus = FileStatus { - fst_exists :: !Bool, - fst_mode :: !CMode, - fst_mtime :: !CTime, - fst_size :: !FileOffset - } - -getFdStatus :: Fd -> IO FileStatus -getFdStatus (Fd fd) = do - do_stat (c_fstat fd) - -do_stat :: (Ptr CStat -> IO CInt) -> IO FileStatus -do_stat stat_func = do - allocaBytes sizeof_stat $! \p -> do - ret <- stat_func p - if (ret == -1) then do err <- getErrno - if (err == eNOENT) - then return $! (FileStatus False 0 0 0) - else throwErrno "do_stat" - else do mode <- st_mode p - mtime <- st_mtime p - size <- st_size p - return $! FileStatus True mode mtime size -{-# INLINE do_stat #-} - -isDirectory :: FileStatus -> Bool -isDirectory = s_isdir . fst_mode - -isRegularFile :: FileStatus -> Bool -isRegularFile = s_isreg . fst_mode - -modificationTime :: FileStatus -> EpochTime -modificationTime = fst_mtime - -fileSize :: FileStatus -> FileOffset -fileSize = fst_size - -fileExists :: FileStatus -> Bool -fileExists = fst_exists - -#include - --- lstat is broken on win32 with at least GHC 6.10.3 -getSymbolicLinkStatus :: FilePath -> IO FileStatus -##if mingw32_HOST_OS -getSymbolicLinkStatus = getFileStatus -##else -getSymbolicLinkStatus fp = - do_stat (\p -> (fp `strToPath` (`lstat` p))) -##endif - -getFileStatus :: FilePath -> IO FileStatus -getFileStatus fp = - do_stat (\p -> (fp `strToPath` (`lstat` p))) - --- | Requires NULL-terminated bytestring -> unsafe! Use with care. -getFileStatusBS :: BS.ByteString -> IO FileStatus -getFileStatusBS fp = - do_stat (\p -> (fp `bsToPath` (`lstat` p))) -{-# INLINE getFileStatusBS #-} diff --git a/hashed-storage/LICENSE b/hashed-storage/LICENSE deleted file mode 100644 --- a/hashed-storage/LICENSE +++ /dev/null @@ -1,26 +0,0 @@ -Copyright Petr Rockai, Jose Neder 2009-2013 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/hashed-storage/Storage/Hashed.hs b/hashed-storage/Storage/Hashed.hs deleted file mode 100644 --- a/hashed-storage/Storage/Hashed.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Storage.Hashed - ( -- * Obtaining Trees. - -- - -- | Please note that Trees obtained this way will contain Stub - -- items. These need to be executed (they are IO actions) in order to be - -- accessed. Use 'expand' to do this. However, many operations are - -- perfectly fine to be used on a stubbed Tree (and it is often more - -- efficient to do everything that can be done before expanding a Tree). - readPlainTree, readDarcsHashed - - -- * Blob access. - , readBlob - - -- * Writing trees. - , writePlainTree, writeDarcsHashed - - -- * Unsafe functions for the curious explorer. - -- - -- | These are more useful for playing within ghci than for real, serious - -- programs. They generally trade safety for conciseness. Please use - -- responsibly. Don't kill innocent kittens. - , floatPath, printPath ) where - -import Storage.Hashed.AnchoredPath -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BL -import Storage.Hashed.Tree ( Tree, TreeItem(..), listImmediate, find, readBlob ) - --- For re-exports. -import Storage.Hashed.Darcs( readDarcsHashed, writeDarcsHashed ) -import Storage.Hashed.Plain( readPlainTree, writePlainTree ) - ------------------------- --- For explorers --- - --- | Take a relative FilePath within a Tree and print the contents of the --- object there. Useful for exploration, less so for serious programming. -printPath :: Tree IO -> FilePath -> IO () -printPath t p = print' $ find t (floatPath p) - where print' Nothing = putStrLn $ "ERROR: No object at " ++ p - print' (Just (File b)) = do - putStrLn $ "== Contents of file " ++ p ++ ":" - BL.unpack `fmap` readBlob b >>= putStr - print' (Just (SubTree t')) = do - putStrLn $ "== Listing Tree " ++ p ++ " (immediates only):" - putStr $ unlines $ map BS.unpack $ listNames t' - print' (Just (Stub _ _)) = - putStrLn $ "== (not listing stub at " ++ p ++ ")" - listNames t' = [ n | (Name n, _) <- listImmediate t' ] - diff --git a/hashed-storage/Storage/Hashed/AnchoredPath.hs b/hashed-storage/Storage/Hashed/AnchoredPath.hs deleted file mode 100644 --- a/hashed-storage/Storage/Hashed/AnchoredPath.hs +++ /dev/null @@ -1,110 +0,0 @@ --- | This module implements relative paths within a Tree. All paths are --- anchored at a certain root (this is usually the Tree root). They are --- represented by a list of Names (these are just strict bytestrings). -module Storage.Hashed.AnchoredPath - ( Name(..), AnchoredPath(..), anchoredRoot, appendPath, anchorPath - , isPrefix, parent, parents, catPaths, flatten, makeName, appendToName - -- * Unsafe functions. - , floatBS, floatPath, replacePrefixPath ) where - -import qualified Data.ByteString.Char8 as BS -import Data.List( isPrefixOf, inits ) -import System.FilePath( (), splitDirectories, normalise, dropTrailingPathSeparator ) - -------------------------------- --- AnchoredPath utilities --- - -newtype Name = Name BS.ByteString deriving (Eq, Show, Ord) - --- | This is a type of "sane" file paths. These are always canonic in the sense --- that there are no stray slashes, no ".." components and similar. They are --- usually used to refer to a location within a Tree, but a relative filesystem --- path works just as well. These are either constructed from individual name --- components (using "appendPath", "catPaths" and "makeName"), or converted --- from a FilePath ("floatPath" -- but take care when doing that) or . -newtype AnchoredPath = AnchoredPath [Name] deriving (Eq, Show, Ord) - --- | Check whether a path is a prefix of another path. -isPrefix :: AnchoredPath -> AnchoredPath -> Bool -(AnchoredPath a) `isPrefix` (AnchoredPath b) = a `isPrefixOf` b - --- | Append an element to the end of a path. -appendPath :: AnchoredPath -> Name -> AnchoredPath -appendPath (AnchoredPath p) n = - case n of - (Name s) | s == BS.empty -> AnchoredPath p - | s == BS.pack "." -> AnchoredPath p - | otherwise -> AnchoredPath $ p ++ [n] - --- | Catenate two paths together. Not very safe, but sometimes useful --- (e.g. when you are representing paths relative to a different point than a --- Tree root). -catPaths :: AnchoredPath -> AnchoredPath -> AnchoredPath -catPaths (AnchoredPath p) (AnchoredPath n) = AnchoredPath $ p ++ n - --- | Get parent (path) of a given path. foo/bar/baz -> foo/bar -parent :: AnchoredPath -> AnchoredPath -parent (AnchoredPath x) = AnchoredPath (init x) - --- | List all parents of a given path. foo/bar/baz -> [foo, foo/bar] -parents :: AnchoredPath -> [AnchoredPath] -parents (AnchoredPath x) = map AnchoredPath . init . inits $ x - --- | Take a "root" directory and an anchored path and produce a full --- 'FilePath'. Moreover, you can use @anchorPath \"\"@ to get a relative --- 'FilePath'. -anchorPath :: FilePath -> AnchoredPath -> FilePath -anchorPath dir p = dir BS.unpack (flatten p) -{-# INLINE anchorPath #-} - --- | Unsafe. Only ever use on bytestrings that came from flatten on a --- pre-existing AnchoredPath. -floatBS :: BS.ByteString -> AnchoredPath -floatBS = AnchoredPath . map Name . takeWhile (not . BS.null) . BS.split '/' - -flatten :: AnchoredPath -> BS.ByteString -flatten (AnchoredPath []) = BS.singleton '.' -flatten (AnchoredPath p) = BS.intercalate (BS.singleton '/') - [ n | (Name n) <- p ] - -makeName :: String -> Name -makeName ".." = error ".. is not a valid AnchoredPath component name" -makeName n | '/' `elem` n = error "/ may not occur in a valid AnchoredPath component name" - | otherwise = Name $ BS.pack n - --- | Take a relative FilePath and turn it into an AnchoredPath. The operation --- is (relatively) unsafe. Basically, by using floatPath, you are testifying --- that the argument is a path relative to some common root -- i.e. the root of --- the associated "Tree" object. Also, there are certain invariants about --- AnchoredPath that this function tries hard to preserve, but probably cannot --- guarantee (i.e. this is a best-effort thing). You should sanitize any --- FilePaths before you declare them "good" by converting into AnchoredPath --- (using this function). -floatPath :: FilePath -> AnchoredPath -floatPath = make . splitDirectories . normalise . dropTrailingPathSeparator - where make ["."] = AnchoredPath [] - make x = AnchoredPath $ map (Name . BS.pack) x - - -anchoredRoot :: AnchoredPath -anchoredRoot = AnchoredPath [] - --- | Take a prefix path, the changed prefix path, and a path to change. --- Assumes the prefix path is a valid prefix. If prefix is wrong return --- AnchoredPath []. -replacePrefixPath :: AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath -replacePrefixPath (AnchoredPath []) b c = catPaths b c -replacePrefixPath (AnchoredPath (r:p)) b (AnchoredPath (r':p')) - | r == r' = replacePrefixPath (AnchoredPath p) b (AnchoredPath p') - | otherwise = AnchoredPath [] -replacePrefixPath _ _ _ = AnchoredPath [] - --- | Append a ByteString to the last Name of an AnchoredPath. -appendToName :: AnchoredPath -> String -> AnchoredPath -appendToName (AnchoredPath p) s = AnchoredPath (init p++[Name finalname]) - where suffix = BS.pack s - finalname | suffix `elem` (BS.tails lastname) = lastname - | otherwise = BS.append lastname suffix - lastname = case last p of - Name name -> name diff --git a/hashed-storage/Storage/Hashed/Darcs.hs b/hashed-storage/Storage/Hashed/Darcs.hs deleted file mode 100644 --- a/hashed-storage/Storage/Hashed/Darcs.hs +++ /dev/null @@ -1,310 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} - --- | A few darcs-specific utility functions. These are used for reading and --- writing darcs and darcs-compatible hashed trees. -module Storage.Hashed.Darcs where - -import Prelude hiding ( lookup, catch ) -import System.FilePath ( () ) - -import System.Directory( doesFileExist ) -import Codec.Compression.GZip( decompress, compress ) -import Control.Applicative( (<$>) ) -import Control.Exception( catch, IOException ) - -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy.Char8 as BL8 -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString as BS - -import Data.List( sortBy ) -import Data.Char( chr, ord, isSpace ) -import Data.Maybe( fromJust, isJust ) -import Control.Monad.State.Strict - -import Storage.Hashed.Tree hiding ( lookup ) -import Storage.Hashed.AnchoredPath -import Storage.Hashed.Utils -import Storage.Hashed.Hash -import Storage.Hashed.Packed -import Storage.Hashed.Monad - ---------------------------------------------------------------------- --- Utilities for coping with the darcs directory format. --- - --- | 'darcsDecodeWhite' interprets the Darcs-specific \"encoded\" filenames --- produced by 'darcsEncodeWhite' --- --- > darcsDecodeWhite "hello\32\there" == "hello there" --- > darcsDecodeWhite "hello\92\there" == "hello\there" --- > darcsDecodeWhite "hello\there" == error "malformed filename" -darcsDecodeWhite :: String -> FilePath -darcsDecodeWhite ('\\':cs) = - case break (=='\\') cs of - (theord, '\\':rest) -> - chr (read theord) : darcsDecodeWhite rest - _ -> error "malformed filename" -darcsDecodeWhite (c:cs) = c: darcsDecodeWhite cs -darcsDecodeWhite "" = "" - --- | 'darcsEncodeWhite' translates whitespace in filenames to a darcs-specific --- format (backslash followed by numerical representation according to 'ord'). --- Note that backslashes are also escaped since they are used in the encoding. --- --- > darcsEncodeWhite "hello there" == "hello\32\there" --- > darcsEncodeWhite "hello\there" == "hello\92\there" -darcsEncodeWhite :: FilePath -> String -darcsEncodeWhite (c:cs) | isSpace c || c == '\\' = - '\\' : (show $ ord c) ++ "\\" ++ darcsEncodeWhite cs -darcsEncodeWhite (c:cs) = c : darcsEncodeWhite cs -darcsEncodeWhite [] = [] - -darcsEncodeWhiteBS :: BS8.ByteString -> BS8.ByteString -darcsEncodeWhiteBS = BS8.pack . darcsEncodeWhite . BS8.unpack - -decodeDarcsHash :: BS8.ByteString -> Hash -decodeDarcsHash bs = case BS8.split '-' bs of - [s, h] | BS8.length s == 10 -> decodeBase16 h - _ -> decodeBase16 bs - -decodeDarcsSize :: BS8.ByteString -> Maybe Int -decodeDarcsSize bs = case BS8.split '-' bs of - [s, _] | BS8.length s == 10 -> - case reads (BS8.unpack s) of - [(x, _)] -> Just x - _ -> Nothing - _ -> Nothing - -darcsLocation :: FilePath -> (Maybe Int, Hash) -> FileSegment -darcsLocation dir (s,h) = case hash of - "" -> error "darcsLocation: invalid hash" - _ -> (dir prefix s ++ hash, Nothing) - where prefix Nothing = "" - prefix (Just s') = formatSize s' ++ "-" - formatSize s' = let n = show s' in replicate (10 - length n) '0' ++ n - hash = BS8.unpack (encodeBase16 h) - ----------------------------------------------- --- Darcs directory format. --- - -darcsFormatDir :: Tree m -> Maybe BL8.ByteString -darcsFormatDir t = BL8.fromChunks <$> concat <$> - mapM string (sortBy cmp $ listImmediate t) - where cmp (Name a, _) (Name b, _) = compare a b - string (Name name, item) = - do header <- case item of - File _ -> Just $ BS8.pack "file:\n" - _ -> Just $ BS8.pack "directory:\n" - hash <- case itemHash item of - NoHash -> Nothing - x -> Just $ encodeBase16 x - return $ [ header - , darcsEncodeWhiteBS name - , BS8.singleton '\n' - , hash, BS8.singleton '\n' ] - -darcsParseDir :: BL8.ByteString -> [(ItemType, Name, Maybe Int, Hash)] -darcsParseDir content = parse (BL8.split '\n' content) - where - parse (t:n:h':r) = (header t, - Name $ BS8.pack $ darcsDecodeWhite (BL8.unpack n), - decodeDarcsSize hash, - decodeDarcsHash hash) : parse r - where hash = BS8.concat $ BL8.toChunks h' - parse _ = [] - header x - | x == BL8.pack "file:" = BlobType - | x == BL8.pack "directory:" = TreeType - | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL8.unpack x - ----------------------------------------- --- Utilities. --- - --- | Compute a darcs-compatible hash value for a tree-like structure. -darcsTreeHash :: Tree m -> Hash -darcsTreeHash t = case darcsFormatDir t of - Nothing -> NoHash - Just x -> sha256 x - --- The following two are mostly for experimental use in Packed. - -darcsUpdateDirHashes :: Tree m -> Tree m -darcsUpdateDirHashes = updateSubtrees update - where update t = t { treeHash = darcsTreeHash t } - -darcsUpdateHashes :: (Monad m, Functor m) => Tree m -> m (Tree m) -darcsUpdateHashes = updateTree update - where update (SubTree t) = return . SubTree $ t { treeHash = darcsTreeHash t } - update (File blob@(Blob con _)) = - do hash <- sha256 <$> readBlob blob - return $ File (Blob con hash) - update stub = return stub - -darcsHash :: (Monad m, Functor m) => TreeItem m -> m Hash -darcsHash (SubTree t) = return $ darcsTreeHash t -darcsHash (File blob) = sha256 <$> readBlob blob -darcsHash _ = return NoHash - -darcsAddMissingHashes :: (Monad m, Functor m) => Tree m -> m (Tree m) -darcsAddMissingHashes = addMissingHashes darcsHash - -------------------------------------------- --- Reading darcs pristine data --- - --- | Read and parse a darcs-style hashed directory listing from a given @dir@ --- and with a given @hash@. -readDarcsHashedDir :: FilePath -> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)] -readDarcsHashedDir dir h = do - exist <- doesFileExist $ fst (darcsLocation dir h) - unless exist $ fail $ "error opening " ++ fst (darcsLocation dir h) - compressed <- readSegment $ darcsLocation dir h - let content = decompress compressed - return $ if BL8.null compressed - then [] - else darcsParseDir content - --- | Read in a darcs-style hashed tree. This is mainly useful for reading --- \"pristine.hashed\". You need to provide the root hash you are interested in --- (found in _darcs/hashed_inventory). -readDarcsHashed' :: Bool -> FilePath -> (Maybe Int, Hash) -> IO (Tree IO) -readDarcsHashed' _ _ (_, NoHash) = fail "Cannot readDarcsHashed NoHash" -readDarcsHashed' sizefail dir root@(_, hash) = do - items' <- readDarcsHashedDir dir root - subs <- sequence [ - do when (sizefail && isJust s) $ - fail ("Unexpectedly encountered size-prefixed hash in " ++ dir) - case tp of - BlobType -> return (d, File $ - Blob (readBlob' (s, h)) h) - TreeType -> - do let t = readDarcsHashed dir (s, h) - return (d, Stub t h) - | (tp, d, s, h) <- items' ] - return $ makeTreeWithHash subs hash - where readBlob' = fmap decompress . readSegment . darcsLocation dir - -readDarcsHashed :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO) -readDarcsHashed = readDarcsHashed' False - -readDarcsHashedNosize :: FilePath -> Hash -> IO (Tree IO) -readDarcsHashedNosize dir hash = readDarcsHashed' True dir (Nothing, hash) - ----------------------------------------------------- --- Writing darcs-style hashed trees. --- - --- | Write a Tree into a darcs-style hashed directory. -writeDarcsHashed :: Tree IO -> FilePath -> IO Hash -writeDarcsHashed tree' dir = - do t <- darcsUpdateDirHashes <$> expand tree' - sequence_ [ dump =<< readBlob b | (_, File b) <- list t ] - let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ] - _ <- mapM dump $ map fromJust dirs - return $ darcsTreeHash t - where dump bits = - do let name = dir BS8.unpack (encodeBase16 $ sha256 bits) - exist <- doesFileExist name - unless exist $ BL.writeFile name (compress bits) - --- | Create a hashed file from a 'FilePath' and content. In case the file exists --- it is kept untouched and is assumed to have the right content. XXX Corrupt --- files should be probably renamed out of the way automatically or something --- (probably when they are being read though). -fsCreateHashedFile :: FilePath -> BL8.ByteString -> TreeIO () -fsCreateHashedFile fn content = - liftIO $ do - exist <- doesFileExist fn - unless exist $ BL.writeFile fn content - --- | Run a 'TreeIO' @action@ in a hashed setting. The @initial@ tree is assumed --- to be fully available from the @directory@, and any changes will be written --- out to same. Please note that actual filesystem files are never removed. -hashedTreeIO :: TreeIO a -- ^ action - -> Tree IO -- ^ initial - -> FilePath -- ^ directory - -> IO (a, Tree IO) -hashedTreeIO action t dir = - do runTreeMonad action $ initialState t darcsHash updateItem - where updateItem _ (File b) = File <$> updateFile b - updateItem _ (SubTree s) = SubTree <$> updateSub s - updateItem _ x = return x - - updateFile b@(Blob _ !h) = do - content <- liftIO $ readBlob b - let fn = dir BS8.unpack (encodeBase16 h) - nblob = Blob (decompress <$> rblob) h - rblob = BL.fromChunks <$> return <$> BS.readFile fn - newcontent = compress content - fsCreateHashedFile fn newcontent - return nblob - updateSub s = do - let !hash = treeHash s - Just dirdata = darcsFormatDir s - fn = dir BS8.unpack (encodeBase16 hash) - fsCreateHashedFile fn (compress dirdata) - return s - --------------------------------------------------------------- --- Reading and writing packed pristine. EXPERIMENTAL. ----- - --- | Read a Tree in the darcs hashed format from an object storage. This is --- basically the same as readDarcsHashed from Storage.Hashed, but uses an --- object storage instead of traditional darcs filesystem layout. Requires the --- tree root hash as a starting point. -readPackedDarcsPristine :: OS -> Hash -> IO (Tree IO) -readPackedDarcsPristine os root = - do items' <- darcsParseDir <$> grab root - subs <- sequence [ - case tp of - BlobType -> return (d, File $ file h) - TreeType -> let t = readPackedDarcsPristine os h - in return (d, Stub t h) - | (tp, d, _, h) <- items' ] - return $ makeTreeWithHash subs root - where file h = Blob (grab h) h - grab hash = do maybeseg <- lookup os hash - case maybeseg of - Nothing -> fail $ "hash " ++ BS8.unpack (encodeBase16 hash) ++ " not available" - Just seg -> readSegment seg - --- | Write a Tree into an object storage, using the darcs-style directory --- formatting (and therefore darcs-style hashes). Gives back the object storage --- and the root hash of the stored Tree. NB. The function expects that the Tree --- comes equipped with darcs-style hashes already! -writePackedDarcsPristine :: Tree IO -> OS -> IO (OS, Hash) -writePackedDarcsPristine tree' os = - do t <- darcsUpdateDirHashes <$> expand tree' - files <- sequence [ readBlob b | (_, File b) <- list t ] - let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ] - os' <- hatch os $ files ++ (map fromJust dirs) - return (os', darcsTreeHash t) - -storePackedDarcsPristine :: Tree IO -> OS -> IO (OS, Hash) -storePackedDarcsPristine tree' os = - do (os', root) <- writePackedDarcsPristine tree' os - return $ (os' { roots = root : roots os' - -- FIXME we probably don't want to override the references - -- thing completely here... - , references = darcsPristineRefs }, root) - -darcsPristineRefs :: FileSegment -> IO [Hash] -darcsPristineRefs fs = do - con <- (darcsParseDir <$> readSegment fs) `catch` \(_ :: IOException) -> return [] - return $! [ hash | (_, _, _, hash) <- con, valid hash ] - where valid NoHash = False - valid _ = True - -darcsCheckExpand :: Tree IO - -> IO (Either [(FilePath, Hash, Maybe Hash)] (Tree IO)) -darcsCheckExpand t = do - problemsOrTree <- checkExpand darcsHash t - case problemsOrTree of - Left problems -> return . Left $ map render problems - Right tree' -> return . Right $ tree' - where - render (path, h, h') = (anchorPath "." path, h, h') diff --git a/hashed-storage/Storage/Hashed/Diff.hs b/hashed-storage/Storage/Hashed/Diff.hs deleted file mode 100644 --- a/hashed-storage/Storage/Hashed/Diff.hs +++ /dev/null @@ -1,136 +0,0 @@ -module Storage.Hashed.Diff where - -import Prelude hiding ( lookup, filter ) -import qualified Data.ByteString.Lazy.Char8 as BL -import Storage.Hashed.Tree -import Storage.Hashed.AnchoredPath -import Data.List.LCS -import Data.List ( groupBy ) - -unidiff :: Tree IO -> Tree IO -> IO BL.ByteString -unidiff l r = - do (from, to) <- diffTrees l r - diffs <- sequence $ zipCommonFiles diff from to - return $ BL.concat diffs - where diff p a b = do x <- readBlob a - y <- readBlob b - return $ diff' p x y - diff' p x y = - case unifiedDiff x y of - x' | BL.null x' -> BL.empty - | otherwise -> - (BL.pack $ "--- " ++ anchorPath "old" p ++ "\n" ++ - "+++ " ++ anchorPath "new" p ++ "\n") - `BL.append` x' - -type Line = BL.ByteString -data WeaveLine = Common Line - | Remove Line - | Add Line - | Replace Line Line - | Skip Int deriving Show - --- | A weave -- two files woven together, with common and differing regions --- marked up. Cf. 'WeaveLine'. -type Weave = [WeaveLine] - --- | Sort of a sub-weave. -type Hunk = [WeaveLine] - --- | Produce unified diff (in a string form, ie. formatted) from a pair of --- bytestrings. -unifiedDiff :: BL.ByteString -> BL.ByteString -> BL.ByteString -unifiedDiff a b = printUnified $ concat unifiedHunks - where unifiedHunks = reduceContext 3 $ map unifyHunk $ hunks $ weave a b - --- | Weave two bytestrings. Intermediate data structure for the actual unidiff --- implementation. No skips are produced. -weave :: BL.ByteString -> BL.ByteString -> Weave -weave a' b' = weave' left common right - where left = init' (BL.split '\n' a') -- drop trailing newline - right = init' (BL.split '\n' b') -- drop trailing newline - init' [] = [] - init' x = init x - common = lcs left right - weave' [] [] [] = [] - weave' [] c [] = error $ "oops: Left & Right empty, Common: " ++ show c - weave' [] [] (b:bs) = Add b : weave' [] [] bs - weave' (a:as) [] [] = Remove a : weave' as [] [] - weave' (a:as) [] (b:bs) = Replace a b : weave' as [] bs - weave' (a:as) (c:cs) (b:bs) - | a == c && b == c = Common a : weave' as cs bs - | a == c && b /= c = Add b : weave' (a:as) (c:cs) bs - | a /= c && b == c = Remove a : weave' as (c:cs) (b:bs) - | a /= c && b /= c = Replace a b : weave' as (c:cs) bs - | otherwise = error "oops!" - weave' a c b = error $ "oops: \nLeft: " ++ show a ++ "\nCommon: " ++ show c ++ "\nRight: " ++ show b - --- | Break up a 'Weave' into 'Hunk's. -hunks :: Weave -> [Hunk] -hunks = groupBy grp - where grp (Common _) (Common _) = True - grp (Common _) _ = False - grp _ (Common _) = False - grp _ _ = True - --- | Reformat a 'Hunk' into a format suitable for unified diff. Replaces are --- turned into add/remove pairs, all removals in a hunk go before all --- adds. 'Hunk's of 'Common' lines are left intact. Produces input suitable for --- 'reduceContext'. -unifyHunk :: Hunk -> Hunk -unifyHunk h = case h of - (Common _:_) -> h - _ -> reorder $ concatMap breakup h - where reorder h' = [ Remove a | Remove a <- h' ] ++ [ Add a | Add a <- h' ] - breakup (Replace f t) = [Remove f, Add t] - breakup x = [x] - --- | Break up a 'Weave' into unified 'Hunk's, leaving @n@ lines of context around --- every hunk. Consecutive 'Common' lines not used as context are replaced with --- 'Skip's. -reduceContext :: Int -> [Hunk] -> [Hunk] -reduceContext n hs = - case hs of - [] -> [] - [Common _:_] -> [] - [x] -> [x] - [h,t] -> [reduce 0 n h, reduce n 0 t] - (h:rest) -> reduce 0 n h : - map (reduce n n) (init rest) ++ - [reduce n 0 $ last rest] - where - reduce s e h@(Common _:_) - | length h <= s + e = h - | otherwise = take s h ++ - [Skip $ length h - e - s ] ++ - drop (length h - e) h - reduce _ _ h = h - --- | Format a 'Weave' for printing. -deweave :: Weave -> BL.ByteString -deweave = BL.unlines . map disp - where disp (Common l) = BL.cons ' ' l - disp (Remove l) = BL.cons '-' l - disp (Add l) = BL.cons '+' l - disp (Replace _ t) = BL.cons '!' t - disp (Skip n) = BL.pack $ "-- skip " ++ show n ++ " lines --" - --- | Print a \"hunked\" weave in form of an unified diff. 'Hunk' boundaries are --- marked up as 'Skip' lines. Cf. 'reduceContext'. -printUnified :: Weave -> BL.ByteString -printUnified hunked = printHunks 1 1 $ groupBy splits hunked - where splits (Skip _) _ = False - splits _ (Skip _) = False - splits _ _ = True - printHunks _ _ [] = BL.empty - printHunks l r ([Skip n]:rest) = - printHunks (n+l) (n+r) rest - printHunks l r (h:rest) = - (BL.pack $ "@@ -" ++ show l ++ "," ++ - show (removals h) ++ " +" ++ show r ++ - "," ++ show (adds h) ++ " @@\n") - `BL.append` deweave h `BL.append` - printHunks (l + removals h) (r + adds h) rest - commons h = length [ () | (Common _) <- h ] - adds h = commons h + length [ () | (Add _) <- h ] - removals h = commons h + length [ () | (Remove _) <- h ] diff --git a/hashed-storage/Storage/Hashed/Hash.hs b/hashed-storage/Storage/Hashed/Hash.hs deleted file mode 100644 --- a/hashed-storage/Storage/Hashed/Hash.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Storage.Hashed.Hash( Hash(..), encodeBase64u, decodeBase64u - , encodeBase16, decodeBase16, sha256, rawHash - , match ) where - -import qualified Crypto.Hash.SHA256 as SHA256 ( hash ) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Char8 as BS8 - -import qualified Codec.Binary.Base64Url as B64U -import qualified Codec.Binary.Base16 as B16 - -import Data.Maybe( isJust, fromJust ) -import Data.Char( toLower, toUpper ) - -import Data.Data( Data ) -import Data.Typeable( Typeable ) - -data Hash = SHA256 !BS.ByteString - | SHA1 !BS.ByteString - | NoHash - deriving (Show, Eq, Ord, Read, Typeable, Data) - -base16 :: BS.ByteString -> BS.ByteString -debase16 :: BS.ByteString -> Maybe BS.ByteString -base64u :: BS.ByteString -> BS.ByteString -debase64u :: BS.ByteString -> Maybe BS.ByteString - -base16 = BS8.map toLower . B16.b16_enc -base64u = B64U.encode -debase64u bs = case B64U.decode bs of - Right s -> Just s - Left _ -> Nothing -debase16 bs = case B16.b16_dec $ BS8.map toUpper bs of - Right (s, _) -> Just s - Left _ -> Nothing - -encodeBase64u :: Hash -> BS.ByteString -encodeBase64u (SHA256 bs) = base64u bs -encodeBase64u (SHA1 bs) = base64u bs -encodeBase64u NoHash = BS.empty - --- | Produce a base16 (ascii-hex) encoded string from a hash. This can be --- turned back into a Hash (see "decodeBase16". This is a loss-less process. -encodeBase16 :: Hash -> BS.ByteString -encodeBase16 (SHA256 bs) = base16 bs -encodeBase16 (SHA1 bs) = base16 bs -encodeBase16 NoHash = BS.empty - --- | Take a base64/url-encoded string and decode it as a "Hash". If the string --- is malformed, yields NoHash. -decodeBase64u :: BS.ByteString -> Hash -decodeBase64u bs - | BS.length bs == 44 && isJust (debase64u bs) = SHA256 (fromJust $ debase64u bs) - | BS.length bs == 28 && isJust (debase64u bs) = SHA1 (fromJust $ debase64u bs) - | otherwise = NoHash - --- | Take a base16-encoded string and decode it as a "Hash". If the string is --- malformed, yields NoHash. -decodeBase16 :: BS.ByteString -> Hash -decodeBase16 bs | BS.length bs == 64 && isJust (debase16 bs) = SHA256 (fromJust $ debase16 bs) - | BS.length bs == 40 && isJust (debase16 bs) = SHA1 (fromJust $ debase16 bs) - | otherwise = NoHash - --- | Compute a sha256 of a (lazy) ByteString. However, although this works --- correctly for any bytestring, it is only efficient if the bytestring only --- has a sigle chunk. -sha256 :: BL.ByteString -> Hash -sha256 bits = SHA256 $ SHA256.hash $ BS.concat $ BL.toChunks bits - -rawHash :: Hash -> BS.ByteString -rawHash NoHash = error "Cannot obtain raw hash from NoHash." -rawHash (SHA1 s) = s -rawHash (SHA256 s) = s - -match :: Hash -> Hash -> Bool -NoHash `match` _ = False -_ `match` NoHash = False -x `match` y = x == y diff --git a/hashed-storage/Storage/Hashed/Index.hs b/hashed-storage/Storage/Hashed/Index.hs deleted file mode 100644 --- a/hashed-storage/Storage/Hashed/Index.hs +++ /dev/null @@ -1,525 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses #-} - --- | This module contains plain tree indexing code. The index itself is a --- CACHE: you should only ever use it as an optimisation and never as a primary --- storage. In practice, this means that when we change index format, the --- application is expected to throw the old index away and build a fresh --- index. Please note that tracking index validity is out of scope for this --- library: this is responsibility of your application. It is advisable that in --- your validity tracking code, you also check for format validity (see --- 'indexFormatValid') and scrap and re-create index when needed. --- --- The index is a binary file that overlays a hashed tree over the working --- copy. This means that every working file and directory has an entry in the --- index, that contains its path and hash and validity data. The validity data --- is a timestamp plus the file size. The file hashes are sha256's of the --- file's content. It also contains the fileid to track moved files. --- --- There are two entry types, a file entry and a directory entry. Both have a --- common binary format (see 'Item'). The on-disk format is best described by --- the section /Index format/ below. --- --- For each file, the index has a copy of the file's last modification --- timestamp taken at the instant when the hash has been computed. This means --- that when file size and timestamp of a file in working copy matches those in --- the index, we assume that the hash stored in the index for given file is --- valid. These hashes are then exposed in the resulting 'Tree' object, and can --- be leveraged by eg. 'diffTrees' to compare many files quickly. --- --- You may have noticed that we also keep hashes of directories. These are --- assumed to be valid whenever the complete subtree has been valid. At any --- point, as soon as a size or timestamp mismatch is found, the working file in --- question is opened, its hash (and timestamp and size) is recomputed and --- updated in-place in the index file (everything lives at a fixed offset and --- is fixed size, so this isn't an issue). This is also true of directories: --- when a file in a directory changes hash, this triggers recomputation of all --- of its parent directory hashes; moreover this is done efficiently -- each --- directory is updated at most once during an update run. --- --- /Index format/ --- --- The Index is organised into \"lines\" where each line describes a single --- indexed item. Cf. 'Item'. --- --- The first word on the index \"line\" is the length of the file path (which is --- the only variable-length part of the line). Then comes the path itself, then --- fixed-length hash (sha256) of the file in question, then three words, one for --- size, one for "aux", which is used differently for directories and for files, and --- one for the fileid (inode or fhandle) of the file. --- --- With directories, this aux holds the offset of the next sibling line in the --- index, so we can efficiently skip reading the whole subtree starting at a --- given directory (by just seeking aux bytes forward). The lines are --- pre-ordered with respect to directory structure -- the directory comes first --- and after it come all its items. Cf. 'readIndex''. --- --- For files, the aux field holds a timestamp. - -module Storage.Hashed.Index( readIndex, updateIndexFrom, indexFormatValid - , updateIndex, listFileIDs, Index, filter - , getFileID ) - where - -import Prelude hiding ( lookup, readFile, writeFile, filter, catch ) -import Storage.Hashed.Utils -import Storage.Hashed.Tree -import Storage.Hashed.AnchoredPath -import Data.Int( Int64, Int32 ) - -import Bundled.Posix( getFileStatusBS, modificationTime, - getFileStatus, fileSize, fileExists, isDirectory ) -import System.IO.MMap( mmapFileForeignPtr, mmapFileByteString, Mode(..) ) -import System.IO( ) -import System.Directory( doesFileExist, getCurrentDirectory, doesDirectoryExist ) -#if mingw32_HOST_OS -import System.Directory( renameFile ) -import System.FilePath( (<.>) ) -#else -import System.Directory( removeFile ) -#endif -import System.FilePath( () ) -import System.Posix.Types ( FileID ) - -import Control.Monad( when ) -import Control.Exception( catch, SomeException ) -import Control.Applicative( (<$>) ) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import Data.ByteString.Unsafe( unsafeHead, unsafeDrop ) -import Data.ByteString.Internal( toForeignPtr, fromForeignPtr, memcpy - , nullForeignPtr, c2w ) - -import Data.IORef( ) -import Data.Maybe( fromJust, isJust, fromMaybe ) -import Data.Bits( Bits ) - -import Foreign.Storable -import Foreign.ForeignPtr -import Foreign.Ptr - -import Storage.Hashed.Hash( sha256, rawHash ) -#ifdef WIN32 -import System.Win32.File ( createFile, getFileInformationByHandle, BY_HANDLE_FILE_INFORMATION(..), - fILE_SHARE_NONE, fILE_FLAG_BACKUP_SEMANTICS, - gENERIC_NONE, oPEN_EXISTING, closeHandle ) -#else -import System.PosixCompat ( fileID, getSymbolicLinkStatus ) -#endif - --------------------------- --- Indexed trees --- - --- | Description of a a single indexed item. The structure itself does not --- contain any data, just pointers to the underlying mmap (bytestring is a --- pointer + offset + length). --- --- The structure is recursive-ish (as opposed to flat-ish structure, which is --- used by git...) It turns out that it's hard to efficiently read a flat index --- with our internal data structures -- we need to turn the flat index into a --- recursive Tree object, which is rather expensive... As a bonus, we can also --- efficiently implement subtree queries this way (cf. 'readIndex'). -data Item = Item { iBase :: !(Ptr ()) - , iHashAndDescriptor :: !BS.ByteString - } deriving Show - -size_magic :: Int -size_magic = 4 -- the magic word, first 4 bytes of the index - -size_dsclen, size_hash, size_size, size_aux, size_fileid :: Int -size_size = 8 -- file/directory size (Int64) -size_aux = 8 -- aux (Int64) -size_fileid = 8 -- fileid (inode or fhandle FileID) -size_dsclen = 4 -- this many bytes store the length of the path -size_hash = 32 -- hash representation - -off_size, off_aux, off_hash, off_dsc, off_dsclen, off_fileid :: Int -off_size = 0 -off_aux = off_size + size_size -off_fileid = off_aux + size_aux -off_dsclen = off_fileid + size_fileid -off_hash = off_dsclen + size_dsclen -off_dsc = off_hash + size_hash - -itemAllocSize :: AnchoredPath -> Int -itemAllocSize apath = - align 4 $ size_hash + size_size + size_aux + size_fileid + size_dsclen + 2 + BS.length (flatten apath) - -itemSize, itemNext :: Item -> Int -itemSize i = size_size + size_aux + size_fileid + size_dsclen + (BS.length $ iHashAndDescriptor i) -itemNext i = align 4 (itemSize i + 1) - -iPath, iHash, iDescriptor :: Item -> BS.ByteString -iDescriptor = unsafeDrop size_hash . iHashAndDescriptor -iPath = unsafeDrop 1 . iDescriptor -iHash = BS.take size_hash . iHashAndDescriptor - -iSize, iAux :: Item -> Ptr Int64 -iSize i = plusPtr (iBase i) off_size -iAux i = plusPtr (iBase i) off_aux - -iFileID :: Item -> Ptr FileID -iFileID i = plusPtr (iBase i) off_fileid - -itemIsDir :: Item -> Bool -itemIsDir i = unsafeHead (iDescriptor i) == c2w 'D' - --- xlatePeek32 = fmap xlate32 . peek -xlatePeek64 :: (Storable a, Num a, Bits a) => Ptr a -> IO a -xlatePeek64 = fmap xlate64 . peek - --- xlatePoke32 ptr v = poke ptr (xlate32 v) -xlatePoke64 :: (Storable a, Num a, Bits a) => Ptr a -> a -> IO () -xlatePoke64 ptr v = poke ptr (xlate64 v) - --- | Lay out the basic index item structure in memory. The memory location is --- given by a ForeignPointer () and an offset. The path and type given are --- written out, and a corresponding Item is given back. The remaining bits of --- the item can be filled out using 'update'. -createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item -createItem typ apath fp off = - do let dsc = BS.concat [ BSC.singleton $ if typ == TreeType then 'D' else 'F' - , flatten apath - , BS.singleton 0 ] - (dsc_fp, dsc_start, dsc_len) = toForeignPtr dsc - withForeignPtr fp $ \p -> - withForeignPtr dsc_fp $ \dsc_p -> - do fileid <- fromMaybe 0 <$> getFileID apath - pokeByteOff p (off + off_fileid) (xlate64 $ fromIntegral fileid :: Int64) - pokeByteOff p (off + off_dsclen) (xlate32 $ fromIntegral dsc_len :: Int32) - memcpy (plusPtr p $ off + off_dsc) - (plusPtr dsc_p dsc_start) - (fromIntegral dsc_len) - peekItem fp off - --- | Read the on-disk representation into internal data structure. --- --- See the module-level section /Index format/ for details on how the index --- is structured. -peekItem :: ForeignPtr () -> Int -> IO Item -peekItem fp off = - withForeignPtr fp $ \p -> do - nl' :: Int32 <- xlate32 `fmap` peekByteOff p (off + off_dsclen) - when (nl' <= 2) $ fail "Descriptor too short in peekItem!" - let nl = fromIntegral nl' - dsc = fromForeignPtr (castForeignPtr fp) (off + off_hash) (size_hash + nl - 1) - return $! Item { iBase = plusPtr p off - , iHashAndDescriptor = dsc } - --- | Update an existing item with new hash and optionally mtime (give Nothing --- when updating directory entries). -updateItem :: Item -> Int64 -> Hash -> IO () -updateItem item _ NoHash = - fail $ "Index.update NoHash: " ++ BSC.unpack (iPath item) -updateItem item size hash = - do xlatePoke64 (iSize item) size - unsafePokeBS (iHash item) (rawHash hash) - -updateFileID :: Item -> FileID -> IO () -updateFileID item fileid = xlatePoke64 (iFileID item) $ fromIntegral fileid -updateAux :: Item -> Int64 -> IO () -updateAux item aux = xlatePoke64 (iAux item) $ aux -updateTime :: forall a.(Enum a) => Item -> a -> IO () -updateTime item mtime = updateAux item (fromIntegral $ fromEnum mtime) - -iHash' :: Item -> Hash -iHash' i = SHA256 (iHash i) - --- | Gives a ForeignPtr to mmapped index, which can be used for reading and --- updates. The req_size parameter, if non-0, expresses the requested size of --- the index file. mmapIndex will grow the index if it is smaller than this. -mmapIndex :: forall a. FilePath -> Int -> IO (ForeignPtr a, Int) -mmapIndex indexpath req_size = do - exist <- doesFileExist indexpath - act_size <- fromIntegral `fmap` if exist then fileSize `fmap` getFileStatus indexpath - else return 0 - let size = case req_size > 0 of - True -> req_size - False | act_size >= size_magic -> act_size - size_magic - | otherwise -> 0 - case size of - 0 -> return (castForeignPtr nullForeignPtr, size) - _ -> do (x, _, _) <- mmapFileForeignPtr indexpath - ReadWriteEx (Just (0, size + size_magic)) - return (x, size) - -data IndexM m = Index { mmap :: (ForeignPtr ()) - , basedir :: FilePath - , hashtree :: Tree m -> Hash - , predicate :: AnchoredPath -> TreeItem m -> Bool } - | EmptyIndex - -type Index = IndexM IO - -data State = State { dirlength :: !Int - , path :: !AnchoredPath - , start :: !Int } - -data Result = Result { -- | marks if the item has changed since the last update to the index - changed :: !Bool - -- | next is the position of the next item, in bytes. - , next :: !Int - -- | treeitem is Nothing in case of the item doesn't exist in the tree - -- or is filtered by a FilterTree. Or a TreeItem otherwise. - , treeitem :: !(Maybe (TreeItem IO)) - -- | resitem is the item extracted. - , resitem :: !Item } - -data ResultF = ResultF { -- | nextF is the position of the next item, in bytes. - nextF :: !Int - -- | resitemF is the item extracted. - , resitemF :: !Item - -- | _fileIDs contains the fileids of the files and folders inside, - -- in a folder item and its own fileid for file item). - , _fileIDs :: [((AnchoredPath, ItemType), FileID)] } - -readItem :: Index -> State -> IO Result -readItem index state = do - item <- peekItem (mmap index) (start state) - res' <- if itemIsDir item - then readDir index state item - else readFile index state item - return res' - -readDir :: Index -> State -> Item -> IO Result -readDir index state item = - do following <- fromIntegral <$> xlatePeek64 (iAux item) - st <- getFileStatusBS (iPath item) - let exists = fileExists st && isDirectory st - fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item) - fileid' <- fromMaybe fileid <$> (getFileID' $ BSC.unpack $ iPath item) - when (fileid == 0) $ updateFileID item fileid' - let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC - namelength = (BS.length $ iDescriptor item) - (dirlength state) - myname = name item (dirlength state) - substate = state { start = start state + itemNext item - , path = path state `appendPath` myname - , dirlength = if myname == Name (BSC.singleton '.') - then dirlength state - else dirlength state + namelength } - - want = exists && (predicate index) (path substate) (Stub undefined NoHash) - oldhash = iHash' item - - subs off | off < following = do - result <- readItem index $ substate { start = off } - rest <- subs $ next result - return $! (name (resitem result) $ dirlength substate, result) : rest - subs coff | coff == following = return [] - | otherwise = fail $ "Offset mismatch at " ++ show coff ++ - " (ends at " ++ show following ++ ")" - - inferiors <- if want then subs $ start substate - else return [] - - let we_changed = or [ changed x | (_, x) <- inferiors ] || nullleaf - nullleaf = null inferiors && oldhash == nullsha - nullsha = SHA256 (BS.replicate 32 0) - tree' = makeTree [ (n, fromJust $ treeitem s) | (n, s) <- inferiors, isJust $ treeitem s ] - treehash = if we_changed then hashtree index tree' else oldhash - tree = tree' { treeHash = treehash } - - when (exists && we_changed) $ updateItem item 0 treehash - return $ Result { changed = not exists || we_changed - , next = following - , treeitem = if want then Just $ SubTree tree - else Nothing - , resitem = item } - -readFile :: Index -> State -> Item -> IO Result -readFile index state item = - do st <- getFileStatusBS (iPath item) - mtime <- fromIntegral <$> (xlatePeek64 $ iAux item) - size <- xlatePeek64 $ iSize item - fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item) - fileid' <- fromMaybe fileid <$> (getFileID' $ BSC.unpack $ iPath item) - let mtime' = modificationTime st - size' = fromIntegral $ fileSize st - readblob = readSegment (basedir index BSC.unpack (iPath item), Nothing) - exists = fileExists st && not (isDirectory st) - we_changed = mtime /= mtime' || size /= size' - hash = iHash' item - when (exists && we_changed) $ - do hash' <- sha256 `fmap` readblob - updateItem item size' hash' - updateTime item mtime' - when (fileid == 0) $ updateFileID item fileid' - return $ Result { changed = not exists || we_changed - , next = start state + itemNext item - , treeitem = if exists then Just $ File $ Blob readblob hash else Nothing - , resitem = item } - -updateIndex :: Index -> IO (Tree IO) -updateIndex EmptyIndex = return emptyTree -updateIndex index = - do let initial = State { start = size_magic - , dirlength = 0 - , path = AnchoredPath [] } - res <- readItem index initial - case treeitem res of - Just (SubTree tree) -> return $ filter (predicate index) tree - _ -> fail "Unexpected failure in updateIndex!" - --- | Return a list containing all the file/folder names in an index, with --- their respective ItemType and FileID. -listFileIDs :: Index -> IO ([((AnchoredPath, ItemType), FileID)]) -listFileIDs EmptyIndex = return [] -listFileIDs index = - do let initial = State { start = size_magic - , dirlength = 0 - , path = AnchoredPath [] } - res <- readItemFileIDs index initial - return $ _fileIDs res - -readItemFileIDs :: Index -> State -> IO ResultF -readItemFileIDs index state = do - item <- peekItem (mmap index) (start state) - res' <- if itemIsDir item - then readDirFileIDs index state item - else readFileFileID index state item - return res' - -readDirFileIDs :: Index -> State -> Item -> IO ResultF -readDirFileIDs index state item = - do fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item) - following <- fromIntegral <$> xlatePeek64 (iAux item) - let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC - namelength = (BS.length $ iDescriptor item) - (dirlength state) - myname = name item (dirlength state) - substate = state { start = start state + itemNext item - , path = path state `appendPath` myname - , dirlength = if myname == Name (BSC.singleton '.') - then dirlength state - else dirlength state + namelength } - subs off | off < following = do - result <- readItemFileIDs index $ substate { start = off } - rest <- subs $ nextF result - return $! (name (resitemF result) $ dirlength substate, result) : rest - subs coff | coff == following = return [] - | otherwise = fail $ "Offset mismatch at " ++ show coff ++ - " (ends at " ++ show following ++ ")" - inferiors <- subs $ start substate - return $ ResultF { nextF = following - , resitemF = item - , _fileIDs = (((path substate, TreeType), fileid):concatMap (_fileIDs . snd) inferiors) } - -readFileFileID :: Index -> State -> Item -> IO ResultF -readFileFileID _ state item = - do fileid' <- fromIntegral <$> (xlatePeek64 $ iFileID item) - let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) - myname = name item (dirlength state) - return $ ResultF { nextF = start state + itemNext item - , resitemF = item - , _fileIDs = [((path state `appendPath` myname, BlobType), fileid')] } - - --- | Read an index and build up a 'Tree' object from it, referring to current --- working directory. The initial Index object returned by readIndex is not --- directly useful. However, you can use 'Tree.filter' on it. Either way, to --- obtain the actual Tree object, call update. --- --- The usual use pattern is this: --- --- > do (idx, update) <- readIndex --- > tree <- update =<< filter predicate idx --- --- The resulting tree will be fully expanded. -readIndex :: FilePath -> (Tree IO -> Hash) -> IO Index -readIndex indexpath ht = do - (mmap_ptr, mmap_size) <- mmapIndex indexpath 0 - base <- getCurrentDirectory - return $ if mmap_size == 0 then EmptyIndex - else Index { mmap = mmap_ptr - , basedir = base - , hashtree = ht - , predicate = \_ _ -> True } - -formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO () -formatIndex mmap_ptr old reference = - do _ <- create (SubTree reference) (AnchoredPath []) size_magic - unsafePokeBS magic (BSC.pack "HSI5") - where magic = fromForeignPtr (castForeignPtr mmap_ptr) 0 4 - create (File _) path' off = - do i <- createItem BlobType path' mmap_ptr off - let flatpath = BSC.unpack $ flatten path' - case find old path' of - Nothing -> return () - -- TODO calling getFileStatus here is both slightly - -- inefficient and slightly race-prone - Just ti -> do st <- getFileStatus flatpath - let hash = itemHash ti - mtime = modificationTime st - size = fileSize st - updateItem i (fromIntegral size) hash - updateTime i mtime - return $ off + itemNext i - create (SubTree s) path' off = - do i <- createItem TreeType path' mmap_ptr off - case find old path' of - Nothing -> return () - Just ti | itemHash ti == NoHash -> return () - | otherwise -> updateItem i 0 $ itemHash ti - let subs [] = return $ off + itemNext i - subs ((name,x):xs) = do - let path'' = path' `appendPath` name - noff <- subs xs - create x path'' noff - lastOff <- subs (listImmediate s) - xlatePoke64 (iAux i) (fromIntegral lastOff) - return lastOff - create (Stub _ _) path' _ = - fail $ "Cannot create index from stubbed Tree at " ++ show path' - --- | Will add and remove files in index to make it match the 'Tree' object --- given (it is an error for the 'Tree' to contain a file or directory that --- does not exist in a plain form in current working directory). -updateIndexFrom :: FilePath -> (Tree IO -> Hash) -> Tree IO -> IO Index -updateIndexFrom indexpath hashtree' ref = - do old_idx <- updateIndex =<< readIndex indexpath hashtree' - reference <- expand ref - let len_root = itemAllocSize anchoredRoot - len = len_root + sum [ itemAllocSize p | (p, _) <- list reference ] - exist <- doesFileExist indexpath -#if mingw32_HOST_OS - when exist $ renameFile indexpath (indexpath <.> "old") -#else - when exist $ removeFile indexpath -- to avoid clobbering oldidx -#endif - (mmap_ptr, _) <- mmapIndex indexpath len - formatIndex mmap_ptr old_idx reference - readIndex indexpath hashtree' - --- | Check that a given file is an index file with a format we can handle. You --- should remove and re-create the index whenever this is not true. -indexFormatValid :: FilePath -> IO Bool -indexFormatValid path' = - do magic <- mmapFileByteString path' (Just (0, size_magic)) - return $ case BSC.unpack magic of - "HSI5" -> True - _ -> False - `catch` \(_::SomeException) -> return False - -instance FilterTree IndexM IO where - filter _ EmptyIndex = EmptyIndex - filter p index = index { predicate = \a b -> predicate index a b && p a b } - - --- | For a given file or folder path, get the corresponding fileID from the --- filesystem. -getFileID :: AnchoredPath -> IO (Maybe FileID) -getFileID = getFileID' . anchorPath "" - -getFileID' :: FilePath -> IO (Maybe FileID) -getFileID' fp = do file_exists <- doesFileExist fp - dir_exists <- doesDirectoryExist fp - if file_exists || dir_exists -#ifdef WIN32 - then do h <- createFile fp gENERIC_NONE fILE_SHARE_NONE Nothing oPEN_EXISTING fILE_FLAG_BACKUP_SEMANTICS Nothing - fhnumber <- (Just . fromIntegral . bhfiFileIndex) <$> getFileInformationByHandle h - closeHandle h - return fhnumber -#else - then (Just . fileID) <$> getSymbolicLinkStatus fp -#endif - else return Nothing diff --git a/hashed-storage/Storage/Hashed/Monad.hs b/hashed-storage/Storage/Hashed/Monad.hs deleted file mode 100644 --- a/hashed-storage/Storage/Hashed/Monad.hs +++ /dev/null @@ -1,277 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns, TypeSynonymInstances, UndecidableInstances, FlexibleInstances #-} - --- | An experimental monadic interface to Tree mutation. The main idea is to --- simulate IO-ish manipulation of real filesystem (that's the state part of --- the monad), and to keep memory usage down by reasonably often dumping the --- intermediate data to disk and forgetting it. The monad interface itself is --- generic, and a number of actual implementations can be used. This module --- provides just 'virtualTreeIO' that never writes any changes, but may trigger --- filesystem reads as appropriate. -module Storage.Hashed.Monad - ( virtualTreeIO, virtualTreeMonad - , readFile, writeFile, createDirectory, rename, copy, unlink - , fileExists, directoryExists, exists, withDirectory - , currentDirectory - , tree, TreeState, TreeMonad, TreeIO, runTreeMonad - , initialState, replaceItem - , findM, findFileM, findTreeM - , TreeRO, TreeRW - ) where - -import Prelude hiding ( readFile, writeFile ) - -import Storage.Hashed.AnchoredPath -import Storage.Hashed.Tree - -import Control.Applicative( (<$>) ) - -import Data.List( sortBy ) -import Data.Int( Int64 ) -import Data.Maybe( isNothing, isJust ) - -import qualified Data.ByteString.Lazy.Char8 as BL -import Control.Monad.RWS.Strict -import qualified Data.Map as M - -type Changed = M.Map AnchoredPath (Int64, Int64) -- size, age - --- | Internal state of the 'TreeIO' monad. Keeps track of the current Tree --- content, unsync'd changes and a current working directory (of the monad). -data TreeState m = TreeState { tree :: !(Tree m) - , changed :: !Changed - , changesize :: !Int64 - , maxage :: !Int64 - , updateHash :: TreeItem m -> m Hash - , update :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m) } - --- | A 'TreeIO' monad. A sort of like IO but it keeps a 'TreeState' around as well, --- which is a sort of virtual filesystem. Depending on how you obtained your --- 'TreeIO', the actions in your virtual filesystem get somehow reflected in the --- actual real filesystem. For 'virtualTreeIO', nothing happens in real --- filesystem, however with 'plainTreeIO', the plain tree will be updated every --- now and then, and with 'hashedTreeIO' a darcs-style hashed tree will get --- updated. -type TreeMonad m = RWST AnchoredPath () (TreeState m) m -type TreeIO = TreeMonad IO - -class (Functor m, Monad m) => TreeRO m where - currentDirectory :: m AnchoredPath - withDirectory :: AnchoredPath -> m a -> m a - expandTo :: AnchoredPath -> m AnchoredPath - -- | Grab content of a file in the current Tree at the given path. - readFile :: AnchoredPath -> m BL.ByteString - -- | Check for existence of a node (file or directory, doesn't matter). - exists :: AnchoredPath -> m Bool - -- | Check for existence of a directory. - directoryExists ::AnchoredPath -> m Bool - -- | Check for existence of a file. - fileExists :: AnchoredPath -> m Bool - -class TreeRO m => TreeRW m where - -- | Change content of a file at a given path. The change will be - -- eventually flushed to disk, but might be buffered for some time. - writeFile :: AnchoredPath -> BL.ByteString -> m () - createDirectory :: AnchoredPath -> m () - unlink :: AnchoredPath -> m () - rename :: AnchoredPath -> AnchoredPath -> m () - copy :: AnchoredPath -> AnchoredPath -> m () - -initialState :: Tree m -> (TreeItem m -> m Hash) - -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)) -> TreeState m -initialState t uh u = TreeState { tree = t - , changed = M.empty - , changesize = 0 - , updateHash = uh - , maxage = 0 - , update = u } - -flush :: (Functor m, Monad m) => TreeMonad m () -flush = do changed' <- map fst <$> M.toList <$> gets changed - dirs' <- gets tree >>= \t -> return [ path | (path, SubTree _) <- list t ] - modify $ \st -> st { changed = M.empty, changesize = 0 } - forM_ (changed' ++ dirs' ++ [AnchoredPath []]) flushItem - -runTreeMonad' :: (Functor m, Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m) -runTreeMonad' action initial = do - (out, final, _) <- runRWST action (AnchoredPath []) initial - return (out, tree final) - -runTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m) -runTreeMonad action initial = do - let action' = do x <- action - flush - return x - runTreeMonad' action' initial - --- | Run a TreeIO action without storing any changes. This is useful for --- running monadic tree mutations for obtaining the resulting Tree (as opposed --- to their effect of writing a modified tree to disk). The actions can do both --- read and write -- reads are passed through to the actual filesystem, but the --- writes are held in memory in a form of modified Tree. -virtualTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m) -virtualTreeMonad action t = runTreeMonad' action $ - initialState t (\_ -> return NoHash) (\_ x -> return x) - -virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO) -virtualTreeIO = virtualTreeMonad - --- | Modifies an item in the current Tree. This action keeps an account of the --- modified data, in changed and changesize, for subsequent flush --- operations. Any modifications (as in "modifyTree") are allowed. -modifyItem :: (Functor m, Monad m) - => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m () -modifyItem path item = do - path' <- (`catPaths` path) `fmap` currentDirectory - age <- gets maxage - changed' <- gets changed - let getsize (Just (File b)) = lift (BL.length `fmap` readBlob b) - getsize _ = return 0 - size <- getsize item - let change = case M.lookup path' changed' of - Nothing -> size - Just (oldsize, _) -> size - oldsize - - modify $ \st -> st { tree = modifyTree (tree st) path' item - , changed = M.insert path' (size, age) (changed st) - , maxage = age + 1 - , changesize = (changesize st + change) } - -renameChanged :: (Functor m, Monad m) - => AnchoredPath -> AnchoredPath -> TreeMonad m () -renameChanged from to = modify $ \st -> st { changed = rename' $ changed st } - where rename' = M.fromList . map renameone . M.toList - renameone (x, d) | from `isPrefix` x = (to `catPaths` relative from x, d) - | otherwise = (x, d) - relative (AnchoredPath from') (AnchoredPath x) = AnchoredPath $ drop (length from') x - --- | Replace an item with a new version without modifying the content of the --- tree. This does not do any change tracking. Ought to be only used from a --- 'sync' implementation for a particular storage format. The presumed use-case --- is that an existing in-memory Blob is replaced with a one referring to an --- on-disk file. -replaceItem :: (Functor m, Monad m) - => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m () -replaceItem path item = do - path' <- (`catPaths` path) `fmap` currentDirectory - modify $ \st -> st { tree = modifyTree (tree st) path' item } - -flushItem :: forall m. (Monad m, Functor m) => AnchoredPath -> TreeMonad m () -flushItem path = - do current <- gets tree - case find current path of - Nothing -> return () -- vanished, do nothing - Just x -> do y <- fixHash x - new <- gets update >>= ($ y) . ($ path) - replaceItem path (Just new) - where fixHash :: TreeItem m -> TreeMonad m (TreeItem m) - fixHash f@(File (Blob con NoHash)) = do - hash <- gets updateHash >>= \x -> lift $ x f - return $ File $ Blob con hash - fixHash (SubTree s) | treeHash s == NoHash = - gets updateHash >>= \f -> SubTree <$> lift (addMissingHashes f s) - fixHash x = return x - - --- | If buffers are becoming large, sync, otherwise do nothing. -flushSome :: (Monad m, Functor m) => TreeMonad m () -flushSome = do x <- gets changesize - when (x > megs 100) $ do - remaining <- go =<< sortBy age <$> M.toList <$> gets changed - modify $ \s -> s { changed = M.fromList remaining } - where go [] = return [] - go ((path, (size, _)):chs) = do - x <- (\s -> s - size) <$> gets changesize - flushItem path - modify $ \s -> s { changesize = x } - if (x > megs 50) then go chs - else return $ chs - megs = (* (1024 * 1024)) - age (_, (_, a)) (_, (_, b)) = compare a b - -instance (Functor m, Monad m) => TreeRO (TreeMonad m) where - expandTo p = - do t <- gets tree - p' <- (`catPaths` p) `fmap` ask - t' <- lift $ expandPath t p' - modify $ \st -> st { tree = t' } - return p' - - fileExists p = - do p' <- expandTo p - (isJust . (flip findFile p')) `fmap` gets tree - - directoryExists p = - do p' <- expandTo p - (isJust . (flip findTree p')) `fmap` gets tree - - exists p = - do p' <- expandTo p - (isJust . (flip find p')) `fmap` gets tree - - readFile p = - do p' <- expandTo p - t <- gets tree - let f = findFile t p' - case f of - Nothing -> fail $ "No such file " ++ show p' - Just x -> lift (readBlob x) - - currentDirectory = ask - withDirectory dir act = do - dir' <- expandTo dir - local (\_ -> dir') act - -instance (Functor m, Monad m) => TreeRW (TreeMonad m) where - writeFile p con = - do _ <- expandTo p - modifyItem p (Just blob) - flushSome - where blob = File $ Blob (return con) hash - hash = NoHash -- we would like to say "sha256 con" here, but due - -- to strictness of Hash in Blob, this would often - -- lead to unnecessary computation which would then - -- be discarded anyway; we rely on the sync - -- implementation to fix up any NoHash occurrences - - createDirectory p = - do _ <- expandTo p - modifyItem p $ Just $ SubTree emptyTree - - unlink p = - do _ <- expandTo p - modifyItem p Nothing - - rename from to = - do from' <- expandTo from - to' <- expandTo to - tr <- gets tree - let item = find tr from' - found_to = find tr to' - unless (isNothing found_to) $ - fail $ "Error renaming: destination " ++ show to ++ " exists." - unless (isNothing item) $ do - modifyItem from Nothing - modifyItem to item - renameChanged from to - - copy from to = - do from' <- expandTo from - _ <- expandTo to - tr <- gets tree - let item = find tr from' - unless (isNothing item) $ modifyItem to item - -findM' :: forall m a. (Monad m, Functor m) - => (Tree m -> AnchoredPath -> a) -> Tree m -> AnchoredPath -> m a -findM' what t path = fst <$> virtualTreeMonad (look path) t - where look :: AnchoredPath -> TreeMonad m a - look = expandTo >=> \p' -> flip what p' <$> gets tree - -findM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (TreeItem m)) -findM = findM' find - -findTreeM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (Tree m)) -findTreeM = findM' findTree - -findFileM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (Blob m)) -findFileM = findM' findFile diff --git a/hashed-storage/Storage/Hashed/Packed.hs b/hashed-storage/Storage/Hashed/Packed.hs deleted file mode 100644 --- a/hashed-storage/Storage/Hashed/Packed.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} --- | This module implements an "object storage". This is a directory on disk --- containing a content-addressed storage. This is useful for storing all kinds --- of things, particularly filesystem trees, or darcs pristine caches and patch --- objects. However, this is an abstract, flat storage: no tree semantics are --- provided. You just need to provide a reference-collecting functionality, --- computing a list of references for any given object. The system provides --- transparent garbage collection and packing. -module Storage.Hashed.Packed - ( Format(..), Block, OS - -- * Basic operations. - , hatch, compact, repack, lookup - -- * Creating and loading. - , create, load - -- * Low-level. - , format, blockLookup, live, hatchery, mature, roots, references, rootdir - ) where - -import Prelude hiding ( lookup, read ) -import Storage.Hashed.AnchoredPath( ) -import Storage.Hashed.Tree ( ) -import Storage.Hashed.Utils -import Storage.Hashed.Hash - -import Control.Monad( forM, forM_, unless ) -import Control.Applicative( (<$>) ) -import System.FilePath( (), (<.>) ) -import System.Directory( createDirectoryIfMissing, removeFile - , getDirectoryContents ) - -import Bundled.Posix( fileExists, isDirectory, getFileStatus ) - -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.ByteString.Char8 as BS -import Data.Maybe( listToMaybe, catMaybes, isNothing ) -import Data.Binary( encode, decode ) - -import qualified Data.Set as S -import qualified Data.Map as M -import Data.List( sort ) -import Data.Int( Int64 ) - --- | On-disk format for object storage: we implement a completely loose format --- (one file per object), a compact format stored in a single append-only file --- and an immutable \"pack\" format. -data Format = Loose | Compact | Pack deriving (Show, Eq) - -loose_dirs :: [[Char]] -loose_dirs = let chars = ['0'..'9'] ++ ['a'..'f'] - in [ [a,b] | a <- chars, b <- chars ] - -loosePath :: OS -> Hash -> FilePath -loosePath _ NoHash = error "No path for NoHash!" -loosePath os hash = - let hash' = BS.unpack (encodeBase16 hash) - in rootdir os "hatchery" take 2 hash' drop 2 hash' - -looseLookup :: OS -> Hash -> IO (Maybe FileSegment) -looseLookup _ NoHash = return Nothing -looseLookup os hash = do - let path = loosePath os hash - exist <- fileExists <$> getFileStatus path - return $ if exist then Just (path, Nothing) - else Nothing - --- | Object storage block. When used as a hatchery, the loose or compact format --- are preferable, while for mature space, the pack format is more useful. -data Block = Block { blockLookup :: Hash -> IO (Maybe FileSegment) - , size :: Int64 - , format :: Format } - --- | Object storage. Contains a single \"hatchery\" and possibly a number of --- mature space blocks, usually in form of packs. It also keeps a list of root --- pointers and has a way to extract pointers from objects (externally --- supplied). These last two things are used to implement a simple GC. -data OS = OS { hatchery :: Block - , mature :: [Block] - , roots :: [Hash] - , references :: FileSegment -> IO [Hash] - , rootdir :: FilePath } - --- | Reduce number of packs in the object storage. This may both recombine --- packs to eliminate dead objects and join some packs to form bigger packs. -repack :: OS -> IO OS -repack _ = error "repack undefined" - --- | Add new objects to the object storage (i.e. put them into hatchery). It is --- safe to call this even on objects that are already present in the storage: --- such objects will be skipped. -hatch :: OS -> [BL.ByteString] -> IO OS -hatch os blobs = - do processed <- mapM sieve blobs - write [ (h, b) | (True, h, b) <- processed ] - where write bits = - case format (hatchery os) of - Loose -> - do _ <- forM bits $ \(hash, blob) -> do - BL.writeFile (loosePath os hash) blob - return os - Compact -> error "hatch/compact undefined" - _ -> fail "Hatchery must be either Loose or Compact." - sieve blob = do let hash = sha256 blob - absent <- isNothing <$> lookup os hash - return (absent, hash, blob) - --- | Move things from hatchery into a (new) pack. -compact :: OS -> IO OS -compact os = do objects <- live os [hatchery os] - block <- createPack os (M.toList objects) - cleanup - return $ os { mature = block:mature os } - where cleanup = - case format (hatchery os) of - Loose -> forM_ loose_dirs $ nuke . ((rootdir os "hatchery") ) - Compact -> removeFile (rootdir os "hatchery") >> return () - _ -> fail "Hatchery must be either Loose or Compact." - nuke dir = mapM (removeFile . (dir )) =<< - (Prelude.filter (`notElem` [".", ".."]) `fmap` - getDirectoryContents dir) - -blocksLookup :: [Block] -> Hash -> IO (Maybe (Hash, FileSegment)) -blocksLookup blocks hash = - do segment <- cat `fmap` mapM (flip blockLookup hash) blocks - return $ case segment of - Nothing -> Nothing - Just seg -> Just (hash, seg) - where cat = listToMaybe . catMaybes - -lookup :: OS -> Hash -> IO (Maybe FileSegment) -lookup os hash = - do res <- blocksLookup (hatchery os : mature os) hash - return $ case res of - Nothing -> Nothing - Just (_, seg) -> Just seg - --- | Create an empty object storage in given directory, with a hatchery of --- given format. The directory is created if needed, but is assumed to be --- empty. -create :: FilePath -> Format -> IO OS -create path fmt = do createDirectoryIfMissing True path - _ <- initHatchery - load path - where initHatchery | fmt == Loose = - do mkdir hatchpath - forM loose_dirs $ mkdir . (hatchpath ) - | fmt == Compact = - error "create/mkHatchery Compact undefined" - | otherwise = - error "create/mkHatchery Pack undefined" - mkdir = createDirectoryIfMissing False - hatchpath = path "hatchery" - -load :: FilePath -> IO OS -load path = - do hatch_stat <- getFileStatus $ path "hatchery" - let is_os = fileExists hatch_stat - is_dir = isDirectory hatch_stat - unless is_os $ fail $ path ++ " is not an object storage!" - let _hatchery = Block { blockLookup = look os - , format = if is_dir then Loose else Compact - , size = undefined } - os = OS { hatchery = _hatchery - , rootdir = path - , mature = packs - , roots = _roots - , references = undefined } - look | format _hatchery == Loose = looseLookup - | otherwise = undefined - packs = [] -- FIXME read packs - _roots = [] -- FIXME read root pointers - return os - -readPack :: FilePath -> IO Block -readPack file = do bits <- readSegment (file, Nothing) - let count = decode (BL.take 8 $ bits) - _lookup NoHash _ _ = return Nothing - _lookup hash first final = do - let middle = first + ((final - first) `div` 2) - rawhash = rawHash hash - res <- case ( compare rawhash (hashof first) - , compare rawhash (hashof middle) - , compare rawhash (hashof final) ) of - (LT, _, _) -> return Nothing - ( _, _, GT) -> return Nothing - (EQ, _, _) -> return $ Just (segof first) - ( _, _, EQ) -> return $ Just (segof final) - (GT, EQ, LT) -> return $ Just (segof middle) - (GT, GT, LT) | middle /= final -> _lookup hash middle final - (GT, LT, LT) | first /= middle -> _lookup hash first middle - ( _, _, _) -> return Nothing - return res - headerof i = BL.take 51 $ BL.drop (8 + i * 51) bits - hashof i = BS.concat $ BL.toChunks $ BL.take 32 $ headerof i - segof i = (file, Just (count * 51 + 8 + from, sz)) - where from = decode (BL.take 8 $ BL.drop 33 $ headerof i) - sz = decode (BL.take 8 $ BL.drop 42 $ headerof i) - return $ Block { size = BL.length bits - , format = Pack - , blockLookup = \h -> _lookup h 0 (count - 1) } - -createPack :: OS -> [(Hash, FileSegment)] -> IO Block -createPack os bits = - do contents <- mapM readSegment (map snd bits) - let offsets = scanl (+) 0 $ map BL.length contents - headerbits = [ BL.concat [ BL.fromChunks [rawhash] - , BL.pack "@" - , encode offset - , BL.pack "!" - , encode $ BL.length string - , BL.pack "\n" ] - | (SHA256 rawhash, _) <- bits - | string <- contents - | offset <- offsets ] - header = BL.concat $ (encode $ length bits) : sort headerbits - blob = BL.concat $ header:contents - hash = sha256 blob - path = rootdir os BS.unpack (encodeBase16 hash) <.> "bin" - BL.writeFile path blob - readPack path - --- | Build a map of live objects (i.e. those reachable from the given roots) in --- a given list of Blocks. -live :: OS -> [Block] -> IO (M.Map Hash FileSegment) -live os blocks = - reachable (references os) - (blocksLookup blocks) - (S.fromList $ roots os) diff --git a/hashed-storage/Storage/Hashed/Plain.hs b/hashed-storage/Storage/Hashed/Plain.hs deleted file mode 100644 --- a/hashed-storage/Storage/Hashed/Plain.hs +++ /dev/null @@ -1,78 +0,0 @@ --- | The plain format implementation resides in this module. The plain format --- does not use any hashing and basically just wraps a normal filesystem tree --- in the hashed-storage API. --- --- NB. The 'read' function on Blobs coming from a plain tree is susceptible to --- file content changes. Since we use mmap in 'read', this will break --- referential transparency and produce unexpected results. Please always make --- sure that all parallel access to the underlying filesystem tree never --- mutates files. Unlink + recreate is fine though (in other words, the --- 'writePlainTree' and 'plainTreeIO' implemented in this module are safe in --- this respect). -module Storage.Hashed.Plain( readPlainTree, writePlainTree, - plainTreeIO -- (obsolete? if so remove implementation!) - ) where - -import Data.Maybe( catMaybes ) -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BL -import System.FilePath( () ) -import System.Directory( getDirectoryContents - , createDirectoryIfMissing ) -import Bundled.Posix( getFileStatus, isDirectory, isRegularFile, FileStatus ) - -import Storage.Hashed.AnchoredPath -import Storage.Hashed.Utils -import Storage.Hashed.Hash( Hash( NoHash) ) -import Storage.Hashed.Tree( Tree(), TreeItem(..) - , Blob(..), makeTree - , list, readBlob, expand ) -import Storage.Hashed.Monad( TreeIO, runTreeMonad, initialState ) -import Control.Monad.State( liftIO ) - -readPlainDir :: FilePath -> IO [(FilePath, FileStatus)] -readPlainDir dir = - withCurrentDirectory dir $ do - items <- getDirectoryContents "." - sequence [ do st <- getFileStatus s - return (s, st) - | s <- items, s `notElem` [ ".", ".." ] ] - -readPlainTree :: FilePath -> IO (Tree IO) -readPlainTree dir = do - items <- readPlainDir dir - let subs = catMaybes [ - let name = Name (BS8.pack name') - in case status of - _ | isDirectory status -> Just (name, Stub (readPlainTree (dir name')) NoHash) - _ | isRegularFile status -> Just (name, File $ Blob (readBlob' name) NoHash) - _ -> Nothing - | (name', status) <- items ] - return $ makeTree subs - where readBlob' (Name name) = readSegment (dir BS8.unpack name, Nothing) - --- | Write out /full/ tree to a plain directory structure. If you instead want --- to make incremental updates, refer to "Storage.Hashed.Monad". -writePlainTree :: Tree IO -> FilePath -> IO () -writePlainTree t dir = do - createDirectoryIfMissing True dir - expand t >>= mapM_ write . list - where write (p, File b) = write' p b - write (p, SubTree _) = - createDirectoryIfMissing True (anchorPath dir p) - write _ = return () - write' p b = readBlob b >>= BL.writeFile (anchorPath dir p) - --- | Run a 'TreeIO' action in a plain tree setting. Writes out changes to the --- plain tree every now and then (after the action is finished, the last tree --- state is always flushed to disk). XXX Modify the tree with filesystem --- reading and put it back into st (ie. replace the in-memory Blobs with normal --- ones, so the memory can be GCd). -plainTreeIO :: TreeIO a -> Tree IO -> FilePath -> IO (a, Tree IO) -plainTreeIO action t _ = runTreeMonad action $ initialState t (\_ -> return NoHash) updatePlain - where updatePlain path (File b) = - do liftIO $ createDirectoryIfMissing True (anchorPath "" $ parent path) - liftIO $ readBlob b >>= BL.writeFile (anchorPath "" path) - return $ File $ Blob (BL.readFile $ anchorPath "" path) NoHash - updatePlain _ x = return x - diff --git a/hashed-storage/Storage/Hashed/Test.hs b/hashed-storage/Storage/Hashed/Test.hs deleted file mode 100644 --- a/hashed-storage/Storage/Hashed/Test.hs +++ /dev/null @@ -1,621 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Storage.Hashed.Test( tests ) where - -import Prelude hiding ( filter, readFile, writeFile, lookup ) -import qualified Prelude -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.ByteString.Char8 as BS -import Control.Exception( finally ) -import System.Directory( doesFileExist, removeFile, doesDirectoryExist ) -import System.FilePath( () ) -import Control.Monad.Identity -import Control.Monad.Trans( lift ) -import Control.Applicative( (<$>) ) - -import Data.Maybe -import Data.Word -import Data.List( sort, intercalate, nub, intersperse ) - -import Storage.Hashed -import Storage.Hashed.AnchoredPath -import Storage.Hashed.Tree hiding ( lookup ) -import Storage.Hashed.Index -import Storage.Hashed.Utils -import Storage.Hashed.Darcs -import Storage.Hashed.Packed hiding ( lookup ) -import Storage.Hashed.Hash -import Storage.Hashed.Monad hiding ( tree ) - -import System.Mem( performGC ) - -import qualified Data.Set as S -import qualified Data.Map as M - -import qualified Bundled.Posix as Posix - ( getFileStatus, getSymbolicLinkStatus, fileSize, fileExists ) - -import Test.HUnit hiding ( path ) -import Test.Framework( testGroup ) -import qualified Test.Framework as TF ( Test ) -import Test.QuickCheck - -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 - ------------------------- --- Test Data --- - -blobs :: [(AnchoredPath, BL.ByteString)] -blobs = [ (floatPath "foo_a", BL.pack "a\n") - , (floatPath "foo_dir/foo_a", BL.pack "a\n") - , (floatPath "foo_dir/foo_b", BL.pack "b\n") - , (floatPath "foo_dir/foo_subdir/foo_a", BL.pack "a\n") - , (floatPath "foo space/foo\nnewline", BL.pack "newline\n") - , (floatPath "foo space/foo\\backslash", BL.pack "backslash\n") - , (floatPath "foo space/foo_a", BL.pack "a\n") ] - -files :: [AnchoredPath] -files = map fst blobs - -dirs :: [AnchoredPath] -dirs = [ floatPath "foo_dir" - , floatPath "foo_dir/foo_subdir" - , floatPath "foo space" ] - -emptyStub :: TreeItem IO -emptyStub = Stub (return emptyTree) NoHash - -testTree :: Tree IO -testTree = - makeTree [ (makeName "foo", emptyStub) - , (makeName "subtree", SubTree sub) - , (makeName "substub", Stub getsub NoHash) ] - where sub = makeTree [ (makeName "stub", emptyStub) - , (makeName "substub", Stub getsub2 NoHash) - , (makeName "x", SubTree emptyTree) ] - getsub = return sub - getsub2 = return $ makeTree [ (makeName "file", File emptyBlob) - , (makeName "file2", - File $ Blob (return $ BL.pack "foo") NoHash) ] - -equals_testdata :: Tree IO -> IO () -equals_testdata t = sequence_ [ - do isJust (findFile t p) @? show p ++ " in tree" - ours <- readBlob (fromJust $ findFile t p) - ours @?= stored - | (p, stored) <- blobs ] >> - sequence_ [ isJust (Prelude.lookup p blobs) @? show p ++ " extra in tree" - | (p, File _) <- list t ] - ---------------------------- --- Test list --- - -tests :: [TF.Test] -tests = [ testGroup "Bundled.Posix" posix - , testGroup "Storage.Hashed.Utils" utils - , testGroup "Storage.Hashed.Hash" hash - , testGroup "Storage.Hashed.Tree" tree - , testGroup "Storage.Hashed.Index" index - , testGroup "Storage.Hashed.Packed" packed - , testGroup "Storage.Hashed.Monad" monad - , testGroup "Storage.Hashed" hashed ] - --------------------------- --- Tests --- - -hashed :: [TF.Test] -hashed = [ testCase "plain has all files" have_files - , testCase "pristine has all files" have_pristine_files - , testCase "pristine has no extras" pristine_no_extra - , testCase "pristine file contents match" pristine_contents - , testCase "plain file contents match" plain_contents - , testCase "writePlainTree works" write_plain ] - where - check_file t f = assertBool - ("path " ++ show f ++ " is missing in tree " ++ show t) - (isJust $ find t f) - check_files = forM_ files . check_file - - pristine_no_extra = do - t <- readDarcsPristine "." >>= expand - forM_ (list t) $ \(path,_) -> assertBool (show path ++ " is extraneous in tree") - (path `elem` (dirs ++ files)) - have_files = readPlainTree "." >>= expand >>= check_files - have_pristine_files = - readDarcsPristine "." >>= expand >>= check_files - - pristine_contents = do - t <- readDarcsPristine "." >>= expand - equals_testdata t - - plain_contents = do - t <- expand =<< filter nondarcs `fmap` readPlainTree "." - equals_testdata t - - write_plain = do - orig <- readDarcsPristine "." >>= expand - writePlainTree orig "_darcs/plain" - t <- expand =<< readPlainTree "_darcs/plain" - equals_testdata t - -index :: [TF.Test] -index = [ testCase "index versioning" check_index_versions - , testCase "index listing" check_index - , testCase "index content" check_index_content ] - where pristine = readDarcsPristine "." >>= expand - build_index = - do x <- pristine - exist <- doesFileExist "_darcs/index" - performGC -- required in win32 to trigger file close - when exist $ removeFile "_darcs/index" - idx <- updateIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash x - return (x, idx) - check_index = - do (pris, idx) <- build_index - (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris) - check_blob_pair p x y = - do a <- readBlob x - b <- readBlob y - assertEqual ("content match on " ++ show p) a b - check_index_content = - do (_, idx) <- build_index - plain <- readPlainTree "." - x <- sequence $ zipCommonFiles check_blob_pair plain idx - assertBool "files match" (length x > 0) - check_index_versions = - do performGC -- required in win32 to trigger file close - Prelude.writeFile "_darcs/index" "nonsense index... do not crash!" - valid <- indexFormatValid "_darcs/index" - assertBool "index format invalid" $ not valid - -tree :: [TF.Test] -tree = [ testCase "modifyTree" check_modify - , testCase "complex modifyTree" check_modify_complex - , testCase "modifyTree removal" check_modify_remove - , testCase "expand" check_expand - , testCase "expandPath" check_expand_path - , testCase "expandPath of sub" check_expand_path_sub - , testCase "diffTrees" check_diffTrees - , testCase "diffTrees identical" check_diffTrees_ident - , testProperty "expandPath" prop_expandPath - , testProperty "shapeEq" prop_shape_eq - , testProperty "expandedShapeEq" prop_expanded_shape_eq - , testProperty "expand is identity" prop_expand_id - , testProperty "filter True is identity" prop_filter_id - , testProperty "filter False is empty" prop_filter_empty - , testProperty "restrict both ways keeps shape" prop_restrict_shape_commutative - , testProperty "restrict is a subtree of both" prop_restrict_subtree - , testProperty "overlay keeps shape" prop_overlay_shape - , testProperty "overlay is superset of over" prop_overlay_super ] - where blob x = File $ Blob (return (BL.pack x)) (sha256 $ BL.pack x) - name = Name . BS.pack - check_modify = - let t = makeTree [(name "foo", blob "bar")] - modify = modifyTree t (floatPath "foo") (Just $ blob "bla") - in do x <- readBlob $ fromJust $ findFile t (floatPath "foo") - y <- readBlob $ fromJust $ findFile modify (floatPath "foo") - assertEqual "old version" x (BL.pack "bar") - assertEqual "new version" y (BL.pack "bla") - assertBool "list has foo" $ - isJust (Prelude.lookup (floatPath "foo") $ list modify) - length (list modify) @?= 1 - check_modify_complex = - let t = makeTree [ (name "foo", blob "bar") - , (name "bar", SubTree t1) ] - t1 = makeTree [ (name "foo", blob "bar") ] - modify = modifyTree t (floatPath "bar/foo") (Just $ blob "bla") - in do foo <- readBlob $ fromJust $ findFile t (floatPath "foo") - foo' <- readBlob $ fromJust $ findFile modify (floatPath "foo") - bar_foo <- readBlob $ fromJust $ - findFile t (floatPath "bar/foo") - bar_foo' <- readBlob $ fromJust $ - findFile modify (floatPath "bar/foo") - assertEqual "old foo" foo (BL.pack "bar") - assertEqual "old bar/foo" bar_foo (BL.pack "bar") - assertEqual "new foo" foo' (BL.pack "bar") - assertEqual "new bar/foo" bar_foo' (BL.pack "bla") - assertBool "list has bar/foo" $ - isJust (Prelude.lookup (floatPath "bar/foo") $ list modify) - assertBool "list has foo" $ - isJust (Prelude.lookup (floatPath "foo") $ list modify) - length (list modify) @?= length (list t) - check_modify_remove = - let t1 = makeTree [(name "foo", blob "bar")] - t2 :: Tree Identity = makeTree [ (name "foo", blob "bar") - , (name "bar", SubTree t1) ] - modify1 = modifyTree t1 (floatPath "foo") Nothing - modify2 = modifyTree t2 (floatPath "bar") Nothing - file = findFile modify1 (floatPath "foo") - subtree = findTree modify2 (floatPath "bar") - in do assertBool "file is gone" (isNothing file) - assertBool "subtree is gone" (isNothing subtree) - - no_stubs t = null [ () | (_, Stub _ _) <- list t ] - path = floatPath "substub/substub/file" - badpath = floatPath "substub/substub/foo" - check_expand = do - x <- expand testTree - assertBool "no stubs in testTree" $ not (no_stubs testTree) - assertBool "stubs in expanded tree" $ no_stubs x - assertBool "path reachable" $ path `elem` (map fst $ list x) - assertBool "badpath not reachable" $ - badpath `notElem` (map fst $ list x) - check_expand_path = do - test_exp <- expand testTree - t <- expandPath testTree path - t' <- expandPath test_exp path - t'' <- expandPath testTree $ floatPath "substub/x" - assertBool "path not reachable in testTree" $ path `notElem` (map fst $ list testTree) - assertBool "path reachable in t" $ path `elem` (map fst $ list t) - assertBool "path reachable in t'" $ path `elem` (map fst $ list t') - assertBool "path reachable in t (with findFile)" $ - isJust $ findFile t path - assertBool "path reachable in t' (with findFile)" $ - isJust $ findFile t' path - assertBool "path not reachable in t''" $ path `notElem` (map fst $ list t'') - assertBool "badpath not reachable in t" $ - badpath `notElem` (map fst $ list t) - assertBool "badpath not reachable in t'" $ - badpath `notElem` (map fst $ list t') - - check_expand_path_sub = do - t <- expandPath testTree $ floatPath "substub" - t' <- expandPath testTree $ floatPath "substub/stub" - t'' <- expandPath testTree $ floatPath "subtree/stub" - assertBool "leaf is not a Stub" $ - isNothing (findTree testTree $ floatPath "substub") - assertBool "leaf is not a Stub" $ isJust (findTree t $ floatPath "substub") - assertBool "leaf is not a Stub (2)" $ isJust (findTree t' $ floatPath "substub/stub") - assertBool "leaf is not a Stub (3)" $ isJust (findTree t'' $ floatPath "subtree/stub") - - check_diffTrees = - flip finally (Prelude.writeFile "foo_dir/foo_a" "a\n") $ - do Prelude.writeFile "foo_dir/foo_a" "b\n" - working_plain <- filter nondarcs `fmap` readPlainTree "." - working <- updateIndex =<< - updateIndexFrom "_darcs/index" darcsTreeHash working_plain - pristine <- readDarcsPristine "." - (working', pristine') <- diffTrees working pristine - let foo_work = findFile working' (floatPath "foo_dir/foo_a") - foo_pris = findFile pristine' (floatPath "foo_dir/foo_a") - working' `shapeEq` pristine' - @? show working' ++ " `shapeEq` " ++ show pristine' - assertBool "foo_dir/foo_a is in working'" $ isJust foo_work - assertBool "foo_dir/foo_a is in pristine'" $ isJust foo_pris - foo_work_c <- readBlob (fromJust foo_work) - foo_pris_c <- readBlob (fromJust foo_pris) - BL.unpack foo_work_c @?= "b\n" - BL.unpack foo_pris_c @?= "a\n" - assertEqual "working' tree is minimal" 2 (length $ list working') - assertEqual "pristine' tree is minimal" 2 (length $ list pristine') - - check_diffTrees_ident = do - pristine <- readDarcsPristine "." - (t1, t2) <- diffTrees pristine pristine - assertBool "t1 is empty" $ null (list t1) - assertBool "t2 is empty" $ null (list t2) - - prop_shape_eq x = no_stubs x ==> x `shapeEq` x - where _types = x :: Tree Identity - prop_expanded_shape_eq x = runIdentity $ expandedShapeEq x x - where _types = x :: Tree Identity - prop_expand_id x = no_stubs x ==> runIdentity (expand x) `shapeEq` x - where _types = x :: Tree Identity - prop_filter_id x = runIdentity $ expandedShapeEq x $ filter (\_ _ -> True) x - where _types = x :: Tree Identity - prop_filter_empty x = runIdentity $ expandedShapeEq emptyTree $ filter (\_ _ -> False) x - where _types = x :: Tree Identity - prop_restrict_shape_commutative (t1, t2) = - no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `shapeEq` emptyTree) ==> - restrict t1 t2 `shapeEq` restrict t2 t1 - where _types = (t1 :: Tree Identity, t2 :: Tree Identity) - prop_restrict_subtree (t1, t2) = - no_stubs t1 && not (restrict t1 t2 `shapeEq` emptyTree) ==> - let restricted = S.fromList (map fst $ list $ restrict t1 t2) - orig1 = S.fromList (map fst $ list t1) - orig2 = S.fromList (map fst $ list t2) - in and [restricted `S.isSubsetOf` orig1, restricted `S.isSubsetOf` orig2] - where _types = (t1 :: Tree Identity, t2 :: Tree Identity) - prop_overlay_shape (t1 :: Tree Identity, t2) = - (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==> - runIdentity $ (t1 `overlay` t2) `expandedShapeEq` t1 - prop_overlay_super (t1 :: Tree Identity, t2) = - (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) && no_stubs t2 ==> - Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2) - prop_expandPath (TreeWithPath t p) = - notStub $ find (runIdentity $ expandPath t p) p - where notStub (Just (Stub _ _)) = False - notStub Nothing = error "Did not exist." - notStub _ = True - -packed :: [TF.Test] -packed = [ testCase "loose pristine tree" check_loose - , testCase "load" check_load - , testCase "live" check_live - , testCase "compact" check_compact ] - where root_hash = treeHash <$> get_pristine - get_pristine = darcsUpdateDirHashes <$> (expand =<< readDarcsPristine ".") - check_loose = do x <- readDarcsPristine "." - os <- create "_darcs/loose" Loose - (os', root) <- writePackedDarcsPristine x os - y <- expand =<< readPackedDarcsPristine os' root - equals_testdata y - check_load = do os <- load "_darcs/loose" - format (hatchery os) @?= Loose - root <- root_hash - y <- expand =<< readPackedDarcsPristine os root - equals_testdata y - check_live = do os <- load "_darcs/loose" - x <- get_pristine - root <- root_hash - alive <- live (os { roots = [ root ] - , references = darcsPristineRefs }) [hatchery os] - sequence_ [ assertBool (show hashValue ++ " is alive") $ - hashValue `S.member` M.keysSet alive - | hashValue <- map (itemHash . snd) $ list x ] - length (M.toList alive) @?= 1 + length (nub $ map snd blobs) + length dirs - check_compact = do os <- load "_darcs/loose" - x <- darcsUpdateDirHashes `fmap` (expand =<< readDarcsPristine ".") - (os', root) <- storePackedDarcsPristine x os - hatch_root_old <- blockLookup (hatchery os') root - assertBool "bits in the old hatchery" $ isJust hatch_root_old - - os'' <- compact os' - length (mature os'') @?= 1 - hatch_root <- blockLookup (hatchery os'') root - mature_root <- blockLookup (head $ mature os'') root - assertBool "bits no longer in hatchery" $ isNothing hatch_root - assertBool "bits now in the mature space" $ isJust mature_root - mature_root_con <- readSegment (fromJust mature_root) - Just mature_root_con @?= darcsFormatDir x - - y <- expand =<< readPackedDarcsPristine os'' root - equals_testdata y - -utils :: [TF.Test] -utils = [ testProperty "xlate32" prop_xlate32 - , testProperty "xlate64" prop_xlate64 - , testProperty "align bounded" prop_align_bounded - , testProperty "align aligned" prop_align_aligned - , testProperty "reachable is a subset" prop_reach_subset - , testProperty "roots are reachable" prop_reach_roots - , testProperty "nonexistent roots are not reachable" prop_reach_nonroots - , testCase "an example for reachable" check_reachable - , testCase "fixFrom" check_fixFrom - , testCase "mmap empty file" check_mmapEmpty ] - where prop_xlate32 x = (xlate32 . xlate32) x == x where _types = x :: Word32 - prop_xlate64 x = (xlate64 . xlate64) x == x where _types = x :: Word64 - prop_align_bounded (bound, x) = - bound > 0 && bound < 1024 && x >= 0 ==> - align bound x >= x && align bound x < x + bound - where _types = (bound, x) :: (Int, Int) - prop_align_aligned (bound, x) = - bound > 0 && bound < 1024 && x >= 0 ==> - align bound x `rem` bound == 0 - where _types = (bound, x) :: (Int, Int) - - check_fixFrom = let f 0 = 0 - f n = f (n - 1) in fixFrom f 5 @?= (0 :: Integer) - - check_mmapEmpty = flip finally (removeFile "test_empty") $ do - Prelude.writeFile "test_empty" "" - x <- readSegment ("test_empty", Nothing) - x @?= BL.empty - - reachable' ref look rootsSet = runIdentity $ reachable ref look rootsSet - - check_reachable = let refs 0 = [1, 2] - refs 1 = [2] - refs 2 = [0, 4] - refs 3 = [4, 6, 7] - refs 4 = [0, 1] - refs _ = error "internal error in check_reachable" - set = S.fromList [1, 2] - mp = M.fromList [ (n, refs n) | n <- [0..10] :: [Int] ] - reach = reachable' return (lookup mp) set - in do M.keysSet reach @?= S.fromList [0, 1, 2, 4] - - prop_reach_subset (set :: S.Set Int, mp :: M.Map Int [Int]) = - M.keysSet (reachable' return (lookup mp) set) - `S.isSubsetOf` M.keysSet mp - prop_reach_roots (set :: S.Set Int, mp :: M.Map Int [Int]) = - set `S.isSubsetOf` M.keysSet mp - ==> set `S.isSubsetOf` - M.keysSet (reachable' return (lookup mp) set) - - prop_reach_nonroots (set :: S.Set Int, mp :: M.Map Int [Int]) = - set `S.intersection` M.keysSet mp - == M.keysSet (reachable' (return . const []) - (lookup mp) set) - - lookup :: (Ord a) => M.Map a [a] -> a -> Identity (Maybe (a, [a])) - lookup m k = return $ case M.lookupIndex k m of - Nothing -> Nothing - Just i -> Just $ M.elemAt i m - -hash :: [TF.Test] -hash = [ testProperty "decodeBase16 . encodeBase16 == id" prop_base16 - , testProperty "decodeBase64u . encodeBase64u == id" prop_base64u ] - where prop_base16 x = (decodeBase16 . encodeBase16) x == x - prop_base64u x = (decodeBase64u . encodeBase64u) x == x - -monad :: [TF.Test] -monad = [ testCase "path expansion" check_virtual - , testCase "rename" check_rename ] - where check_virtual = virtualTreeMonad run testTree >> return () - where run = do file <- readFile (floatPath "substub/substub/file") - file2 <- readFile (floatPath "substub/substub/file2") - lift $ BL.unpack file @?= "" - lift $ BL.unpack file2 @?= "foo" - check_rename = do (_, t) <- virtualTreeMonad run testTree - t' <- darcsAddMissingHashes =<< expand t - forM_ [ (p, i) | (p, i) <- list t' ] $ \(p,i) -> - assertBool ("have hash: " ++ show p) $ itemHash i /= NoHash - where run = do rename (floatPath "substub/substub/file") (floatPath "substub/file2") - -posix :: [TF.Test] -posix = [ testCase "getFileStatus" $ check_stat Posix.getFileStatus - , testCase "getSymbolicLinkStatus" $ check_stat Posix.getSymbolicLinkStatus ] - where check_stat fun = flip finally (removeFile "test_empty") $ do - x <- Posix.fileSize `fmap` fun "foo_a" - Prelude.writeFile "test_empty" "" - y <- Posix.fileSize `fmap` fun "test_empty" - exist_nonexistent <- Posix.fileExists `fmap` fun "test_does_not_exist" - exist_existent <- Posix.fileExists `fmap` fun "test_empty" - assertEqual "file size" x 2 - assertEqual "file size" y 0 - assertBool "existence check" $ not exist_nonexistent - assertBool "existence check" exist_existent - ----------------------------------- --- Arbitrary instances --- - -#if !MIN_VERSION_QuickCheck(2,8,2) --- these instances were added to QuickCheck itself in version 2.8.2 -instance (Arbitrary a, Ord a) => Arbitrary (S.Set a) - where arbitrary = S.fromList `fmap` arbitrary - -instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) - where arbitrary = M.fromList `fmap` arbitrary -#endif - -instance Arbitrary BL.ByteString where - arbitrary = BL.pack `fmap` arbitrary - -instance Arbitrary Hash where - arbitrary = sized hash' - where hash' 0 = return NoHash - hash' _ = do - tag <- oneof [return False, return True] - case tag of - False -> SHA256 . BS.pack <$> sequence [ arbitrary | _ <- [1..32] :: [Int] ] - True -> SHA1 . BS.pack <$> sequence [ arbitrary | _ <- [1..20] :: [Int] ] - -instance (Monad m) => Arbitrary (TreeItem m) where - arbitrary = sized tree' - where tree' 0 = oneof [ return (File emptyBlob), return (SubTree emptyTree) ] - tree' n = oneof [ file n, subtree n ] - file 0 = return (File emptyBlob) - file _ = do content <- arbitrary - return (File $ Blob (return content) NoHash) - subtree n = do branches <- choose (1, n) - let sub name = do t <- tree' ((n - 1) `div` branches) - return (makeName $ show name, t) - sublist <- mapM sub [0..branches] - oneof [ tree' 0 - , return (SubTree $ makeTree sublist) - , return $ (Stub $ return (makeTree sublist)) NoHash ] - -instance (Monad m) => Arbitrary (Tree m) where - arbitrary = do item <- arbitrary - case item of - File _ -> arbitrary - Stub _ _ -> arbitrary - SubTree t -> return t - -data TreeWithPath = TreeWithPath (Tree Identity) AnchoredPath deriving (Show) - -instance Arbitrary TreeWithPath where - arbitrary = do t <- arbitrary - p <- oneof $ return (AnchoredPath []) : - (map (return . fst) $ list (runIdentity $ expand t)) - return $ TreeWithPath t p - ---------------------------- --- Other instances --- - -instance Show (Blob m) where - show (Blob _ h) = "Blob " ++ show h - -instance Show (TreeItem m) where - show (File f) = "File (" ++ show f ++ ")" - show (Stub _ h) = "Stub _ " ++ show h - show (SubTree s) = "SubTree (" ++ show s ++ ")" - -instance Show (Tree m) where - show t = "Tree " ++ show (treeHash t) ++ " { " ++ - (concat . intersperse ", " $ itemstrs) ++ " }" - where itemstrs = map show $ listImmediate t - -instance Show (Int -> Int) where - show f = "[" ++ intercalate ", " (map val [1..20]) ++ " ...]" - where val x = show x ++ " -> " ++ show (f x) - ------------------------ --- Test utilities --- - -shapeEq :: Tree m -> Tree m -> Bool -shapeEq a b = Just EQ == cmpShape a b - -expandedShapeEq :: (Monad m, Functor m) => Tree m -> Tree m -> m Bool -expandedShapeEq a b = (Just EQ ==) <$> cmpExpandedShape a b - -cmpcat :: [Maybe Ordering] -> Maybe Ordering -cmpcat (x:y:rest) | x == y = cmpcat (x:rest) - | x == Just EQ = cmpcat (y:rest) - | y == Just EQ = cmpcat (x:rest) - | otherwise = Nothing -cmpcat [x] = x -cmpcat [] = Just EQ -- empty things are equal - -cmpTree :: (Monad m, Functor m) => Tree m -> Tree m -> m (Maybe Ordering) -cmpTree x y = do x' <- expand x - y' <- expand y - con <- contentsEq x' y' - return $ cmpcat [cmpShape x' y', con] - where contentsEq a b = cmpcat <$> sequence (zipTrees cmp a b) - cmp _ (Just (File a)) (Just (File b)) = do a' <- readBlob a - b' <- readBlob b - return $ Just (compare a' b') - cmp _ _ _ = return (Just EQ) -- neutral - -cmpShape :: Tree m -> Tree m -> Maybe Ordering -cmpShape t r = cmpcat $ zipTrees cmp t r - where cmp _ (Just a) (Just b) = a `item` b - cmp _ Nothing (Just _) = Just LT - cmp _ (Just _) Nothing = Just GT - cmp _ Nothing Nothing = Just EQ - item (File _) (File _) = Just EQ - item (SubTree s) (SubTree p) = s `cmpShape` p - item _ _ = Nothing - -cmpExpandedShape :: (Monad m) => Tree m -> Tree m -> m (Maybe Ordering) -cmpExpandedShape a b = do x <- expand a - y <- expand b - return $ x `cmpShape` y - -nondarcs :: AnchoredPath -> TreeItem m -> Bool -nondarcs (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False - | otherwise = True -nondarcs (AnchoredPath []) _ = True - -readDarcsPristine :: FilePath -> IO (Tree IO) -readDarcsPristine dir = do - let darcs = dir "_darcs" - h_inventory = darcs "hashed_inventory" - repo <- doesDirectoryExist darcs - unless repo $ fail $ "Not a darcs repository: " ++ dir - isHashed <- doesFileExist h_inventory - if isHashed - then do inv <- BS.readFile h_inventory - let thelines = BS.split '\n' inv - case thelines of - [] -> return emptyTree - (pris_line:_) -> do - let thehash = decodeDarcsHash $ BS.drop 9 pris_line - thesize = decodeDarcsSize $ BS.drop 9 pris_line - when (thehash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line - readDarcsHashed (darcs "pristine.hashed") (thesize, thehash) - else do have_pristine <- doesDirectoryExist $ darcs "pristine" - have_current <- doesDirectoryExist $ darcs "current" - case (have_pristine, have_current) of - (True, _) -> readPlainTree $ darcs "pristine" - (False, True) -> readPlainTree $ darcs "current" - (_, _) -> fail "No pristine tree is available!" diff --git a/hashed-storage/Storage/Hashed/Tree.hs b/hashed-storage/Storage/Hashed/Tree.hs deleted file mode 100644 --- a/hashed-storage/Storage/Hashed/Tree.hs +++ /dev/null @@ -1,464 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, BangPatterns #-} - --- | The abstract representation of a Tree and useful abstract utilities to --- handle those. -module Storage.Hashed.Tree - ( Tree, Blob(..), TreeItem(..), ItemType(..), Hash(..) - , makeTree, makeTreeWithHash, emptyTree, emptyBlob, makeBlob, makeBlobBS - - -- * Unfolding stubbed (lazy) Trees. - -- - -- | By default, Tree obtained by a read function is stubbed: it will - -- contain Stub items that need to be executed in order to access the - -- respective subtrees. 'expand' will produce an unstubbed Tree. - , expandUpdate, expand, expandPath, checkExpand - - -- * Tree access and lookup. - , items, list, listImmediate, treeHash - , lookup, find, findFile, findTree, itemHash, itemType - , zipCommonFiles, zipFiles, zipTrees, diffTrees - - -- * Files (Blobs). - , readBlob - - -- * Filtering trees. - , FilterTree(..), restrict - - -- * Manipulating trees. - , modifyTree, updateTree, partiallyUpdateTree, updateSubtrees, overlay - , addMissingHashes ) where - -import Control.Exception( catch, IOException ) -import Prelude hiding( lookup, filter, all, catch ) -import Storage.Hashed.AnchoredPath -import Storage.Hashed.Hash - -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.ByteString.Char8 as BS -import qualified Data.Map as M - -import Data.Maybe( catMaybes, isNothing ) -import Data.Either( lefts, rights ) -import Data.List( union, sort ) -import Control.Monad( filterM ) -import Control.Applicative( (<$>) ) - --------------------------------- --- Tree, Blob and friends --- - -data Blob m = Blob !(m BL.ByteString) !Hash -data TreeItem m = File !(Blob m) - | SubTree !(Tree m) - | Stub !(m (Tree m)) !Hash - -data ItemType = TreeType | BlobType deriving (Show, Eq, Ord) - --- | Abstraction of a filesystem tree. --- Please note that the Tree returned by the respective read operations will --- have TreeStub items in it. To obtain a Tree without such stubs, call --- expand on it, eg.: --- --- > tree <- readDarcsPristine "." >>= expand --- --- When a Tree is expanded, it becomes \"final\". All stubs are forced and the --- Tree can be traversed purely. Access to actual file contents stays in IO --- though. --- --- A Tree may have a Hash associated with it. A pair of Tree's is identical --- whenever their hashes are (the reverse need not hold, since not all Trees --- come equipped with a hash). -data Tree m = Tree { items :: (M.Map Name (TreeItem m)) - -- | Get hash of a Tree. This is guaranteed to uniquely - -- identify the Tree (including any blob content), as far as - -- cryptographic hashes are concerned. Sha256 is recommended. - , treeHash :: !Hash } - -listImmediate :: Tree m -> [(Name, TreeItem m)] -listImmediate = M.toList . items - --- | Get a hash of a TreeItem. May be Nothing. -itemHash :: TreeItem m -> Hash -itemHash (File (Blob _ h)) = h -itemHash (SubTree t) = treeHash t -itemHash (Stub _ h) = h - -itemType :: TreeItem m -> ItemType -itemType (File _) = BlobType -itemType (SubTree _) = TreeType -itemType (Stub _ _) = TreeType - -emptyTree :: (Monad m) => Tree m -emptyTree = Tree { items = M.empty - , treeHash = NoHash } - -emptyBlob :: (Monad m) => Blob m -emptyBlob = Blob (return BL.empty) NoHash - -makeBlob :: (Monad m) => BL.ByteString -> Blob m -makeBlob str = Blob (return str) (sha256 str) - -makeBlobBS :: (Monad m) => BS.ByteString -> Blob m -makeBlobBS s' = let s = BL.fromChunks [s'] in Blob (return s) (sha256 s) - -makeTree :: (Monad m) => [(Name,TreeItem m)] -> Tree m -makeTree l = Tree { items = M.fromList l - , treeHash = NoHash } - -makeTreeWithHash :: (Monad m) => [(Name,TreeItem m)] -> Hash -> Tree m -makeTreeWithHash l h = Tree { items = M.fromList l - , treeHash = h } - ------------------------------------ --- Tree access and lookup --- - --- | Look up a 'Tree' item (an immediate subtree or blob). -lookup :: Tree m -> Name -> Maybe (TreeItem m) -lookup t n = M.lookup n (items t) - -find' :: TreeItem m -> AnchoredPath -> Maybe (TreeItem m) -find' t (AnchoredPath []) = Just t -find' (SubTree t) (AnchoredPath (d : rest)) = - case lookup t d of - Just sub -> find' sub (AnchoredPath rest) - Nothing -> Nothing -find' _ _ = Nothing - --- | Find a 'TreeItem' by its path. Gives 'Nothing' if the path is invalid. -find :: Tree m -> AnchoredPath -> Maybe (TreeItem m) -find = find' . SubTree - --- | Find a 'Blob' by its path. Gives 'Nothing' if the path is invalid, or does --- not point to a Blob. -findFile :: Tree m -> AnchoredPath -> Maybe (Blob m) -findFile t p = case find t p of - Just (File x) -> Just x - _ -> Nothing - --- | Find a 'Tree' by its path. Gives 'Nothing' if the path is invalid, or does --- not point to a Tree. -findTree :: Tree m -> AnchoredPath -> Maybe (Tree m) -findTree t p = case find t p of - Just (SubTree x) -> Just x - _ -> Nothing - --- | List all contents of a 'Tree'. -list :: Tree m -> [(AnchoredPath, TreeItem m)] -list t_ = paths t_ (AnchoredPath []) - where paths t p = [ (appendPath p n, i) - | (n,i) <- listImmediate t ] ++ - concat [ paths subt (appendPath p subn) - | (subn, SubTree subt) <- listImmediate t ] - -expandUpdate :: (Monad m) => (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m) -expandUpdate update t_ = go (AnchoredPath []) t_ - where go path t = do - let subtree (name, sub) = do tree <- go (path `appendPath` name) =<< unstub sub - return (name, SubTree tree) - expanded <- mapM subtree [ x | x@(_, item) <- listImmediate t, isSub item ] - let orig_map = M.filter (not . isSub) (items t) - expanded_map = M.fromList expanded - tree = t { items = M.union orig_map expanded_map } - update path tree - --- | Expand a stubbed Tree into a one with no stubs in it. You might want to --- filter the tree before expanding to save IO. This is the basic --- implementation, which may be overriden by some Tree instances (this is --- especially true of the Index case). -expand :: (Monad m) => Tree m -> m (Tree m) -expand = expandUpdate $ \_ -> return - --- | Unfold a path in a (stubbed) Tree, such that the leaf node of the path is --- reachable without crossing any stubs. Moreover, the leaf ought not be a Stub --- in the resulting Tree. A non-existent path is expanded as far as it can be. -expandPath :: (Monad m) => Tree m -> AnchoredPath -> m (Tree m) -expandPath t_ path_ = expand' t_ path_ - where expand' t (AnchoredPath []) = return t - expand' t (AnchoredPath (n:rest)) = - case lookup t n of - (Just item) | isSub item -> amend t n rest =<< unstub item - _ -> return t -- fail $ "Descent error in expandPath: " ++ show path_ - amend t name rest sub = do - sub' <- expand' sub (AnchoredPath rest) - let tree = t { items = M.insert name (SubTree sub') (items t) } - return tree - --- | Check the disk version of a Tree: expands it, and checks each --- hash. Returns either the expanded tree or a list of AnchoredPaths --- where there are problems. The first argument is the hashing function --- used to create the tree. -checkExpand :: (TreeItem IO -> IO Hash) -> Tree IO - -> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)) -checkExpand hashFunc t = go (AnchoredPath []) t - where - go path t_ = do - let - subtree (name, sub) = - do let here = path `appendPath` name - sub' <- (Just <$> unstub sub) `catch` \(_ :: IOException) -> return Nothing - case sub' of - Nothing -> return $ Left [(here, treeHash t_, Nothing)] - Just sub'' -> do - treeOrTrouble <- go (path `appendPath` name) sub'' - return $ case treeOrTrouble of - Left problems -> Left problems - Right tree -> Right (name, SubTree tree) - badBlob (_, f@(File (Blob _ h))) = - fmap (/= h) (hashFunc f `catch` (\(_ :: IOException) -> return NoHash)) - badBlob _ = return False - render (name, f@(File (Blob _ h))) = do - h' <- (Just <$> hashFunc f) `catch` \(_ :: IOException) -> return Nothing - return (path `appendPath` name, h, h') - render (name, _) = return (path `appendPath` name, NoHash, Nothing) - subs <- mapM subtree [ x | x@(_, item) <- listImmediate t_, isSub item ] - badBlobs <- filterM badBlob (listImmediate t) >>= mapM render - let problems = badBlobs ++ (concat $ lefts subs) - if null problems - then do - let orig_map = M.filter (not . isSub) (items t) - expanded_map = M.fromList $ rights subs - tree = t_ {items = orig_map `M.union` expanded_map} - h' <- hashFunc (SubTree t_) - if h' `match` treeHash t_ - then return $ Right tree - else return $ Left [(path, treeHash t_, Just h')] - else return $ Left problems - -class (Monad m) => FilterTree a m where - -- | Given @pred tree@, produce a 'Tree' that only has items for which - -- @pred@ returns @True@. - -- The tree might contain stubs. When expanded, these will be subject to - -- filtering as well. - filter :: (AnchoredPath -> TreeItem m -> Bool) -> a m -> a m - -instance (Monad m) => FilterTree Tree m where - filter predicate t_ = filter' t_ (AnchoredPath []) - where filter' t path = t { items = M.mapMaybeWithKey (wibble path) $ items t } - wibble path name item = - let npath = path `appendPath` name in - if predicate npath item - then Just $ filterSub npath item - else Nothing - filterSub npath (SubTree t) = SubTree $ filter' t npath - filterSub npath (Stub stub h) = - Stub (do x <- stub - return $ filter' x npath) h - filterSub _ x = x - --- | Given two Trees, a @guide@ and a @tree@, produces a new Tree that is a --- identical to @tree@, but only has those items that are present in both --- @tree@ and @guide@. The @guide@ Tree may not contain any stubs. -restrict :: (FilterTree t m, Monad n) => Tree n -> t m -> t m -restrict guide tree = filter accept tree - where accept path item = - case (find guide path, item) of - (Just (SubTree _), SubTree _) -> True - (Just (SubTree _), Stub _ _) -> True - (Just (File _), File _) -> True - (Just (Stub _ _), _) -> - error "*sulk* Go away, you, you precondition violator!" - (_, _) -> False - --- | Read a Blob into a Lazy ByteString. Might be backed by an mmap, use with --- care. -readBlob :: Blob m -> m BL.ByteString -readBlob (Blob r _) = r - --- | For every pair of corresponding blobs from the two supplied trees, --- evaluate the supplied function and accumulate the results in a list. Hint: --- to get IO actions through, just use sequence on the resulting list. --- NB. This won't expand any stubs. -zipCommonFiles :: (AnchoredPath -> Blob m -> Blob m -> a) -> Tree m -> Tree m -> [a] -zipCommonFiles f a b = catMaybes [ flip (f p) x `fmap` findFile a p - | (p, File x) <- list b ] - --- | For each file in each of the two supplied trees, evaluate the supplied --- function (supplying the corresponding file from the other tree, or Nothing) --- and accumulate the results in a list. Hint: to get IO actions through, just --- use sequence on the resulting list. NB. This won't expand any stubs. -zipFiles :: (AnchoredPath -> Maybe (Blob m) -> Maybe (Blob m) -> a) - -> Tree m -> Tree m -> [a] -zipFiles f a b = [ f p (findFile a p) (findFile b p) - | p <- paths a `sortedUnion` paths b ] - where paths t = sort [ p | (p, File _) <- list t ] - -zipTrees :: (AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a) - -> Tree m -> Tree m -> [a] -zipTrees f a b = [ f p (find a p) (find b p) - | p <- reverse (paths a `sortedUnion` paths b) ] - where paths t = sort [ p | (p, _) <- list t ] - --- | Helper function for taking the union of AnchoredPath lists that --- are already sorted. This function does not check the precondition --- so use it carefully. -sortedUnion :: [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath] -sortedUnion [] ys = ys -sortedUnion xs [] = xs -sortedUnion a@(x:xs) b@(y:ys) = case compare x y of - LT -> x : sortedUnion xs b - EQ -> x : sortedUnion xs ys - GT -> y : sortedUnion a ys - --- | Cautiously extracts differing subtrees from a pair of Trees. It will never --- do any unneccessary expanding. Tree hashes are used to cut the comparison as --- high up the Tree branches as possible. The result is a pair of trees that do --- not share any identical subtrees. They are derived from the first and second --- parameters respectively and they are always fully expanded. It might be --- advantageous to feed the result into 'zipFiles' or 'zipTrees'. -diffTrees :: forall m. (Functor m, Monad m) => Tree m -> Tree m -> m (Tree m, Tree m) -diffTrees left right = - if treeHash left `match` treeHash right - then return (emptyTree, emptyTree) - else diff left right - where isFile (File _) = True - isFile _ = False - notFile = not . isFile - isEmpty = null . listImmediate - subtree :: TreeItem m -> m (Tree m) - subtree (Stub x _) = x - subtree (SubTree x) = return x - subtree (File _) = error "diffTrees tried to descend a File as a subtree" - maybeUnfold (Stub x _) = SubTree `fmap` (x >>= expand) - maybeUnfold (SubTree x) = SubTree `fmap` expand x - maybeUnfold i = return i - immediateN t = [ n | (n, _) <- listImmediate t ] - diff left' right' = do - is <- sequence [ - case (lookup left' n, lookup right' n) of - (Just l, Nothing) -> do - l' <- maybeUnfold l - return (n, Just l', Nothing) - (Nothing, Just r) -> do - r' <- maybeUnfold r - return (n, Nothing, Just r') - (Just l, Just r) - | itemHash l `match` itemHash r -> - return (n, Nothing, Nothing) - | notFile l && notFile r -> - do x <- subtree l - y <- subtree r - (x', y') <- diffTrees x y - if isEmpty x' && isEmpty y' - then return (n, Nothing, Nothing) - else return (n, Just $ SubTree x', Just $ SubTree y') - | isFile l && isFile r -> - return (n, Just l, Just r) - | otherwise -> - do l' <- maybeUnfold l - r' <- maybeUnfold r - return (n, Just l', Just r') - _ -> error "n lookups failed" - | n <- immediateN left' `union` immediateN right' ] - let is_l = [ (n, l) | (n, Just l, _) <- is ] - is_r = [ (n, r) | (n, _, Just r) <- is ] - return (makeTree is_l, makeTree is_r) - --- | Modify a Tree (by replacing, or removing or adding items). -modifyTree :: (Monad m) => Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m -modifyTree t_ p_ i_ = snd $ go t_ p_ i_ - where fix t unmod items' = (unmod, t { items = (countmap items':: Int) `seq` items' - , treeHash = if unmod then treeHash t else NoHash }) - - go t (AnchoredPath []) (Just (SubTree sub)) = (treeHash t `match` treeHash sub, sub) - - go t (AnchoredPath [n]) (Just item) = fix t unmod items' - where !items' = M.insert n item (items t) - !unmod = itemHash item `match` case lookup t n of - Nothing -> NoHash - Just i -> itemHash i - - go t (AnchoredPath [n]) Nothing = fix t unmod items' - where !items' = M.delete n (items t) - !unmod = isNothing $ lookup t n - - go t path@(AnchoredPath (n:r)) item = fix t unmod items' - where subtree s = go s (AnchoredPath r) item - !items' = M.insert n sub (items t) - !sub = snd sub' - !unmod = fst sub' - !sub' = case lookup t n of - Just (SubTree s) -> let (mod', sub'') = subtree s in (mod', SubTree sub'') - Just (Stub s _) -> (False, Stub (do x <- s - return $! snd $! subtree x) NoHash) - Nothing -> (False, SubTree $! snd $! subtree emptyTree) - _ -> error $ "Modify tree at " ++ show path - - go _ (AnchoredPath []) (Just (Stub _ _)) = - error $ "BUG: Error descending in modifyTree, path = " ++ show p_ - go _ (AnchoredPath []) (Just (File _)) = - error $ "BUG: Error descending in modifyTree, path = " ++ show p_ - go _ (AnchoredPath []) Nothing = - error $ "BUG: Error descending in modifyTree, path = " ++ show p_ - -countmap :: forall a k. M.Map k a -> Int -countmap = M.fold (\_ i -> i + 1) 0 - -updateSubtrees :: (Tree m -> Tree m) -> Tree m -> Tree m -updateSubtrees fun t = - fun $ t { items = M.mapWithKey (curry $ snd . update) $ items t - , treeHash = NoHash } - where update (k, SubTree s) = (k, SubTree $ updateSubtrees fun s) - update (k, File f) = (k, File f) - update (_, Stub _ _) = error "Stubs not supported in updateTreePostorder" - --- | Does /not/ expand the tree. -updateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m) -updateTree fun t = partiallyUpdateTree fun (\_ _ -> True) t - --- | Does /not/ expand the tree. -partiallyUpdateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m)) - -> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m) -partiallyUpdateTree fun predi t' = go (AnchoredPath []) t' - where go path t = do - items' <- M.fromList <$> mapM (maybeupdate path) (listImmediate t) - SubTree t'' <- fun . SubTree $ t { items = items' - , treeHash = NoHash } - return t'' - maybeupdate path (k, item) = case predi (path `appendPath` k) item of - True -> update (path `appendPath` k) (k, item) - False -> return (k, item) - update path (k, SubTree tree) = (\new -> (k, SubTree new)) <$> go path tree - update _ (k, item) = (\new -> (k, new)) <$> fun item - --- | Lay one tree over another. The resulting Tree will look like the base (1st --- parameter) Tree, although any items also present in the overlay Tree will be --- taken from the overlay. It is not allowed to overlay a different kind of an --- object, nor it is allowed for the overlay to add new objects to base. This --- means that the overlay Tree should be a subset of the base Tree (although --- any extraneous items will be ignored by the implementation). -overlay :: (Functor m, Monad m) => Tree m -> Tree m -> Tree m -overlay base over = Tree { items = M.fromList immediate - , treeHash = NoHash } - where immediate = [ (n, get n) | (n, _) <- listImmediate base ] - get n = case (M.lookup n $ items base, M.lookup n $ items over) of - (Just (File _), Just f@(File _)) -> f - (Just (SubTree b), Just (SubTree o)) -> SubTree $ overlay b o - (Just (Stub b _), Just (SubTree o)) -> Stub (flip overlay o `fmap` b) NoHash - (Just (SubTree b), Just (Stub o _)) -> Stub (overlay b `fmap` o) NoHash - (Just (Stub b _), Just (Stub o _)) -> Stub (do o' <- o - b' <- b - return $ overlay b' o') NoHash - (Just x, _) -> x - (_, _) -> error $ "Unexpected case in overlay at get " ++ show n ++ "." - -addMissingHashes :: (Monad m, Functor m) => (TreeItem m -> m Hash) -> Tree m -> m (Tree m) -addMissingHashes make = updateTree update -- use partiallyUpdateTree here - where update (SubTree t) = make (SubTree t) >>= \x -> return $ SubTree (t { treeHash = x }) - update (File blob@(Blob con NoHash)) = - do hash <- make $ File blob - return $ File (Blob con hash) - update (Stub s NoHash) = update . SubTree =<< s - update x = return x - ------- Private utilities shared among multiple functions. -------- - -unstub :: (Monad m) => TreeItem m -> m (Tree m) -unstub (Stub s _) = s -unstub (SubTree s) = return s -unstub _ = return emptyTree - -isSub :: TreeItem m -> Bool -isSub (File _) = False -isSub _ = True - diff --git a/hashed-storage/Storage/Hashed/Utils.hs b/hashed-storage/Storage/Hashed/Utils.hs deleted file mode 100644 --- a/hashed-storage/Storage/Hashed/Utils.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} - --- | Mostly internal utilities for use by the rest of the library. Subject to --- removal without further notice. -module Storage.Hashed.Utils where - -import Prelude hiding ( lookup, catch ) -import System.Mem( performGC ) -import Bundled.Posix( getFileStatus, fileSize ) -import System.Directory( getCurrentDirectory, setCurrentDirectory ) -import System.FilePath( (), isAbsolute ) -import Data.Int( Int64 ) -import Data.Maybe( catMaybes ) -import Control.Exception( catch, bracket, SomeException(..) ) -import Control.Monad( when ) -import Control.Monad.Identity( runIdentity ) -import Control.Applicative( (<$>) ) - -import Foreign.ForeignPtr( withForeignPtr ) -import Foreign.Ptr( plusPtr ) -import Data.ByteString.Internal( toForeignPtr, memcpy ) -import System.IO (withFile, IOMode(ReadMode), hSeek, SeekMode(AbsoluteSeek)) -import Data.Bits( Bits ) -#ifdef BIGENDIAN -import Data.Bits( (.&.), (.|.), shift, shiftL, rotateR ) -#endif - -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString as BS - -import qualified Data.Set as S -import qualified Data.Map as M - --- | Pointer to a filesystem, possibly with start/end offsets. Supposed to be --- fed to (uncurry mmapFileByteString) or similar. -type FileSegment = (FilePath, Maybe (Int64, Int)) - --- | Read in a FileSegment into a Lazy ByteString. Implemented using mmap. -readSegment :: FileSegment -> IO BL.ByteString -readSegment (f,range) = do - bs <- tryToRead - `catch` (\(_::SomeException) -> do - size <- fileSize `fmap` getFileStatus f - if size == 0 - then return BS8.empty - else performGC >> tryToRead) - return $ BL.fromChunks [bs] - where - tryToRead = do - case range of - Nothing -> BS.readFile f - Just (off, size) -> withFile f ReadMode $ \h -> do - hSeek h AbsoluteSeek $ fromIntegral off - BS.hGet h size -{-# INLINE readSegment #-} - --- | Run an IO action with @path@ as a working directory. Does neccessary --- bracketing. -withCurrentDirectory :: FilePath -> IO a -> IO a -withCurrentDirectory name = - bracket - (do cwd <- getCurrentDirectory - when (name /= "") (setCurrentDirectory name) - return cwd) - (\oldwd -> setCurrentDirectory oldwd - `catch` \(_::SomeException) -> return ()) - . const - -makeAbsolute :: FilePath -> IO FilePath -makeAbsolute p = do - cwd <- getCurrentDirectory - return $! if isAbsolute p then p else cwd p - --- Wow, unsafe. -unsafePokeBS :: BS8.ByteString -> BS8.ByteString -> IO () -unsafePokeBS to from = - do let (fp_to, off_to, len_to) = toForeignPtr to - (fp_from, off_from, len_from) = toForeignPtr from - when (len_to /= len_from) $ fail $ "Length mismatch in unsafePokeBS: from = " - ++ show len_from ++ " /= to = " ++ show len_to - withForeignPtr fp_from $ \p_from -> - withForeignPtr fp_to $ \p_to -> - memcpy (plusPtr p_to off_to) - (plusPtr p_from off_from) - (fromIntegral len_to) - -align :: Integral a => a -> a -> a -align boundary i = case i `rem` boundary of - 0 -> i - x -> i + boundary - x -{-# INLINE align #-} - -xlate32 :: (Num a, Bits a) => a -> a -xlate64 :: (Num a, Bits a) => a -> a - -#ifdef LITTLEENDIAN -xlate32 = id -xlate64 = id -#endif - -#ifdef BIGENDIAN -bytemask :: (Num a, Bits a) => a -bytemask = 255 - -xlate32 a = ((a .&. (bytemask `shift` 0)) `shiftL` 24) .|. - ((a .&. (bytemask `shift` 8)) `shiftL` 8) .|. - ((a .&. (bytemask `shift` 16)) `rotateR` 8) .|. - ((a .&. (bytemask `shift` 24)) `rotateR` 24) - -xlate64 a = ((a .&. (bytemask `shift` 0)) `shiftL` 56) .|. - ((a .&. (bytemask `shift` 8)) `shiftL` 40) .|. - ((a .&. (bytemask `shift` 16)) `shiftL` 24) .|. - ((a .&. (bytemask `shift` 24)) `shiftL` 8) .|. - ((a .&. (bytemask `shift` 32)) `rotateR` 8) .|. - ((a .&. (bytemask `shift` 40)) `rotateR` 24) .|. - ((a .&. (bytemask `shift` 48)) `rotateR` 40) .|. - ((a .&. (bytemask `shift` 56)) `rotateR` 56) -#endif - --- | Find a monadic fixed point of @f@ that is the least above @i@. (Will --- happily diverge if there is none.) -mfixFrom :: (Eq a, Functor m, Monad m) => (a -> m a) -> a -> m a -mfixFrom f i = do x <- f i - if x == i then return i - else mfixFrom f x - --- | Find a fixed point of @f@ that is the least above @i@. (Will happily --- diverge if there is none.) -fixFrom :: (Eq a) => (a -> a) -> a -> a -fixFrom f i = runIdentity $ mfixFrom (return . f) i - --- | For a @refs@ function, a @map@ (@key@ -> @value@) and a @rootSet@, find a --- submap of @map@ such that all items in @map@ are reachable, through @refs@ --- from @rootSet@. -reachable :: forall monad key value. (Functor monad, Monad monad, Ord key, Eq value) => - (value -> monad [key]) - -> (key -> monad (Maybe (key, value))) - -> S.Set key -> monad (M.Map key value) -reachable refs lookup rootSet = - do lookupSet rootSet >>= mfixFrom expand - where lookupSet :: S.Set key -> monad (M.Map key value) - expand :: M.Map key value -> monad (M.Map key value) - - lookupSet s = do list <- mapM lookup (S.toAscList s) - return $ M.fromAscList (catMaybes list) - expand from = do refd <- concat <$> mapM refs (M.elems from) - M.union from <$> lookupSet (S.fromList refd) diff --git a/hashed-storage/test.hs b/hashed-storage/test.hs deleted file mode 100644 --- a/hashed-storage/test.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -import Storage.Hashed.Test( tests ) -import Prelude hiding( catch ) -import Test.Framework( defaultMain ) -import System.Directory( createDirectory, removeDirectoryRecursive - , setCurrentDirectory ) -import Codec.Archive.Zip( extractFilesFromArchive, toArchive ) -import qualified Data.ByteString.Lazy as BL -import Control.Exception( catch, IOException ) - -main :: IO () -main = do zipFile <- toArchive `fmap` BL.readFile "hashed-storage/testdata.zip" - removeDirectoryRecursive "_test_playground" `catch` \(_ :: IOException) -> return () - createDirectory "_test_playground" - setCurrentDirectory "_test_playground" - extractFilesFromArchive [] zipFile - defaultMain tests diff --git a/hashed-storage/testdata.zip b/hashed-storage/testdata.zip deleted file mode 100644 Binary files a/hashed-storage/testdata.zip and /dev/null differ diff --git a/release/distributed-context b/release/distributed-context --- a/release/distributed-context +++ b/release/distributed-context @@ -1,1 +1,1 @@ -Just "\nContext:\n\n[TAG 2.10.3\nGuillaume Hoffmann **20160129115730\n Ignore-this: 7eac9bf53015a285c43e6ea2b1e11a1d\n] \n" +Just "\nContext:\n\n[TAG 2.12.0\nGuillaume Hoffmann **20160429142058\n Ignore-this: 5c8cbe0424942686a2168f9e6fd8e35d\n] \n" diff --git a/src/Bundled/Posix.hsc b/src/Bundled/Posix.hsc new file mode 100644 --- /dev/null +++ b/src/Bundled/Posix.hsc @@ -0,0 +1,116 @@ +{-# LANGUAGE CPP, RankNTypes #-} + +module Bundled.Posix( getFdStatus, getSymbolicLinkStatus, getFileStatus + , getFileStatusBS + , fileExists + , modificationTime, fileSize, FileStatus + , EpochTime, isDirectory, isRegularFile ) where + +import qualified Data.ByteString.Char8 as BS +#if mingw32_HOST_OS +#else +import Data.ByteString.Unsafe( unsafeUseAsCString ) +#endif +import Foreign.Marshal.Alloc ( allocaBytes ) +import Foreign.C.Error ( throwErrno, getErrno, eNOENT ) +import Foreign.C.Types ( CTime, CInt ) +import Foreign.Ptr ( Ptr ) + +import System.Posix.Internals + ( CStat, c_fstat, sizeof_stat + , st_mode, st_size, st_mtime, s_isdir, s_isreg ) +#if mingw32_HOST_OS +import System.Posix.Internals ( c_stat, CFilePath ) +#endif + +import System.Posix.Types ( Fd(..), CMode, EpochTime ) + +#if mingw32_HOST_OS +import Foreign.C.String( withCWString, CWString ) +#else +import Foreign.C.String ( withCString, CString ) +#endif + +#if mingw32_HOST_OS +import Data.Int ( Int64 ) + +type FileOffset = Int64 +lstat :: CFilePath -> Ptr CStat -> IO CInt +lstat = c_stat +#else +import System.Posix.Types ( FileOffset ) +import System.Posix.Internals( lstat ) +#endif + +#if mingw32_HOST_OS +bsToPath :: forall a. BS.ByteString -> (CWString -> IO a) -> IO a +bsToPath s f = withCWString (BS.unpack s) f +strToPath :: forall a. String -> (CWString -> IO a) -> IO a +strToPath = withCWString +#else +bsToPath :: forall a. BS.ByteString -> (CString -> IO a) -> IO a +bsToPath = unsafeUseAsCString +strToPath :: forall a. String -> (CString -> IO a) -> IO a +strToPath = withCString +#endif + +data FileStatus = FileStatus { + fst_exists :: !Bool, + fst_mode :: !CMode, + fst_mtime :: !CTime, + fst_size :: !FileOffset + } + +getFdStatus :: Fd -> IO FileStatus +getFdStatus (Fd fd) = do + do_stat (c_fstat fd) + +do_stat :: (Ptr CStat -> IO CInt) -> IO FileStatus +do_stat stat_func = do + allocaBytes sizeof_stat $! \p -> do + ret <- stat_func p + if (ret == -1) then do err <- getErrno + if (err == eNOENT) + then return $! (FileStatus False 0 0 0) + else throwErrno "do_stat" + else do mode <- st_mode p + mtime <- st_mtime p + size <- st_size p + return $! FileStatus True mode mtime size +{-# INLINE do_stat #-} + +isDirectory :: FileStatus -> Bool +isDirectory = s_isdir . fst_mode + +isRegularFile :: FileStatus -> Bool +isRegularFile = s_isreg . fst_mode + +modificationTime :: FileStatus -> EpochTime +modificationTime = fst_mtime + +fileSize :: FileStatus -> FileOffset +fileSize = fst_size + +fileExists :: FileStatus -> Bool +fileExists = fst_exists + +#include + +-- lstat is broken on win32 with at least GHC 6.10.3 +getSymbolicLinkStatus :: FilePath -> IO FileStatus +##if mingw32_HOST_OS +getSymbolicLinkStatus = getFileStatus +##else +getSymbolicLinkStatus fp = + do_stat (\p -> (fp `strToPath` (`lstat` p))) +##endif + +getFileStatus :: FilePath -> IO FileStatus +getFileStatus fp = + do_stat (\p -> (fp `strToPath` (`lstat` p))) + +-- | Requires NULL-terminated bytestring -> unsafe! Use with care. +getFileStatusBS :: BS.ByteString -> IO FileStatus +getFileStatusBS fp = + do_stat (\p -> (fp `bsToPath` (`lstat` p))) +{-# INLINE getFileStatusBS #-} diff --git a/src/Darcs/Patch.hs b/src/Darcs/Patch.hs --- a/src/Darcs/Patch.hs +++ b/src/Darcs/Patch.hs @@ -16,13 +16,14 @@ -- Boston, MA 02110-1301, USA. {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP, UndecidableInstances #-} -- XXX Undecidable only in GHC < 7 - module Darcs.Patch ( RepoPatch + , RepoType + , IsRepoType , PrimOf , Named + , WrappedNamed , Patchy , fromPrim , fromPrims @@ -62,6 +63,7 @@ , invert , invertFL , invertRL + , commuteFL , commuteFLorComplain , commuteRL , readPatch @@ -74,6 +76,7 @@ , applyToFilePaths , apply , applyToTree + , maybeApplyToTree , effectOnFilePaths , patch2patchinfo , summary @@ -89,8 +92,8 @@ import Darcs.Patch.Apply ( applyToFilePaths, effectOnFilePaths, applyToTree, - ApplyState ) -import Darcs.Patch.Commute ( commuteFLorComplain, commuteRL ) + maybeApplyToTree, ApplyState ) +import Darcs.Patch.Commute ( commuteFL, commuteFLorComplain, commuteRL ) import Darcs.Patch.Conflict ( listConflictedFiles, resolveConflicts ) import Darcs.Patch.Effect ( Effect(effect) ) import Darcs.Patch.Invert ( invertRL, invertFL ) @@ -100,6 +103,7 @@ getdeps, infopatch, patch2patchinfo, patchname, patchcontents ) +import Darcs.Patch.Named.Wrapped ( WrappedNamed ) import Darcs.Patch.Patchy ( Patchy, showPatch, showNicely, showContextPatch, invert, @@ -118,14 +122,15 @@ tryToShrink, PrimPatch, PrimPatchBase(..) ) import Darcs.Patch.Read ( readPatch, readPatchPartial ) -import Darcs.Patch.Rebase.NameHack ( NameHack ) import Darcs.Patch.Repair ( isInconsistent ) import Darcs.Patch.RepoPatch ( RepoPatch ) +import Darcs.Patch.RepoType ( RepoType, IsRepoType ) import Darcs.Patch.Summary ( xmlSummary, plainSummary, plainSummaryPrims ) import Darcs.Patch.TokenReplace ( forceTokReplace ) import Darcs.Patch.V1.Commute ( merge ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) -instance (Patchy p, NameHack p, ApplyState p ~ Tree) => Patchy (Named p) +instance (Patchy p, ApplyState p ~ Tree) => Patchy (Named p) +instance (Patchy p, ApplyState p ~ Tree) => Patchy (WrappedNamed rt p) diff --git a/src/Darcs/Patch/Annotate.hs b/src/Darcs/Patch/Annotate.hs --- a/src/Darcs/Patch/Annotate.hs +++ b/src/Darcs/Patch/Annotate.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# LANGUAGE CPP, OverloadedStrings, TypeSynonymInstances, MultiParamTypeClasses #-} -- Copyright (C) 2010 Petr Rockai @@ -40,7 +39,8 @@ , AnnotateResult ) where -import Prelude hiding ( pi ) +import Prelude () +import Darcs.Prelude import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC @@ -52,15 +52,14 @@ import Data.Maybe( isJust, mapMaybe ) import Control.Monad.State ( modify, when, gets, State, execState ) -import Control.Applicative( (<$>) ) -import Darcs.Patch.ApplyMonad( ApplyMonad(..) ) +import Darcs.Patch.ApplyMonad( ApplyMonad(..), ApplyMonadTree(..) ) import Darcs.Patch.Apply ( Apply, apply, ApplyState ) import Darcs.Patch.Info ( PatchInfo(..), showPatchInfoUI, piAuthor, makePatchname ) import Darcs.Patch.PatchInfoAnd( info, PatchInfoAnd ) import Darcs.Patch.Witnesses.Ordered -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) import Darcs.Util.Path ( FileName, movedirfilename, fn2ps, ps2fn ) import Darcs.Util.Printer( renderString, RenderMode(..) ) import Darcs.Util.ByteString ( linesPS, unlinesPS ) @@ -87,14 +86,14 @@ type AnnotatedM = State Annotated --- XXX: No explicit method nor default method for 'editFile', 'editDirectory' -instance ApplyMonad AnnotatedM Tree where +instance ApplyMonad Tree AnnotatedM where type ApplyMonadBase AnnotatedM = AnnotatedM nestedApply _ _ = undefinedFun "nestedApply" liftApply _ _ = undefinedFun "liftApply" getApplyState = undefinedFun "getApplyState" - putApplyState _ = undefinedFun "putApplyState" + +instance ApplyMonadTree AnnotatedM where mReadFilePS = undefinedFun "mReadFilePS" mDoesFileExist _ = return True @@ -177,7 +176,7 @@ annotate' :: (Apply p, ApplyState p ~ Tree) - => FL (PatchInfoAnd p) wX wY + => FL (PatchInfoAnd rt p) wX wY -> Annotated -> Annotated annotate' NilFL ann = ann @@ -188,7 +187,7 @@ annotate :: (Apply p, ApplyState p ~ Tree) => D.DiffAlgorithm - -> FL (PatchInfoAnd p) wX wY + -> FL (PatchInfoAnd rt p) wX wY -> FileName -> B.ByteString -> AnnotateResult @@ -206,7 +205,7 @@ annotateDirectory :: (Apply p, ApplyState p ~ Tree) => D.DiffAlgorithm - -> FL (PatchInfoAnd p) wX wY + -> FL (PatchInfoAnd rt p) wX wY -> FileName -> [FileName] -> AnnotateResult diff --git a/src/Darcs/Patch/Apply.hs b/src/Darcs/Patch/Apply.hs --- a/src/Darcs/Patch/Apply.hs +++ b/src/Darcs/Patch/Apply.hs @@ -33,19 +33,20 @@ , applyToFilePaths , applyToTree , applyToState + , maybeApplyToTree , applyToFileMods , effectOnFilePaths ) where -import Prelude hiding ( catch, pi ) +import Prelude () +import Darcs.Prelude import Data.Set ( Set ) -import Control.Applicative ( (<$>) ) +import Control.Exception ( catch, IOException ) import Control.Arrow ( (***) ) -import Storage.Hashed.Tree( Tree ) -import Storage.Hashed.Monad( virtualTreeMonad ) +import Darcs.Util.Tree( Tree ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..), withFileNames, ApplyMonadTrans(..) ) import Darcs.Util.Path( FileName, fn2fp, fp2fn ) @@ -55,7 +56,7 @@ class Apply p where type ApplyState p :: (* -> *) -> * - apply :: ApplyMonad m (ApplyState p) => p wX wY -> m () + apply :: ApplyMonad (ApplyState p) m => p wX wY -> m () instance Apply p => Apply (FL p) where type ApplyState (FL p) = ApplyState p @@ -93,15 +94,21 @@ => p wX wY -> Tree m -> m (Tree m) -applyToTree patch t = snd <$> virtualTreeMonad (apply patch) t - +applyToTree = applyToState -applyToState :: forall p m wX wY. (Apply p, ApplyMonadTrans m (ApplyState p)) +applyToState :: forall p m wX wY. (Apply p, ApplyMonadTrans (ApplyState p) m) => p wX wY -> (ApplyState p) m -> m ((ApplyState p) m) applyToState patch t = snd <$> runApplyMonad (apply patch) t +-- | Attempts to apply a given replace patch to a Tree. If the apply fails (if +-- the file the patch applies to already contains the target token), we return +-- Nothing, otherwise we return the updated Tree. +maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Tree IO + -> IO (Maybe (Tree IO)) +maybeApplyToTree patch tree = + (Just `fmap` applyToTree patch tree) `catch` (\(_ :: IOException) -> return Nothing) -------------------------------------------------------------------------------- -- | Apply a patch to set of 'FileName's, yielding the new set of 'FileName's and 'PatchMod's diff --git a/src/Darcs/Patch/ApplyMonad.hs b/src/Darcs/Patch/ApplyMonad.hs --- a/src/Darcs/Patch/ApplyMonad.hs +++ b/src/Darcs/Patch/ApplyMonad.hs @@ -1,5 +1,9 @@ {-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-} -{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses + , ConstraintKinds, UndecidableInstances, CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif -- Copyright (C) 2010, 2011 Petr Rockai -- -- Permission is hereby granted, free of charge, to any person @@ -21,14 +25,21 @@ -- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. -module Darcs.Patch.ApplyMonad( ApplyMonad(..), ApplyMonadTrans(..), withFileNames, withFiles, ToTree(..) ) where +module Darcs.Patch.ApplyMonad + ( ApplyMonad(..), ApplyMonadTrans(..), ApplyMonadState(..) + , withFileNames, withFiles, ToTree(..) + , ApplyMonadTree(..) + ) where +import Prelude () +import Darcs.Prelude + import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Map as M -import qualified Storage.Hashed.Monad as HSM +import qualified Darcs.Util.Tree.Monad as TM +import Darcs.Util.Tree ( Tree ) import Data.Maybe ( fromMaybe ) -import Storage.Hashed.Tree ( Tree ) import Darcs.Util.ByteString( linesPS, unlinesPS ) import Darcs.Util.Path ( FileName, movedirfilename, fn2fp, isParentOrEqOf, floatPath, AnchoredPath ) @@ -36,8 +47,7 @@ import Control.Monad.Identity( Identity ) import Darcs.Patch.MonadProgress --- TODO should UUID/Object live somewhere more central? -import Darcs.Patch.Prim.V3.ObjectMap ( UUID, ObjectMap, DirContent ) +import GHC.Exts ( Constraint ) fn2ap :: FileName -> AnchoredPath fn2ap = floatPath . fn2fp @@ -48,19 +58,46 @@ instance ToTree Tree where toTree = id -class (Functor m, Monad m, ApplyMonad (ApplyMonadOver m state) state) - => ApplyMonadTrans m (state :: (* -> *) -> *) where - type ApplyMonadOver m state :: * -> * - runApplyMonad :: (ApplyMonadOver m state) x -> state m -> m (x, state m) +class (Functor m, Monad m, ApplyMonad state (ApplyMonadOver state m)) + => ApplyMonadTrans (state :: (* -> *) -> *) m where + type ApplyMonadOver state m :: * -> * + runApplyMonad :: (ApplyMonadOver state m) x -> state m -> m (x, state m) -instance (Functor m, Monad m) => ApplyMonadTrans m Tree where - type ApplyMonadOver m Tree = HSM.TreeMonad m - runApplyMonad = HSM.virtualTreeMonad +instance (Functor m, Monad m) => ApplyMonadTrans Tree m where + type ApplyMonadOver Tree m = TM.TreeMonad m + runApplyMonad = TM.virtualTreeMonad -class (Functor m, Monad m, Functor (ApplyMonadBase m), Monad (ApplyMonadBase m), ToTree state) +class ApplyMonadState (state :: (* -> *) -> *) where + type ApplyMonadStateOperations state :: (* -> *) -> Constraint + +class (Functor m, Monad m) => ApplyMonadTree m where + -- a semantic, Tree-based interface for patch application + mDoesDirectoryExist :: FileName -> m Bool + mDoesFileExist :: FileName -> m Bool + mReadFilePS :: FileName -> m B.ByteString + mReadFilePSs :: FileName -> m [B.ByteString] + mReadFilePSs f = linesPS `fmap` mReadFilePS f + mCreateDirectory :: FileName -> m () + mRemoveDirectory :: FileName -> m () + mCreateFile :: FileName -> m () + mCreateFile f = mModifyFilePS f $ \_ -> return B.empty + mRemoveFile :: FileName -> m () + mRename :: FileName -> FileName -> m () + mModifyFilePS :: FileName -> (B.ByteString -> m B.ByteString) -> m () + mModifyFilePSs :: FileName -> ([B.ByteString] -> m [B.ByteString]) -> m () + mModifyFilePSs f j = mModifyFilePS f (fmap unlinesPS . j . linesPS) + mChangePref :: String -> String -> String -> m () + mChangePref _ _ _ = return () + +instance ApplyMonadState Tree where + type ApplyMonadStateOperations Tree = ApplyMonadTree + +class ( Functor m, Monad m, Functor (ApplyMonadBase m), Monad (ApplyMonadBase m) + , ApplyMonadStateOperations state m, ToTree state + ) -- ApplyMonadOver (ApplyMonadBase m) ~ m is *not* required in general, -- since ApplyMonadBase is not injective - => ApplyMonad m (state :: (* -> *) -> *) where + => ApplyMonad (state :: (* -> *) -> *) m where type ApplyMonadBase m :: * -> * nestedApply :: m x -> state (ApplyMonadBase m) -> m (x, state (ApplyMonadBase m)) @@ -68,50 +105,27 @@ -> m (x, state (ApplyMonadBase m)) getApplyState :: m (state (ApplyMonadBase m)) - putApplyState :: state m -> m () - -- a semantic, ObjectMap-based interface for patch application - editFile :: (state ~ ObjectMap) => UUID -> (B.ByteString -> B.ByteString) -> m () - editDirectory :: (state ~ ObjectMap) => UUID -> (DirContent -> DirContent) -> m () - - -- a semantic, Tree-based interface for patch application - mDoesDirectoryExist :: (state ~ Tree) => FileName -> m Bool - mDoesFileExist :: (state ~ Tree) => FileName -> m Bool - mReadFilePS :: (state ~ Tree) => FileName -> m B.ByteString - mReadFilePSs :: (state ~ Tree) => FileName -> m [B.ByteString] - mReadFilePSs f = linesPS `fmap` mReadFilePS f - mCreateDirectory :: (state ~ Tree) => FileName -> m () - mRemoveDirectory :: (state ~ Tree) => FileName -> m () - mCreateFile :: (state ~ Tree) => FileName -> m () - mCreateFile f = mModifyFilePS f $ \_ -> return B.empty - mRemoveFile :: (state ~ Tree) => FileName -> m () - mRename :: (state ~ Tree) => FileName -> FileName -> m () - mModifyFilePS :: (state ~ Tree) => FileName -> (B.ByteString -> m B.ByteString) -> m () - mModifyFilePSs :: (state ~ Tree) => FileName -> ([B.ByteString] -> m [B.ByteString]) -> m () - mModifyFilePSs f j = mModifyFilePS f (fmap unlinesPS . j . linesPS) - mChangePref :: (state ~ Tree) => String -> String -> String -> m () - mChangePref _ _ _ = return () - -instance (Functor m, Monad m) => ApplyMonad (HSM.TreeMonad m) Tree where - type ApplyMonadBase (HSM.TreeMonad m) = m - getApplyState = gets HSM.tree +instance (Functor m, Monad m) => ApplyMonad Tree (TM.TreeMonad m) where + type ApplyMonadBase (TM.TreeMonad m) = m + getApplyState = gets TM.tree nestedApply a start = lift $ runApplyMonad a start - liftApply a start = do x <- gets HSM.tree + liftApply a start = do x <- gets TM.tree lift $ runApplyMonad (lift $ a x) start - -- putApplyState needs some support from HSM +instance (Functor m, Monad m) => ApplyMonadTree (TM.TreeMonad m) where - mDoesDirectoryExist d = HSM.directoryExists (fn2ap d) - mDoesFileExist d = HSM.fileExists (fn2ap d) - mReadFilePS p = B.concat `fmap` BL.toChunks `fmap` HSM.readFile (fn2ap p) - mModifyFilePS p j = do have <- HSM.fileExists (fn2ap p) - x <- if have then B.concat `fmap` BL.toChunks `fmap` HSM.readFile (fn2ap p) + mDoesDirectoryExist d = TM.directoryExists (fn2ap d) + mDoesFileExist d = TM.fileExists (fn2ap d) + mReadFilePS p = B.concat `fmap` BL.toChunks `fmap` TM.readFile (fn2ap p) + mModifyFilePS p j = do have <- TM.fileExists (fn2ap p) + x <- if have then B.concat `fmap` BL.toChunks `fmap` TM.readFile (fn2ap p) else return B.empty - HSM.writeFile (fn2ap p) . BL.fromChunks . (:[]) =<< j x - mCreateDirectory p = HSM.createDirectory (fn2ap p) - mRename from to = HSM.rename (fn2ap from) (fn2ap to) - mRemoveDirectory = HSM.unlink . fn2ap - mRemoveFile = HSM.unlink . fn2ap + TM.writeFile (fn2ap p) . BL.fromChunks . (:[]) =<< j x + mCreateDirectory p = TM.createDirectory (fn2ap p) + mRename from to = TM.rename (fn2ap from) (fn2ap to) + mRemoveDirectory = TM.unlink . fn2ap + mRemoveFile = TM.unlink . fn2ap -- Latest name, current original name. type OrigFileNameOf = (FileName, FileName) @@ -138,8 +152,11 @@ withFileNames mbofnos fps x = execState x ([], fps, ofnos) where ofnos = fromMaybe (map (\y -> (y, y)) fps) mbofnos -instance ApplyMonad FilePathMonad Tree where +instance ApplyMonad Tree FilePathMonad where type ApplyMonadBase FilePathMonad = Identity + + +instance ApplyMonadTree FilePathMonad where -- We can't check it actually is a directory here mDoesDirectoryExist d = gets $ \(_, fs, _) -> d `elem` fs @@ -158,8 +175,10 @@ type RestrictedApply = State (M.Map FileName B.ByteString) -instance ApplyMonad RestrictedApply Tree where +instance ApplyMonad Tree RestrictedApply where type ApplyMonadBase RestrictedApply = Identity + +instance ApplyMonadTree RestrictedApply where mDoesDirectoryExist _ = return True mCreateDirectory _ = return () mRemoveFile f = modify $ M.delete f diff --git a/src/Darcs/Patch/ApplyPatches.hs b/src/Darcs/Patch/ApplyPatches.hs --- a/src/Darcs/Patch/ApplyPatches.hs +++ b/src/Darcs/Patch/ApplyPatches.hs @@ -12,8 +12,8 @@ import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL ) import Darcs.Util.Printer ( text, ($$) ) -applyPatches :: (MonadProgress m, ApplyMonad m (ApplyState p), Patchy p) - => FL (PatchInfoAnd p) wX wY -> m () +applyPatches :: (MonadProgress m, ApplyMonad (ApplyState p) m, Patchy p) + => FL (PatchInfoAnd rt p) wX wY -> m () applyPatches ps = runProgressActions "Applying patch" (mapFL doApply ps) where doApply hp = ProgressAction { paAction = apply (hopefully hp) diff --git a/src/Darcs/Patch/Bracketed.hs b/src/Darcs/Patch/Bracketed.hs --- a/src/Darcs/Patch/Bracketed.hs +++ b/src/Darcs/Patch/Bracketed.hs @@ -3,6 +3,8 @@ , BracketedFL, mapBracketedFLFL, unBracketedFL ) where +import Prelude () +import Darcs.Prelude import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, concatFL ) diff --git a/src/Darcs/Patch/Bracketed/Instances.hs b/src/Darcs/Patch/Bracketed/Instances.hs --- a/src/Darcs/Patch/Bracketed/Instances.hs +++ b/src/Darcs/Patch/Bracketed/Instances.hs @@ -2,12 +2,34 @@ module Darcs.Patch.Bracketed.Instances () where import Darcs.Patch.Bracketed ( Bracketed(..) ) +import Darcs.Patch.Effect ( Effect(..) ) +import Darcs.Patch.Prim ( FromPrim(..), PrimPatchBase(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(NilFL), mapFL ) import Darcs.Util.Printer ( vcat, blueText, ($$) ) +-- The PrimPatchBase, Effect and FromPrim instances are only +-- needed (by Darcs.Patch.Bundle) because the ReadPatch instance for +-- WrappedNamed unconditionally has them as requirements even though +-- they are only needed for the 'IsRebase case which isn't itself used +-- by Darcs.Patch.Bundle. +-- TODO see if this can be simplified +instance PrimPatchBase p => PrimPatchBase (Bracketed p) where + type PrimOf (Bracketed p) = PrimOf p + +instance Effect p => Effect (Bracketed p) where + effect (Singleton p) = effect p + effect (Braced ps) = effect ps + effect (Parens ps) = effect ps + + effectRL (Singleton p) = effectRL p + effectRL (Braced ps) = effectRL ps + effectRL (Parens ps) = effectRL ps + +instance FromPrim p => FromPrim (Bracketed p) where + fromPrim p = Singleton (fromPrim p) instance ShowPatchBasic p => ShowPatchBasic (Bracketed p) where showPatch (Singleton p) = showPatch p diff --git a/src/Darcs/Patch/Bundle.hs b/src/Darcs/Patch/Bundle.hs --- a/src/Darcs/Patch/Bundle.hs +++ b/src/Darcs/Patch/Bundle.hs @@ -30,15 +30,18 @@ , parseBundle ) where +import Prelude () +import Darcs.Prelude + import Data.Char ( isAlpha, toLower, isDigit, isSpace ) import qualified Data.ByteString as B ( ByteString, length, null, drop, isPrefixOf ) import qualified Data.ByteString.Char8 as BC ( unpack, break, pack ) -import Storage.Hashed.Tree( Tree ) -import Storage.Hashed.Monad( virtualTreeIO ) +import Darcs.Util.Tree( Tree ) +import Darcs.Util.Tree.Monad( virtualTreeIO ) -import Darcs.Patch ( RepoPatch, Named, showPatch, showContextPatch, +import Darcs.Patch ( RepoPatch, showPatch, showContextPatch, readPatchPartial ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Bracketed ( Bracketed, unBracketedFL ) @@ -48,9 +51,13 @@ import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, showPatchInfoUI, isTag ) +import Darcs.Patch.Named.Wrapped ( WrappedNamed ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, piap, fmapFLPIAP, info, - patchInfoAndPatch, unavailable, hopefully ) + patchInfoAndPatch, unavailable, hopefully, + generaliseRepoTypePIAP + ) import Darcs.Patch.ReadMonads ( parseStrictly ) +import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin ) import Darcs.Patch.Show ( ShowPatchBasic ) import Darcs.Patch.Witnesses.Ordered @@ -67,16 +74,16 @@ -- |hashBundle creates a SHA1 string of a given a FL of named patches. This -- allows us to ensure that the patches in a received patchBundle have not been -- modified in transit. -hashBundle :: (PatchListFormat p, ShowPatchBasic p) => FL (Named p) wX wY +hashBundle :: (PatchListFormat p, ShowPatchBasic p) => FL (WrappedNamed rt p) wX wY -> String hashBundle to_be_sent = show $ sha1PS $ renderPS Standard $ vcat (mapFL showPatch to_be_sent) <> newline makeBundleN :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO) - -> PatchSet p wStart wX -> FL (Named p) wX wY -> IO Doc -makeBundleN the_s (PatchSet ps (Tagged t _ _ :<: _)) to_be_sent = - makeBundle2 the_s (ps +<+ (t :<: NilRL)) to_be_sent to_be_sent -makeBundleN the_s (PatchSet ps NilRL) to_be_sent = + -> PatchSet rt p wStart wX -> FL (WrappedNamed rt p) wX wY -> IO Doc +makeBundleN the_s (PatchSet (_ :<: Tagged t _ _) ps) to_be_sent = + makeBundle2 the_s ((NilRL :<: t) +<+ ps) to_be_sent to_be_sent +makeBundleN the_s (PatchSet NilRL ps) to_be_sent = makeBundle2 the_s ps to_be_sent to_be_sent -- | In makeBundle2, it is presumed that the two patch sequences are @@ -85,8 +92,8 @@ -- generated, which is not the end of the world, but isn't very useful -- either. makeBundle2 :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO) - -> RL (PatchInfoAnd p) wStart wX -> FL (Named p) wX wY - -> FL (Named p) wX wY -> IO Doc + -> RL (PatchInfoAnd rt p) wStart wX -> FL (WrappedNamed rt p) wX wY + -> FL (WrappedNamed rt p) wX wY -> IO Doc makeBundle2 the_s common' to_be_sent to_be_sent2 = do patches <- case the_s of Just tree -> fst `fmap` virtualTreeIO (showContextPatch to_be_sent) tree @@ -106,9 +113,9 @@ $$ text "" common = mapRL info common' -parseBundle :: forall p. RepoPatch p => B.ByteString +parseBundle :: forall rt p. RepoPatch p => B.ByteString -> Either String - (Sealed ((PatchSet p :> FL (PatchInfoAnd p)) Origin)) + (Sealed ((PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin)) parseBundle input | B.null input = Left "Bad patch bundle!" parseBundle input = case sillyLex input of ("New patches:", rest) -> case getPatches rest of @@ -147,28 +154,34 @@ sealCtxAndPs ctx ps = Right $ sealContextWithPatches ctx ps sealContextWithPatches :: RepoPatch p => [PatchInfo] - -> FL (PatchInfoAnd (Bracketed p)) wX wY + -> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY -> Sealed - ((PatchSet p :> FL (PatchInfoAnd p)) Origin) + ((PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin) sealContextWithPatches context bracketedPatches = - let patches = mapFL_FL (fmapFLPIAP unBracketedFL) bracketedPatches in + let -- witness to fmapFLPIAP that the bundle won't contain stash/rebase patches + -- TODO use EmptyCase with GHC 7.8+ + notRebasing _ + = error "internal error: unreachable case (Darcs.Patch.Bundle.parseBundle.notRebasing)" + patches = mapFL_FL (generaliseRepoTypePIAP . fmapFLPIAP unBracketedFL notRebasing) + bracketedPatches + in case reverse context of (x : ry) | isTag x -> let ps = unavailablePatches (reverse ry) t = Tagged (piUnavailable x) Nothing NilRL in - Sealed $ PatchSet ps (t :<: NilRL) :> patches - _ -> let ps = PatchSet (unavailablePatches context) NilRL in + Sealed $ PatchSet (NilRL :<: t) ps :> patches + _ -> let ps = PatchSet NilRL (unavailablePatches context) in Sealed $ ps :> patches -- The above NilRLs aren't quite right, because ther *are* -- earlier patches, but we can't set this to undefined -- because there are situations where we look at the rest. -- :{ -scanBundle :: forall p . RepoPatch p => B.ByteString - -> Either String (SealedPatchSet p Origin) +scanBundle :: forall rt p . RepoPatch p => B.ByteString + -> Either String (SealedPatchSet rt p Origin) scanBundle bundle = do - Sealed (PatchSet recent tagged :> ps) <- parseBundle bundle - return . Sealed $ PatchSet (reverseFL ps +<+ recent) tagged + Sealed (PatchSet tagged recent :> ps) <- parseBundle bundle + return . Sealed $ PatchSet tagged (recent +<+ reverseFL ps) -- |filterGpgDashes unescapes a clearsigned patch, which will have had any -- lines starting with dashes escaped with a leading "- ". @@ -188,12 +201,12 @@ -- |unavailablePatches converts a list of PatchInfos into a RL of PatchInfoAnd -- Unavailable patches. This is used to represent the Context of a patchBundle. -unavailablePatches :: RepoPatch p => [PatchInfo] -> RL (PatchInfoAnd p) wX wY -unavailablePatches = foldr ((:<:) . piUnavailable) (unsafeCoerceP NilRL) +unavailablePatches :: RepoPatch p => [PatchInfo] -> RL (PatchInfoAnd rt p) wX wY +unavailablePatches = foldr (flip (:<:) . piUnavailable) (unsafeCoerceP NilRL) -- |piUnavailable returns an Unavailable within a PatchInfoAnd given a -- PatchInfo. -piUnavailable :: RepoPatch p => PatchInfo -> PatchInfoAnd p wX wY +piUnavailable :: RepoPatch p => PatchInfo -> PatchInfoAnd rt p wX wY piUnavailable i = patchInfoAndPatch i . unavailable $ "Patch not stored in patch bundle:\n" ++ renderString Encode (showPatchInfoUI i) @@ -214,7 +227,7 @@ -- returning the FL of as many patches-with-info as were successfully parsed, -- along with any unconsumed input. getPatches :: RepoPatch p => B.ByteString - -> (Sealed (FL (PatchInfoAnd (Bracketed p)) wX), B.ByteString) + -> (Sealed (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX), B.ByteString) getPatches ps = case parseStrictly readPatchInfo ps of Nothing -> (Sealed NilFL, ps) Just (pinfo, _) -> case readPatchPartial ps of @@ -229,19 +242,19 @@ where (a, b) = BC.break (== '\n') (dropSpace ps) -contextPatches :: RepoPatch p => PatchSet p Origin wX - -> (PatchSet p :> RL (PatchInfoAnd p)) Origin wX +contextPatches :: RepoPatch p => PatchSet rt p Origin wX + -> (PatchSet rt p :> RL (PatchInfoAnd rt p)) Origin wX contextPatches set = case slightlyOptimizePatchset set of - PatchSet ps (Tagged t _ ps' :<: ts) -> - PatchSet ps' ts :> (ps +<+ (t :<: NilRL)) - PatchSet ps NilRL -> PatchSet NilRL NilRL :> ps + PatchSet (ts :<: Tagged t _ ps') ps -> + PatchSet ts ps' :> ((NilRL :<: t) +<+ ps) + PatchSet NilRL ps -> PatchSet NilRL NilRL :> ps -- |'scanContextFile' scans the context in the file of the given name. -scanContextFile :: RepoPatch p => FilePath -> IO (PatchSet p Origin wX) +scanContextFile :: RepoPatch p => FilePath -> IO (PatchSet rt p Origin wX) scanContextFile filename = scanContext `fmap` mmapFilePS filename where -- are the type witnesses sensible? - scanContext :: RepoPatch p => B.ByteString -> PatchSet p Origin wX + scanContext :: RepoPatch p => B.ByteString -> PatchSet rt p Origin wX scanContext input | B.null input = error "Bad context!" | otherwise = case sillyLex input of @@ -249,8 +262,8 @@ (cont@(_ : _), _) | isTag (last cont) -> let ps = unavailablePatches $ init cont t = Tagged (piUnavailable $ last cont) Nothing NilRL in - PatchSet ps (t :<: NilRL) - (cont, _) -> PatchSet (unavailablePatches cont) NilRL + PatchSet (NilRL :<: t) ps + (cont, _) -> PatchSet NilRL (unavailablePatches cont) ("-----BEGIN PGP SIGNED MESSAGE-----",rest) -> scanContext $ filterGpgDashes rest (_, rest) -> scanContext rest @@ -258,20 +271,20 @@ -- | Minimize the context of a bundle to be sent, taking into account -- the patches selected to be sent minContext :: (RepoPatch p) - => PatchSet p wStart wB - -> FL (PatchInfoAnd p) wB wC - -> Sealed ((PatchSet p :> FL (PatchInfoAnd p)) wStart) -minContext (PatchSet topCommon behindTag) to_be_sent = + => PatchSet rt p wStart wB + -> FL (PatchInfoAnd rt p) wB wC + -> Sealed ((PatchSet rt p :> FL (PatchInfoAnd rt p)) wStart) +minContext (PatchSet behindTag topCommon) to_be_sent = case go topCommon NilFL to_be_sent of - Sealed (c :> to_be_sent') -> seal (PatchSet c behindTag :> to_be_sent') + Sealed (c :> to_be_sent') -> seal (PatchSet behindTag c :> to_be_sent') where go :: (RepoPatch p) - => RL (PatchInfoAnd p) wA wB -- context we attempt to minimize - -> FL (PatchInfoAnd p) wB wC -- patches we cannot remove from context - -> FL (PatchInfoAnd p) wC wD -- patches to be included in the bundle - -> Sealed (( RL (PatchInfoAnd p) :> FL (PatchInfoAnd p) ) wA ) + => RL (PatchInfoAnd rt p) wA wB -- context we attempt to minimize + -> FL (PatchInfoAnd rt p) wB wC -- patches we cannot remove from context + -> FL (PatchInfoAnd rt p) wC wD -- patches to be included in the bundle + -> Sealed (( RL (PatchInfoAnd rt p) :> FL (PatchInfoAnd rt p) ) wA ) go NilRL necessary to_be_sent' = seal (reverseFL necessary :> to_be_sent') - go (candidate :<: rest) necessary to_be_sent' = + go (rest :<: candidate) necessary to_be_sent' = let fl1 = (candidate :>: NilFL) in case commute (fl1 :> necessary) of Nothing -> go rest (candidate :>: necessary) to_be_sent' diff --git a/src/Darcs/Patch/Choices.hs b/src/Darcs/Patch/Choices.hs --- a/src/Darcs/Patch/Choices.hs +++ b/src/Darcs/Patch/Choices.hs @@ -54,11 +54,14 @@ forceMatchingFirst, forceMatchingLast, selectAllMiddles, makeUncertain, makeEverythingLater, makeEverythingSooner, - LabelledPatch, Label, label, lpPatch, + LabelledPatch, Label, label, lpPatch, getLabelInt, Slot(..), substitute ) where +import Prelude () +import Darcs.Prelude + import Control.Monad.Identity ( Identity ) import Control.Monad.State ( StateT(..) ) @@ -114,6 +117,9 @@ label :: LabelledPatch p wX wY -> Label label (LP tg _) = tg +getLabelInt :: Label -> Integer +getLabelInt (Label _ i) = i + lpPatch :: LabelledPatch p wX wY -> p wX wY lpPatch (LP _ p) = p @@ -256,11 +262,11 @@ +>+ PC lp True :>: ls}) psLast firsts middles bubble (PC lp True :>: ls) = - psLast firsts middles (lp :<: bubble) ls + psLast firsts middles (bubble :<: lp) ls psLast firsts middles bubble (PC lp False :>: ls) = case commuteRL (bubble :> lp) of - Just (lp' :> bubble') -> psLast firsts (lp' :<: middles) bubble' ls - Nothing -> psLast firsts middles (lp :<: bubble) ls + Just (lp' :> bubble') -> psLast firsts (middles :<: lp') bubble' ls + Nothing -> psLast firsts middles (bubble :<: lp) ls psLast _ _ _ NilFL = impossible settleM middles = mapFL_FL (\lp -> PC lp False) $ reverseRL middles settleB bubble = mapFL_FL (\lp -> PC lp True) $ reverseRL bubble @@ -287,7 +293,7 @@ let f' = f +>+ mapFL_FL pcPatch (reverseRL deps) +>+ (pcPatch a' :>: NilFL) in fmfLasts f' l1' l2 - fmfLasts f l1 (a :>: l2) = fmfLasts f (a :<: l1) l2 + fmfLasts f l1 (a :>: l2) = fmfLasts f (l1 :<: a) l2 fmfLasts f l1 NilFL = PCs { pcsFirsts = f , pcsLasts = reverseRL l1 } pred_pc :: forall wX wY . PatchChoice p wX wY -> Bool @@ -316,9 +322,9 @@ PatchChoices p wX wY samf f1 f2 l1 (pc@(PC lp False) :>: l2) = case commuteRL (l1 :> pc) of - Nothing -> samf f1 f2 (PC lp True :<: l1) l2 - Just ((PC lp' _) :> l1') -> samf f1 (lp' :<: f2) l1' l2 - samf f1 f2 l1 (PC lp True :>: l2) = samf f1 f2 (PC lp True :<: l1) l2 + Nothing -> samf f1 f2 (l1 :<: PC lp True) l2 + Just ((PC lp' _) :> l1') -> samf f1 (f2 :<: lp') l1' l2 + samf f1 f2 l1 (PC lp True :>: l2) = samf f1 f2 (l1 :<: PC lp True) l2 samf f1 f2 l1 NilFL = PCs (f1 +>+ reverseRL f2) (reverseRL l1) forceMatchingLast :: Patchy p => (forall wX wY . LabelledPatch p wX wY -> Bool) @@ -341,7 +347,7 @@ l' = mapFL_FL (\lp -> PC lp b) (a' :>: deps) +>+ l in fmlFirst pred b f1 f2' l' -fmlFirst pred b f1 (a :>: f2) l = fmlFirst pred b (a :<: f1) f2 l +fmlFirst pred b f1 (a :>: f2) l = fmlFirst pred b (f1 :<: a) f2 l fmlFirst pred b f1 NilFL l = PCs { pcsFirsts = reverseRL f1 , pcsLasts = mapFL_FL ch l} where ch (PC lp c) = (PC lp (if pred lp then b else c) ) @@ -376,11 +382,11 @@ RL (LabelledPatch p) wM2 wM3 -> FL (PatchChoice p) wM3 wY -> (FL (LabelledPatch p) :> FL (PatchChoice p)) wM1 wY - mes middle bubble (PC lp True :>: ls) = mes middle (lp :<: bubble) ls + mes middle bubble (PC lp True :>: ls) = mes middle (bubble :<: lp) ls mes middle bubble (PC lp False :>: ls) = case commuteRL (bubble :> lp) of - Nothing -> mes middle (lp :<: bubble) ls - Just (lp' :> bubble') -> mes (lp' :<: middle) bubble' ls + Nothing -> mes middle (bubble :<: lp) ls + Just (lp' :> bubble') -> mes (middle :<: lp') bubble' ls mes middle bubble NilFL = (reverseRL middle) :> mapFL_FL (\lp -> PC lp False) (reverseRL bubble) -- | 'substitute' @(a :||: bs)@ @pcs@ replaces @a@ with @bs@ in @pcs@ preserving the choice diff --git a/src/Darcs/Patch/Commute.hs b/src/Darcs/Patch/Commute.hs --- a/src/Darcs/Patch/Commute.hs +++ b/src/Darcs/Patch/Commute.hs @@ -4,16 +4,17 @@ , commuteFLorComplain , commuteRL , commuteRLFL - , toFwdCommute - , toRevCommute , selfCommuter ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.CommuteFn ( CommuteFn ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), reverseFL, reverseRL, - (:>)(..), (:<)(..) ) + (:>)(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed2, seal2 ) -- | Commute represents things that can be (possibly) commuted. @@ -44,10 +45,10 @@ -- |'commuteRL' commutes a RL past a single element. commuteRL :: Commute p => (RL p :> p) wX wY -> Maybe ((p :> RL p) wX wY) -commuteRL (z :<: zs :> w) = do +commuteRL (zs :<: z :> w) = do w' :> z' <- commute (z :> w) w'' :> zs' <- commuteRL (zs :> w') - return (w'' :> z' :<: zs') + return (w'' :> zs' :<: z') commuteRL (NilRL :> w) = Just (w :> NilRL) -- |'commuteFL' commutes a single element past a FL. @@ -67,23 +68,6 @@ Right (ps' :> q'') -> Right (p' :>: ps' :> q'') Left l -> Left l Nothing -> Left $ seal2 p - --- | Swaps the ordered pair type so that commute can be called directly. -toFwdCommute :: (Commute p, Commute q, Monad m) => - ((p :< q) wX wY -> m ((q :< p) wX wY)) -> (q :> p) wX wY - -> m ((p :> q) wX wY) -toFwdCommute c (x :> y) = do - x' :< y' <- c (y :< x) - return (y' :> x') - --- | Swaps the ordered pair type from the order expected by commute to the --- reverse order. -toRevCommute :: (Commute p, Commute q, Monad m) => - ((p :> q) wX wY -> m ((q :> p) wX wY)) -> (q :< p) wX wY - -> m ((p :< q) wX wY) -toRevCommute c (x :< y) = do - x' :> y' <- c (y :> x) - return (y' :< x') -- |Build a commuter between a patch and itself using the operation from the type class. selfCommuter :: Commute p => CommuteFn p p diff --git a/src/Darcs/Patch/CommuteFn.hs b/src/Darcs/Patch/CommuteFn.hs --- a/src/Darcs/Patch/CommuteFn.hs +++ b/src/Darcs/Patch/CommuteFn.hs @@ -8,6 +8,9 @@ totalCommuterIdFL, totalCommuterFLId, totalCommuterFLFL ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Witnesses.Ordered ( (:>)(..) , (:\/:)(..) @@ -32,10 +35,10 @@ commuterIdRL :: CommuteFn p1 p2 -> CommuteFn p1 (RL p2) commuterIdRL _ (x :> NilRL) = return (NilRL :> x) -commuterIdRL commuter (x :> (y :<: ys)) +commuterIdRL commuter (x :> (ys :<: y)) = do ys' :> x' <- commuterIdRL commuter (x :> ys) y' :> x'' <- commuter (x' :> y) - return ((y' :<: ys') :> x'') + return ((ys' :<: y') :> x'') commuterIdFL :: CommuteFn p1 p2 -> CommuteFn p1 (FL p2) commuterIdFL _ (x :> NilFL) = return (NilFL :> x) @@ -67,10 +70,10 @@ commuterRLId :: CommuteFn p1 p2 -> CommuteFn (RL p1) p2 commuterRLId _ (NilRL :> y) = return (y :> NilRL) -commuterRLId commuter ((x :<: xs) :> y) +commuterRLId commuter ((xs :<: x) :> y) = do y' :> x' <- commuter (x :> y) y'' :> xs' <- commuterRLId commuter (xs :> y') - return (y'' :> (x' :<: xs')) + return (y'' :> (xs' :<: x')) totalCommuterFLId :: TotalCommuteFn p1 p2 -> TotalCommuteFn (FL p1) p2 totalCommuterFLId _ (NilFL :> y) = y :> NilFL diff --git a/src/Darcs/Patch/Conflict.hs b/src/Darcs/Patch/Conflict.hs --- a/src/Darcs/Patch/Conflict.hs +++ b/src/Darcs/Patch/Conflict.hs @@ -1,32 +1,46 @@ +-- Copyright (C) 2002-2003 David Roundy, 2010 Ganesh Sittampalam +{-# LANGUAGE CPP, ViewPatterns #-} module Darcs.Patch.Conflict - ( Conflict(..), CommuteNoConflicts(..) - , IsConflictedPrim(..), ConflictState(..) ) - where + ( Conflict(..), CommuteNoConflicts(..), listConflictedFiles + , IsConflictedPrim(..), ConflictState(..) + , mangleUnravelled + ) where +import Prelude () +import Darcs.Prelude + +import qualified Data.ByteString.Char8 as BC (pack, last) +import qualified Data.ByteString as B (null, ByteString) +import Data.Maybe ( isJust ) +import Data.List ( sort, intercalate ) +import Data.List.Ordered ( nubSort ) + import Darcs.Patch.Effect ( Effect(..) ) +import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk, isHunk ) import Darcs.Patch.Inspect ( PatchInspect(..) ) +import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Permutations () +import Darcs.Patch.Prim ( PrimPatch, is_filepatch, primIsHunk, primFromHunk ) import Darcs.Patch.Prim.Class ( PrimOf ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..) , mapFL, reverseFL, mapRL, reverseRL ) -import Darcs.Patch.Witnesses.Sealed ( Sealed, unseal ) +import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unseal, mapSeal ) import Darcs.Patch.Witnesses.Show ( Show2, showsPrec2 ) +import Darcs.Util.Path ( FileName, fn2fp, fp2fn ) import Darcs.Util.Show ( appPrec ) -import Data.List.Ordered ( nubSort ) +#include "impossible.h" +listConflictedFiles :: Conflict p => p wX wY -> [FilePath] +listConflictedFiles p = + nubSort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p + class (Effect p, PatchInspect (PrimOf p)) => Conflict p where - listConflictedFiles :: p wX wY -> [FilePath] - listConflictedFiles p = - nubSort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p resolveConflicts :: p wX wY -> [[Sealed (FL (PrimOf p) wY)]] conflictedEffect :: p wX wY -> [IsConflictedPrim (PrimOf p)] - conflictedEffect x = case listConflictedFiles x of - [] -> mapFL (IsC Okay) $ effect x - _ -> mapFL (IsC Conflicted) $ effect x class CommuteNoConflicts p where -- | If 'commuteNoConflicts' @x :> y@ succeeds, we know that that @x@ commutes @@ -36,7 +50,6 @@ commuteNoConflicts :: (p :> p) wX wY -> Maybe ((p :> p) wX wY) instance (CommuteNoConflicts p, Conflict p) => Conflict (FL p) where - listConflictedFiles = nubSort . concat . mapFL listConflictedFiles resolveConflicts NilFL = [] resolveConflicts x = resolveConflicts $ reverseFL x conflictedEffect = concat . mapFL conflictedEffect @@ -48,15 +61,14 @@ return $ ys' :> reverseRL rxs' instance (CommuteNoConflicts p, Conflict p) => Conflict (RL p) where - listConflictedFiles = nubSort . concat . mapRL listConflictedFiles resolveConflicts x = rcs x NilFL where rcs :: RL p wX wY -> FL p wY wW -> [[Sealed (FL (PrimOf p) wW)]] rcs NilRL _ = [] - rcs (p:<:ps) passedby | (_:_) <- resolveConflicts p = + rcs (ps:<:p) passedby | (_:_) <- resolveConflicts p = case commuteNoConflictsFL (p:>passedby) of Just (_:> p') -> resolveConflicts p' ++ rcs ps (p:>:passedby) Nothing -> rcs ps (p:>:passedby) - rcs (p:<:ps) passedby = seq passedby $ rcs ps (p:>:passedby) + rcs (ps:<:p) passedby = seq passedby $ rcs ps (p:>:passedby) conflictedEffect = concat . reverse . mapRL conflictedEffect instance CommuteNoConflicts p => CommuteNoConflicts (RL p) where @@ -83,9 +95,9 @@ commuteNoConflictsRL :: CommuteNoConflicts p => (RL p :> p) wX wY -> Maybe ((p :> RL p) wX wY) commuteNoConflictsRL (NilRL :> p) = Just (p :> NilRL) -commuteNoConflictsRL (p :<: ps :> q) = do q' :> p' <- commuteNoConflicts (p :> q) +commuteNoConflictsRL (ps :<: p :> q) = do q' :> p' <- commuteNoConflicts (p :> q) q'' :> ps' <- commuteNoConflictsRL (ps :> q') - return (q'' :> p' :<: ps') + return (q'' :> ps' :<: p') commuteNoConflictsRLFL :: CommuteNoConflicts p => (RL p :> FL p) wX wY -> Maybe ((FL p :> RL p) wX wY) commuteNoConflictsRLFL (NilRL :> ys) = Just (ys :> NilRL) @@ -93,4 +105,80 @@ commuteNoConflictsRLFL (xs :> y :>: ys) = do y' :> xs' <- commuteNoConflictsRL (xs :> y) ys' :> xs'' <- commuteNoConflictsRLFL (xs' :> ys) return (y' :>: ys' :> xs'') + + +applyHunks :: IsHunk prim => [Maybe B.ByteString] -> FL prim wX wY -> [Maybe B.ByteString] +applyHunks ms ((isHunk -> Just (FileHunk _ l o n)):>:ps) = applyHunks (rls l ms) ps + where rls k _ | k <=0 = bug $ "bad hunk: start position <=0 (" ++ show k ++ ")" + rls 1 mls = map Just n ++ drop (length o) mls + rls i (ml:mls) = ml : rls (i-1) mls + rls _ [] = bug "rls in applyHunks" +applyHunks ms NilFL = ms +applyHunks _ (_:>:_) = impossible + +getAFilename :: PrimPatch prim => [Sealed (FL prim wX)] -> FileName +getAFilename (Sealed ((is_filepatch -> Just f):>:_):_) = f +getAFilename _ = fp2fn "" + +getOld :: PrimPatch prim => [Maybe B.ByteString] -> [Sealed (FL prim wX)] -> [Maybe B.ByteString] +getOld = foldl getHunksOld + +getHunksOld :: PrimPatch prim => [Maybe B.ByteString] -> Sealed (FL prim wX) + -> [Maybe B.ByteString] +getHunksOld mls (Sealed ps) = + applyHunks (applyHunks mls ps) (invert ps) + +getHunksNew :: IsHunk prim => [Maybe B.ByteString] -> Sealed (FL prim wX) + -> [Maybe B.ByteString] +getHunksNew mls (Sealed ps) = applyHunks mls ps + +getHunkline :: [[Maybe B.ByteString]] -> Int +getHunkline = ghl 1 + where ghl :: Int -> [[Maybe B.ByteString]] -> Int + ghl n pps = + if any (isJust . head) pps + then n + else ghl (n+1) $ map tail pps + +makeChunk :: Int -> [Maybe B.ByteString] -> [B.ByteString] +makeChunk n mls = pull_chunk $ drop (n-1) mls + where pull_chunk (Just l:mls') = l : pull_chunk mls' + pull_chunk (Nothing:_) = [] + pull_chunk [] = bug "should this be [] in pull_chunk?" + + +mangleUnravelled :: PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (FL prim wX) +mangleUnravelled pss = if onlyHunks pss + then (:>: NilFL) `mapSeal` mangleUnravelledHunks pss + else head pss + +onlyHunks :: forall prim wX . PrimPatch prim => [Sealed (FL prim wX)] -> Bool +onlyHunks [] = False +onlyHunks pss = fn2fp f /= "" && all oh pss + where f = getAFilename pss + oh :: Sealed (FL prim wY) -> Bool + oh (Sealed (p:>:ps)) = primIsHunk p && + [fn2fp f] == listTouchedFiles p && + oh (Sealed ps) + oh (Sealed NilFL) = True + +mangleUnravelledHunks :: PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (prim wX) +--mangleUnravelledHunks [[h1],[h2]] = Deal with simple cases handily? +mangleUnravelledHunks pss = + if null nchs then bug "mangleUnravelledHunks" + else Sealed (primFromHunk (FileHunk filename l old new)) + where oldf = getOld (repeat Nothing) pss + newfs = map (getHunksNew oldf) pss + l = getHunkline $ oldf : newfs + nchs = sort $ map (makeChunk l) newfs + filename = getAFilename pss + old = makeChunk l oldf + new = [top] ++ old ++ [initial] ++ intercalate [middle] nchs ++ [bottom] + top = BC.pack $ "v v v v v v v" ++ eol_c + initial= BC.pack $ "=============" ++ eol_c + middle = BC.pack $ "*************" ++ eol_c + bottom = BC.pack $ "^ ^ ^ ^ ^ ^ ^" ++ eol_c + eol_c = if any (\ps -> not (B.null ps) && BC.last ps == '\r') old + then "\r" + else "" diff --git a/src/Darcs/Patch/ConflictMarking.hs b/src/Darcs/Patch/ConflictMarking.hs deleted file mode 100644 --- a/src/Darcs/Patch/ConflictMarking.hs +++ /dev/null @@ -1,97 +0,0 @@ --- Copyright (C) 2002-2003 David Roundy, 2010 Ganesh Sittampalam -{-# LANGUAGE CPP, ViewPatterns #-} -module Darcs.Patch.ConflictMarking - ( mangleUnravelled - ) where - -import qualified Data.ByteString.Char8 as BC (pack, last) -import qualified Data.ByteString as B (null, ByteString) -import Data.List ( sort, intercalate ) -import Data.Maybe ( isJust ) - -import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk, isHunk ) -import Darcs.Util.Path ( FileName, fn2fp, fp2fn ) -import Darcs.Patch.Inspect ( PatchInspect(..) ) -import Darcs.Patch.Invert ( Invert(..) ) -import Darcs.Patch.Permutations () -import Darcs.Patch.Prim ( PrimPatch, is_filepatch, primIsHunk, primFromHunk ) -import Darcs.Patch.Witnesses.Ordered ( FL(..) ) -import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal ) - -#include "impossible.h" - -applyHunks :: IsHunk prim => [Maybe B.ByteString] -> FL prim wX wY -> [Maybe B.ByteString] -applyHunks ms ((isHunk -> Just (FileHunk _ l o n)):>:ps) = applyHunks (rls l ms) ps - where rls k _ | k <=0 = bug $ "bad hunk: start position <=0 (" ++ show k ++ ")" - rls 1 mls = map Just n ++ drop (length o) mls - rls i (ml:mls) = ml : rls (i-1) mls - rls _ [] = bug "rls in applyHunks" -applyHunks ms NilFL = ms -applyHunks _ (_:>:_) = impossible - -getAFilename :: PrimPatch prim => [Sealed (FL prim wX)] -> FileName -getAFilename (Sealed ((is_filepatch -> Just f):>:_):_) = f -getAFilename _ = fp2fn "" - -getOld :: PrimPatch prim => [Maybe B.ByteString] -> [Sealed (FL prim wX)] -> [Maybe B.ByteString] -getOld = foldl getHunksOld - -getHunksOld :: PrimPatch prim => [Maybe B.ByteString] -> Sealed (FL prim wX) - -> [Maybe B.ByteString] -getHunksOld mls (Sealed ps) = - applyHunks (applyHunks mls ps) (invert ps) - -getHunksNew :: IsHunk prim => [Maybe B.ByteString] -> Sealed (FL prim wX) - -> [Maybe B.ByteString] -getHunksNew mls (Sealed ps) = applyHunks mls ps - -getHunkline :: [[Maybe B.ByteString]] -> Int -getHunkline = ghl 1 - where ghl :: Int -> [[Maybe B.ByteString]] -> Int - ghl n pps = - if any (isJust . head) pps - then n - else ghl (n+1) $ map tail pps - -makeChunk :: Int -> [Maybe B.ByteString] -> [B.ByteString] -makeChunk n mls = pull_chunk $ drop (n-1) mls - where pull_chunk (Just l:mls') = l : pull_chunk mls' - pull_chunk (Nothing:_) = [] - pull_chunk [] = bug "should this be [] in pull_chunk?" - - -mangleUnravelled :: PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (FL prim wX) -mangleUnravelled pss = if onlyHunks pss - then (:>: NilFL) `mapSeal` mangleUnravelledHunks pss - else head pss - -onlyHunks :: forall prim wX . PrimPatch prim => [Sealed (FL prim wX)] -> Bool -onlyHunks [] = False -onlyHunks pss = fn2fp f /= "" && all oh pss - where f = getAFilename pss - oh :: Sealed (FL prim wY) -> Bool - oh (Sealed (p:>:ps)) = primIsHunk p && - [fn2fp f] == listTouchedFiles p && - oh (Sealed ps) - oh (Sealed NilFL) = True - -mangleUnravelledHunks :: PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (prim wX) ---mangleUnravelledHunks [[h1],[h2]] = Deal with simple cases handily? -mangleUnravelledHunks pss = - if null nchs then bug "mangleUnravelledHunks" - else Sealed (primFromHunk (FileHunk filename l old new)) - where oldf = getOld (repeat Nothing) pss - newfs = map (getHunksNew oldf) pss - l = getHunkline $ oldf : newfs - nchs = sort $ map (makeChunk l) newfs - filename = getAFilename pss - old = makeChunk l oldf - new = [top] ++ old ++ [initial] ++ intercalate [middle] nchs ++ [bottom] - top = BC.pack $ "v v v v v v v" ++ eol_c - initial= BC.pack $ "=============" ++ eol_c - middle = BC.pack $ "*************" ++ eol_c - bottom = BC.pack $ "^ ^ ^ ^ ^ ^ ^" ++ eol_c - eol_c = if any (\ps -> not (B.null ps) && BC.last ps == '\r') old - then "\r" - else "" - diff --git a/src/Darcs/Patch/Depends.hs b/src/Darcs/Patch/Depends.hs --- a/src/Darcs/Patch/Depends.hs +++ b/src/Darcs/Patch/Depends.hs @@ -30,25 +30,36 @@ , splitOnTag , newsetUnion , newsetIntersection - , commuteToEnd , findUncommon , merge2FL + , getDeps + , SPatchAndDeps ) where +import Prelude () +import Darcs.Prelude + #include "impossible.h" import Prelude hiding ( pi ) import Data.List ( delete, intersect, (\\) ) import Data.Maybe ( fromMaybe ) +import qualified Data.ByteString.Char8 as BC ( unpack ) +import Control.Arrow ( (&&&) ) -import Darcs.Patch ( Patchy, getdeps, commute, commuteFLorComplain, - commuteRL ) -import Darcs.Patch.Info ( PatchInfo, isTag, showPatchInfoUI ) +import Darcs.Patch ( RepoPatch ) +import Darcs.Patch.Apply( ApplyState ) +import Darcs.Patch.Patchy ( Patchy ) +import Darcs.Patch.Named ( Named (..), patch2patchinfo ) +import Darcs.Patch.Named.Wrapped ( getdeps ) +import Darcs.Patch.Choices ( Label, patchChoices, forceFirst + , PatchChoices, lpPatch, getChoices + , LabelledPatch, label ) +import Darcs.Patch.Commute ( commute, commuteFL, commuteRL ) +import Darcs.Patch.Info ( PatchInfo, isTag, showPatchInfoUI, _piName ) import Darcs.Patch.Merge ( Merge, mergeFL ) -import Darcs.Patch.Permutations ( partitionFL, partitionRL, - removeSubsequenceRL ) +import Darcs.Patch.Permutations ( partitionFL, partitionRL ) import Darcs.Patch.PatchInfoAnd( PatchInfoAnd, hopefully, hopefullyM, info ) -import Darcs.Patch.Rebase.NameHack ( NameHack ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL, appendPSFL ) import Darcs.Patch.Progress ( progressRL ) @@ -57,11 +68,12 @@ import Darcs.Patch.Witnesses.Ordered ( (:\/:)(..), (:/\:)(..), (:>)(..), Fork(..), (+>+), mapFL, RL(..), FL(..), isShorterThanRL, - (+<+), reverseFL, reverseRL, mapRL ) + (+<+), reverseFL, reverseRL, mapRL, lengthFL, splitAtFL ) import Darcs.Patch.Witnesses.Sealed - ( Sealed(..), FlippedSeal(..), flipSeal, seal ) + ( Sealed(..), FlippedSeal(..), flipSeal, seal, Sealed2(..), seal2 ) import Darcs.Util.Printer ( renderString, vcat, RenderMode(..) ) +import Darcs.Util.Tree ( Tree ) {- - This module uses the following definitions: @@ -82,6 +94,54 @@ - since they explicitly depend on all uncovered patches. -} +-- | S(ealed) Patch and his dependencies. +type SPatchAndDeps p = ( Sealed2 (LabelledPatch (Named p)) + , Sealed2 (FL (LabelledPatch (Named p))) + ) + +-- | Searchs dependencies in @repoFL@ of the patches in @getDepsFL@. +getDeps :: (RepoPatch p, ApplyState p ~ Tree) => + FL (Named p) wA wR -> FL (PatchInfoAnd rt p) wX wY -> [SPatchAndDeps p] +getDeps repoFL getDepsFL = + let repoChoices = patchChoices repoFL + getDepsFL' = mapFL (BC.unpack . _piName . info) getDepsFL + labelledDeps = getLabelledDeps getDepsFL' repoChoices + in + map (deps repoChoices) labelledDeps + where + -- Search dependencies for the patch with label @l@ in @repoChoices@. + deps :: (Patchy (Named p)) => PatchChoices (Named p) wX wY -> + (String,Label) -> SPatchAndDeps p + deps repoChoices (_,l) = + case getChoices $ forceFirst l repoChoices of + (ds :> _) -> let i = lengthFL ds + in case splitAtFL (i-1) ds of + -- Separate last patch in list + ds' :> (r :>: NilFL) -> (seal2 r, seal2 ds') + _ -> impossible -- Because deps at least + -- has r, which is the patch + -- that we are looking at + -- dependencies. + getLabelledDeps :: Patchy (Named p) => [String] -> + PatchChoices (Named p) x y -> [(String, Label)] + getLabelledDeps patchnames repoChoices = + case getChoices repoChoices of + a :> (b :> c) -> filterDepsFL patchnames a ++ + filterDepsFL patchnames b ++ + filterDepsFL patchnames c + filterDepsFL :: [String] -> FL (LabelledPatch (Named p)) wX wY -> + [(String, Label)] + filterDepsFL _ NilFL = [] + filterDepsFL patchnames (lp :>: lps) = + if fst dep `elem` patchnames + then dep : filterDepsFL patchnames lps + else filterDepsFL patchnames lps + where + lpTostring :: LabelledPatch (Named p) wA wB -> String + lpTostring = BC.unpack . _piName . patch2patchinfo . lpPatch + dep :: (String, Label) + dep = lpTostring &&& label $ lp + {-| taggedIntersection takes two 'PatchSet's and splits them into a /common/ intersection portion and two sets of patches. The intersection, however, @@ -95,21 +155,21 @@ taggedIntersection does its best to reduce the number of inventories that are accessed from its rightmost argument. -} -taggedIntersection :: forall p wStart wX wY . (Patchy p, NameHack p) => - PatchSet p wStart wX -> PatchSet p wStart wY -> - Fork (RL (Tagged p)) - (RL (PatchInfoAnd p)) - (RL (PatchInfoAnd p)) wStart wX wY -taggedIntersection (PatchSet ps1 NilRL) s2 = Fork NilRL ps1 (newset2RL s2) -taggedIntersection s1 (PatchSet ps2 NilRL) = Fork NilRL (newset2RL s1) ps2 -taggedIntersection s1 (PatchSet ps2 (Tagged t _ _ :<: _)) - | Just (PatchSet ps1 ts1) <- maybeSplitSetOnTag (info t) s1 = +taggedIntersection :: forall rt p wStart wX wY . Patchy p => + PatchSet rt p wStart wX -> PatchSet rt p wStart wY -> + Fork (RL (Tagged rt p)) + (RL (PatchInfoAnd rt p)) + (RL (PatchInfoAnd rt p)) wStart wX wY +taggedIntersection (PatchSet NilRL ps1) s2 = Fork NilRL ps1 (newset2RL s2) +taggedIntersection s1 (PatchSet NilRL ps2) = Fork NilRL (newset2RL s1) ps2 +taggedIntersection s1 (PatchSet (_ :<: Tagged t _ _) ps2) + | Just (PatchSet ts1 ps1) <- maybeSplitSetOnTag (info t) s1 = Fork ts1 ps1 (unsafeCoercePStart ps2) -taggedIntersection s1 s2@(PatchSet ps2 (Tagged t _ p :<: ts2)) = +taggedIntersection s1 s2@(PatchSet (ts2 :<: Tagged t _ p) ps2) = case hopefullyM t of - Just _ -> taggedIntersection s1 (PatchSet (ps2 +<+ t :<: p) ts2) + Just _ -> taggedIntersection s1 (PatchSet ts2 (p :<: t +<+ ps2)) Nothing -> case splitOnTag (info t) s1 of - Just (PatchSet NilRL com :> us) -> + Just (PatchSet com NilRL :> us) -> Fork com us (unsafeCoercePStart ps2) Just _ -> impossible Nothing -> Fork NilRL (newset2RL s1) (newset2RL s2) @@ -119,20 +179,20 @@ -- found, the PatchSet is split up, on that tag, such that all later patches -- are in the "since last tag" patch list. If the tag is not found, 'Nothing' -- is returned. -maybeSplitSetOnTag :: PatchInfo -> PatchSet p wStart wX - -> Maybe (PatchSet p wStart wX) -maybeSplitSetOnTag t0 origSet@(PatchSet ps (Tagged t _ pst :<: ts)) +maybeSplitSetOnTag :: PatchInfo -> PatchSet rt p wStart wX + -> Maybe (PatchSet rt p wStart wX) +maybeSplitSetOnTag t0 origSet@(PatchSet (ts :<: Tagged t _ pst) ps) | t0 == info t = Just origSet | otherwise = do - PatchSet ps' ts' <- maybeSplitSetOnTag t0 (PatchSet (t :<: pst) ts) - Just $ PatchSet (ps +<+ ps') ts' + PatchSet ts' ps' <- maybeSplitSetOnTag t0 (PatchSet ts (pst :<: t)) + Just $ PatchSet ts' (ps' +<+ ps) maybeSplitSetOnTag _ _ = Nothing -getPatchesBeyondTag :: (Patchy p, NameHack p) => PatchInfo -> PatchSet p wStart wX - -> FlippedSeal (RL (PatchInfoAnd p)) wX -getPatchesBeyondTag t (PatchSet ps (Tagged hp _ _ :<: _)) | info hp == t = +getPatchesBeyondTag :: Patchy p => PatchInfo -> PatchSet rt p wStart wX + -> FlippedSeal (RL (PatchInfoAnd rt p)) wX +getPatchesBeyondTag t (PatchSet (_ :<: Tagged hp _ _) ps) | info hp == t = flipSeal ps -getPatchesBeyondTag t patchset@(PatchSet (hp :<: ps) ts) = +getPatchesBeyondTag t patchset@(PatchSet ts (ps :<: hp)) = if info hp == t then if getUncovered patchset == [info hp] -- special case to avoid looking at redundant patches @@ -140,63 +200,63 @@ else case splitOnTag t patchset of Just (_ :> e) -> flipSeal e _ -> impossible - else case getPatchesBeyondTag t (PatchSet ps ts) of - FlippedSeal xxs -> FlippedSeal (hp :<: xxs) + else case getPatchesBeyondTag t (PatchSet ts ps) of + FlippedSeal xxs -> FlippedSeal (xxs :<: hp) getPatchesBeyondTag t (PatchSet NilRL NilRL) = bug $ "tag\n" ++ renderString Encode (showPatchInfoUI t) ++ "\nis not in the patchset in getPatchesBeyondTag." -getPatchesBeyondTag t0 (PatchSet NilRL (Tagged t _ ps :<: ts)) = - getPatchesBeyondTag t0 (PatchSet (t :<: ps) ts) +getPatchesBeyondTag t0 (PatchSet (ts :<: Tagged t _ ps) NilRL) = + getPatchesBeyondTag t0 (PatchSet ts (ps :<: t)) -- |splitOnTag takes a tag's 'PatchInfo', and a 'PatchSet', and attempts to -- find the tag in the PatchSet, returning a pair: the clean PatchSet "up to" -- the tag, and a RL of patches after the tag; If the tag is not in the -- PatchSet, we return Nothing. -splitOnTag :: (Patchy p, NameHack p) => PatchInfo -> PatchSet p wStart wX - -> Maybe ((PatchSet p :> RL (PatchInfoAnd p)) wStart wX) +splitOnTag :: Patchy p => PatchInfo -> PatchSet rt p wStart wX + -> Maybe ((PatchSet rt p :> RL (PatchInfoAnd rt p)) wStart wX) -- If the tag we are looking for is the first Tagged tag of the patchset, just -- separate out the patchset's patches. -splitOnTag t (PatchSet ps ts@(Tagged hp _ _ :<: _)) | info hp == t = - Just $ PatchSet NilRL ts :> ps +splitOnTag t (PatchSet ts@(_ :<: Tagged hp _ _) ps) | info hp == t = + Just $ PatchSet ts NilRL :> ps -- If the tag is the most recent patch in the set, we check if the patch is the -- only non-depended-on patch in the set (i.e. it is a clean tag); creating a -- new Tagged out of the patches and tag, and adding it to the patchset, if -- this is the case. Otherwise, we try to make the tag clean. -splitOnTag t patchset@(PatchSet hps@(hp :<: ps) ts) | info hp == t = +splitOnTag t patchset@(PatchSet ts hps@(ps :<: hp)) | info hp == t = if getUncovered patchset == [t] - then Just $ PatchSet NilRL (Tagged hp Nothing ps :<: ts) :> NilRL + then Just $ PatchSet (ts :<: Tagged hp Nothing ps) NilRL :> NilRL else case partitionRL ((`notElem` (t : ds)) . info) hps of -- Partition hps by those that are the tag and its explicit deps. - tagAndDeps@(hp' :<: ds') :> nonDeps -> + tagAndDeps@(ds' :<: hp') :> nonDeps -> -- If @ds@ doesn't contain the tag of the first Tagged, that -- tag will also be returned by the call to getUncovered - so -- we need to unwrap the next Tagged in order to expose it to -- being partitioned out in the recursive call to splitOnTag. - if getUncovered (PatchSet tagAndDeps ts) == [t] + if getUncovered (PatchSet ts tagAndDeps) == [t] then let tagged = Tagged hp' Nothing ds' in - return $ PatchSet NilRL (tagged :<: ts) :> nonDeps + return $ PatchSet (ts :<: tagged) NilRL :> nonDeps else do - unfolded <- unwrapOneTagged $ PatchSet tagAndDeps ts + unfolded <- unwrapOneTagged $ PatchSet ts tagAndDeps xx :> yy <- splitOnTag t unfolded - return $ xx :> (nonDeps +<+ yy) + return $ xx :> (yy +<+ nonDeps) _ -> impossible where ds = getdeps (hopefully hp) -- We drop the leading patch, to try and find a non-Tagged tag. -splitOnTag t (PatchSet (p :<: ps) ts) = do - ns :> x <- splitOnTag t (PatchSet ps ts) - return $ ns :> (p :<: x) +splitOnTag t (PatchSet ts (ps :<: p)) = do + ns :> x <- splitOnTag t (PatchSet ts ps) + return $ ns :> (x :<: p) -- If there are no patches left, we "unfold" the next Tagged, and try again. -splitOnTag t0 patchset@(PatchSet NilRL (Tagged _ _ _s :<: _)) = +splitOnTag t0 patchset@(PatchSet (_ :<: Tagged _ _ _s) NilRL) = unwrapOneTagged patchset >>= splitOnTag t0 -- If we've checked all the patches, but haven't found the tag, return Nothing. splitOnTag _ (PatchSet NilRL NilRL) = Nothing -- |'unwrapOneTagged' unfolds a single Tagged object in a PatchSet, adding the -- tag and patches to the PatchSet's patch list. -unwrapOneTagged :: (Monad m) => PatchSet p wX wY -> m (PatchSet p wX wY) -unwrapOneTagged (PatchSet ps (Tagged t _ tps :<: ts)) = - return $ PatchSet (ps +<+ t :<: tps) ts +unwrapOneTagged :: (Monad m) => PatchSet rt p wX wY -> m (PatchSet rt p wX wY) +unwrapOneTagged (PatchSet (ts :<: Tagged t _ tps) ps) = + return $ PatchSet ts (tps :<: t +<+ ps) unwrapOneTagged _ = fail "called unwrapOneTagged with no Tagged's in the set" -- | @getUncovered ps@ returns the 'PatchInfo' for all the patches in @@ -207,11 +267,11 @@ -- Keep in mind that in a typical repository with a lot of tags, only a small -- fraction of tags would be returned as they would be at least indirectly -- depended on by the topmost ones. -getUncovered :: PatchSet p wStart wX -> [PatchInfo] +getUncovered :: PatchSet rt p wStart wX -> [PatchInfo] getUncovered patchset = case patchset of - (PatchSet ps NilRL) -> findUncovered (mapRL infoAndExplicitDeps ps) - (PatchSet ps (Tagged t _ _ :<: _)) -> - findUncovered (mapRL infoAndExplicitDeps (ps +<+ t :<: NilRL)) + (PatchSet NilRL ps) -> findUncovered (mapRL infoAndExplicitDeps ps) + (PatchSet (_ :<: Tagged t _ _) ps) -> + findUncovered (mapRL infoAndExplicitDeps (NilRL :<: t +<+ ps)) where findUncovered :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo] findUncovered [] = [] @@ -234,7 +294,7 @@ -- |infoAndExplicitDeps returns the patch info and (for tags only) the list -- of explicit dependencies of a patch. - infoAndExplicitDeps :: PatchInfoAnd p wX wY + infoAndExplicitDeps :: PatchInfoAnd rt p wX wY -> (PatchInfo, Maybe [PatchInfo]) infoAndExplicitDeps p | isTag (info p) = (info p, getdeps `fmap` hopefullyM p) @@ -244,59 +304,46 @@ -- (see 'optimizePatchset') and only optimises at most one tag in -- there, going for the most recent tag which has no non-depended -- patch after it. Older tags won't be 'clean', which means the --- PatchSet will not be in 'unclean :< clean' state. -slightlyOptimizePatchset :: PatchSet p wStart wX -> PatchSet p wStart wX +-- PatchSet will not be in 'clean :> unclean' state. +slightlyOptimizePatchset :: PatchSet rt p wStart wX -> PatchSet rt p wStart wX slightlyOptimizePatchset (PatchSet ps0 ts0) = sops $ PatchSet (prog ps0) ts0 where prog = progressRL "Optimizing inventory" - sops :: PatchSet p wStart wY -> PatchSet p wStart wY - sops patchset@(PatchSet NilRL _) = patchset - sops patchset@(PatchSet (hp :<: ps) ts) + sops :: PatchSet rt p wStart wY -> PatchSet rt p wStart wY + sops patchset@(PatchSet _ NilRL) = patchset + sops patchset@(PatchSet ts (ps :<: hp)) | isTag (info hp) = if getUncovered patchset == [info hp] -- exactly one tag and it depends on everything not already -- archived - then PatchSet NilRL (Tagged hp Nothing ps :<: ts) + then PatchSet (ts :<: Tagged hp Nothing ps) NilRL -- other tags or other top-level patches too (so move past hp) - else let ps' = sops $ PatchSet (prog ps) ts in + else let ps' = sops $ PatchSet ts (prog ps) in appendPSFL ps' (hp :>: NilFL) - | otherwise = appendPSFL (sops $ PatchSet ps ts) (hp :>: NilFL) + | otherwise = appendPSFL (sops $ PatchSet ts ps) (hp :>: NilFL) -commuteToEnd :: forall p wStart wX wY - . (Patchy p, NameHack p) - => RL (PatchInfoAnd p) wX wY - -> PatchSet p wStart wY - -> (PatchSet p :> RL (PatchInfoAnd p)) wStart wX -commuteToEnd NilRL (PatchSet ps ts) = PatchSet NilRL ts :> ps -commuteToEnd (p :<: ps) (PatchSet xs ts) | info p `elem` mapRL info xs = - case fastRemoveRL p xs of - Just xs' -> commuteToEnd ps (PatchSet xs' ts) - Nothing -> impossible -- "Nothing is impossible" -commuteToEnd ps (PatchSet xs (Tagged t _ ys :<: ts)) = - commuteToEnd ps (PatchSet (xs +<+ t :<: ys) ts) -commuteToEnd _ _ = impossible +removeFromPatchSet :: Patchy p => FL (PatchInfoAnd rt p) wX wY + -> PatchSet rt p wStart wY -> Maybe (PatchSet rt p wStart wX) +removeFromPatchSet bad (PatchSet ts ps) | all (`elem` mapRL info ps) (mapFL info bad) = do + ps' <- fastRemoveSubsequenceRL (reverseFL bad) ps + return (PatchSet ts ps') +removeFromPatchSet _ (PatchSet NilRL _) = Nothing +removeFromPatchSet bad (PatchSet (ts :<: Tagged t _ tps) ps) = + removeFromPatchSet bad (PatchSet ts (tps :<: t +<+ ps)) -removeFromPatchSet :: (Patchy p, NameHack p) => FL (PatchInfoAnd p) wX wY - -> PatchSet p wStart wY -> Maybe (PatchSet p wStart wX) -removeFromPatchSet bad0 = rfns (reverseFL bad0) - where - rfns :: (Patchy p, NameHack p) - => RL (PatchInfoAnd p) wX wY -> PatchSet p wStart wY - -> Maybe (PatchSet p wStart wX) - rfns bad (PatchSet ps ts) - | all (`elem` mapRL info ps) (mapRL info bad) = do - ps' <- removeSubsequenceRL bad ps - Just $ PatchSet ps' ts - rfns _ (PatchSet _ NilRL) = Nothing - rfns bad (PatchSet ps (Tagged t _ tps :<: ts)) = - rfns bad (PatchSet (ps +<+ t :<: tps) ts) +fastRemoveSubsequenceRL :: Patchy p + => RL (PatchInfoAnd rt p) wY wZ + -> RL (PatchInfoAnd rt p) wX wZ + -> Maybe (RL (PatchInfoAnd rt p) wX wY) +fastRemoveSubsequenceRL NilRL ys = Just ys +fastRemoveSubsequenceRL (xs:<:x) ys = fastRemoveRL x ys >>= fastRemoveSubsequenceRL xs -findCommonAndUncommon :: forall p wStart wX wY . (Patchy p, NameHack p) - => PatchSet p wStart wX -> PatchSet p wStart wY - -> Fork (PatchSet p) - (FL (PatchInfoAnd p)) - (FL (PatchInfoAnd p)) wStart wX wY +findCommonAndUncommon :: forall rt p wStart wX wY . Patchy p + => PatchSet rt p wStart wX -> PatchSet rt p wStart wY + -> Fork (PatchSet rt p) + (FL (PatchInfoAnd rt p)) + (FL (PatchInfoAnd rt p)) wStart wX wY findCommonAndUncommon us them = case taggedIntersection us them of Fork common us' them' -> case partitionFL (infoIn them') $ reverseRL us' of @@ -311,15 +358,15 @@ ++ renderString Encode (vcat $ mapRL (showPatchInfoUI . info) $ reverseFL bad) _ :> NilFL :> only_theirs -> - Fork (PatchSet (reverseFL common2) common) + Fork (PatchSet common (reverseFL common2)) only_ours (unsafeCoercePStart only_theirs) where infoIn inWhat = (`elem` mapRL info inWhat) . info -findCommonWithThem :: (Patchy p, NameHack p) - => PatchSet p wStart wX - -> PatchSet p wStart wY - -> (PatchSet p :> FL (PatchInfoAnd p)) wStart wX +findCommonWithThem :: Patchy p + => PatchSet rt p wStart wX + -> PatchSet rt p wStart wY + -> (PatchSet rt p :> FL (PatchInfoAnd rt p)) wStart wX findCommonWithThem us them = case taggedIntersection us them of Fork common us' them' -> case partitionFL ((`elem` mapRL info them') . info) $ reverseRL us' of @@ -328,19 +375,19 @@ ++ renderString Encode (vcat $ mapRL (showPatchInfoUI . info) $ reverseFL bad) common2 :> _nilfl :> only_ours -> - PatchSet (reverseFL common2) common :> unsafeCoerceP only_ours + PatchSet common (reverseFL common2) :> unsafeCoerceP only_ours -findUncommon :: (Patchy p, NameHack p) - => PatchSet p wStart wX -> PatchSet p wStart wY - -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wX wY +findUncommon :: Patchy p + => PatchSet rt p wStart wX -> PatchSet rt p wStart wY + -> (FL (PatchInfoAnd rt p) :\/: FL (PatchInfoAnd rt p)) wX wY findUncommon us them = case findCommonWithThem us them of _common :> us' -> case findCommonWithThem them us of _ :> them' -> unsafeCoercePStart us' :\/: them' -countUsThem :: (Patchy p, NameHack p) - => PatchSet p wStart wX - -> PatchSet p wStart wY +countUsThem :: Patchy p + => PatchSet rt p wStart wX + -> PatchSet rt p wStart wY -> (Int, Int) countUsThem us them = case taggedIntersection us them of @@ -348,18 +395,18 @@ tt = mapRL info them' in (length $ uu \\ tt, length $ tt \\ uu) -mergeThem :: (Patchy p, Merge p, NameHack p) - => PatchSet p wStart wX -> PatchSet p wStart wY - -> Sealed (FL (PatchInfoAnd p) wX) +mergeThem :: (Patchy p, Merge p) + => PatchSet rt p wStart wX -> PatchSet rt p wStart wY + -> Sealed (FL (PatchInfoAnd rt p) wX) mergeThem us them = case taggedIntersection us them of Fork _ us' them' -> case merge2FL (reverseRL us') (reverseRL them') of them'' :/\: _ -> Sealed them'' -newsetIntersection :: (Patchy p, NameHack p) - => [SealedPatchSet p wStart] - -> SealedPatchSet p wStart +newsetIntersection :: Patchy p + => [SealedPatchSet rt p wStart] + -> SealedPatchSet rt p wStart newsetIntersection [] = seal $ PatchSet NilRL NilRL newsetIntersection [x] = x newsetIntersection (Sealed y : ys) = @@ -368,38 +415,35 @@ Fork common a b -> case mapRL info a `intersect` mapRL info b of morecommon -> case partitionRL (\e -> info e `notElem` morecommon) a of - commonps :> _ -> seal $ PatchSet commonps common + commonps :> _ -> seal $ PatchSet common commonps -newsetUnion :: (Patchy p, Merge p, NameHack p) - => [SealedPatchSet p wStart] - -> SealedPatchSet p wStart +newsetUnion :: (Patchy p, Merge p) + => [SealedPatchSet rt p wStart] + -> SealedPatchSet rt p wStart newsetUnion [] = seal $ PatchSet NilRL NilRL newsetUnion [x] = x -newsetUnion (Sealed y@(PatchSet psy tsy) : Sealed y2 : ys) = +newsetUnion (Sealed y@(PatchSet tsy psy) : Sealed y2 : ys) = case mergeThem y y2 of Sealed p2 -> - newsetUnion $ seal (PatchSet (reverseFL p2 +<+ psy) tsy) : ys + newsetUnion $ seal (PatchSet tsy (psy +<+ reverseFL p2)) : ys -- | Merge two FLs (say L and R), starting in a common context. The result is a -- FL starting in the original end context of L, going to a new context that is -- the result of applying all patches from R on top of patches from L. -- --- While this function is similar to 'mergeFL', there are three important +-- While this function is similar to 'mergeFL', there are some important -- differences to keep in mind: -- -- * 'mergeFL' does not correctly deal with duplicate patches whereas this one -- does --- (Question from Eric Kow: in what sense? Why not fix the mergeFL instance?) --- --- * The conventional order we use in this function is reversed from --- 'mergeFL' (so @mergeFL r l@ vs. @merge2FL l r@. This does not --- matter so much for the former since you get both paths. --- (Question from Eric Kow: should we flip merge2FL for more uniformity in --- the code?) -merge2FL :: (Patchy p, Merge p, NameHack p) - => FL (PatchInfoAnd p) wX wY - -> FL (PatchInfoAnd p) wX wZ - -> (FL (PatchInfoAnd p) :/\: FL (PatchInfoAnd p)) wY wZ +-- (Question from Eric Kow: in what sense? Why not fix 'mergeFL'?) +-- (bf: I guess what was meant here is that 'merge2FL' works in the +-- the way it does because it considers patch meta data whereas +-- 'mergeFL' cannot since it must work for primitive patches, too. +merge2FL :: (Patchy p, Merge p) + => FL (PatchInfoAnd rt p) wX wY + -> FL (PatchInfoAnd rt p) wX wZ + -> (FL (PatchInfoAnd rt p) :/\: FL (PatchInfoAnd rt p)) wY wZ merge2FL xs NilFL = NilFL :/\: xs merge2FL NilFL ys = ys :/\: NilFL merge2FL xs (y :>: ys) | Just xs' <- fastRemoveFL y xs = merge2FL xs' ys @@ -410,14 +454,14 @@ ys'' :/\: xs' -> ys'' :/\: (x' :>: xs') -areUnrelatedRepos :: (Patchy p, NameHack p) - => PatchSet p wStart wX - -> PatchSet p wStart wY -> Bool +areUnrelatedRepos :: Patchy p + => PatchSet rt p wStart wX + -> PatchSet rt p wStart wY -> Bool areUnrelatedRepos us them = case taggedIntersection us them of Fork c u t -> checkit c u t where - checkit (Tagged{} :<: _) _ _ = False + checkit (_ :<: Tagged{}) _ _ = False checkit _ u t | t `isShorterThanRL` 5 = False | u `isShorterThanRL` 5 = False | otherwise = null $ intersect (mapRL info u) (mapRL info t) @@ -427,9 +471,21 @@ -- in the sequence at all or any commutation fails, we get Nothing. First two -- cases are optimisations for the common cases where the head of the list is -- the patch to remove, or the patch is not there at all. -fastRemoveFL :: (Patchy p, NameHack p) - => PatchInfoAnd p wX wY - -> FL (PatchInfoAnd p) wX wZ -> Maybe (FL (PatchInfoAnd p) wY wZ) +-- +-- A note on the witness types: the patch to be removed is typed as if it had +-- to be the first in the list, since it has the same pre-context as the list. +-- The types fit together (internally, in this module) because we commute the +-- patch to the front before removing it and commutation inside a sequence does +-- not change the sequence's contexts. +-- +-- However, the use sites outside this module are something different. We +-- usually need coercions to get the patch(es) to be removed in shape. This is +-- not very nice but probably unavoidable given the approximative nature of +-- context witnesses. +fastRemoveFL :: Patchy p + => PatchInfoAnd rt p wX wY -- this type assumes element is at the front + -> FL (PatchInfoAnd rt p) wX wZ + -> Maybe (FL (PatchInfoAnd rt p) wY wZ) fastRemoveFL _ NilFL = Nothing fastRemoveFL a (b :>: bs) | IsEq <- a =\/= b = Just bs | info a `notElem` mapFL info bs = Nothing @@ -440,38 +496,37 @@ Just (b' :>: bs') where i = info a - pullout :: (Patchy p, NameHack p) - => RL (PatchInfoAnd p) wA0 wA - -> FL (PatchInfoAnd p) wA wB - -> Maybe ((PatchInfoAnd p :> FL (PatchInfoAnd p)) wA0 wB) + pullout :: Patchy p + => RL (PatchInfoAnd rt p) wA wB + -> FL (PatchInfoAnd rt p) wB wC + -> Maybe ((PatchInfoAnd rt p :> FL (PatchInfoAnd rt p)) wA wC) pullout _ NilFL = Nothing pullout acc (x :>: xs) | info x == i = do x' :> acc' <- commuteRL (acc :> x) Just (x' :> reverseRL acc' +>+ xs) - | otherwise = pullout (x :<: acc) xs + | otherwise = pullout (acc :<: x) xs -fastRemoveRL :: (Patchy p, NameHack p) - => PatchInfoAnd p wY wZ - -> RL (PatchInfoAnd p) wX wZ -> Maybe (RL (PatchInfoAnd p) wX wY) +-- | Same as 'fastRemoveFL' only for 'RL'. +fastRemoveRL :: Patchy p + => PatchInfoAnd rt p wY wZ -- this type assumes element is at the back + -> RL (PatchInfoAnd rt p) wX wZ + -> Maybe (RL (PatchInfoAnd rt p) wX wY) fastRemoveRL _ NilRL = Nothing -fastRemoveRL a (b :<: bs) | IsEq <- a =/\= b = Just bs +fastRemoveRL a (bs :<: b) | IsEq <- b =/\= a = Just bs | info a `notElem` mapRL info bs = Nothing -fastRemoveRL a (b :<: bs) = do - bs' :> a' <- pullout NilFL bs +fastRemoveRL a (bs :<: b) = do + bs' :> a' <- pullout bs NilFL b' :> a'' <- commute (a' :> b) IsEq <- return (a'' =/\= a) - Just (b' :<: bs') + Just (bs' :<: b') where i = info a - pullout :: (Patchy p, NameHack p) - => FL (PatchInfoAnd p) wB wC - -> RL (PatchInfoAnd p) wA wB - -> Maybe ((RL (PatchInfoAnd p) :> PatchInfoAnd p) wA wC) - pullout _ NilRL = Nothing - pullout acc (x :<: xs) - | info x == i = do - acc' :> x' <- either (const Nothing) - Just - (commuteFLorComplain (x :> acc)) - Just (reverseFL acc' +<+ xs :> x') - | otherwise = pullout (x :>: acc) xs + pullout :: Patchy p + => RL (PatchInfoAnd rt p) wA wB + -> FL (PatchInfoAnd rt p) wB wC + -> Maybe ((RL (PatchInfoAnd rt p) :> PatchInfoAnd rt p) wA wC) + pullout NilRL _ = Nothing + pullout (xs :<: x) acc + | info x == i = do acc' :> x' <- commuteFL (x :> acc) + Just (xs +<+ reverseFL acc' :> x') + | otherwise = pullout xs (x :>: acc) diff --git a/src/Darcs/Patch/Dummy.hs b/src/Darcs/Patch/Dummy.hs --- a/src/Darcs/Patch/Dummy.hs +++ b/src/Darcs/Patch/Dummy.hs @@ -8,7 +8,6 @@ import Darcs.Patch.FileHunk ( IsHunk ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Matchable ( Matchable ) -import Darcs.Patch.MaybeInternal ( MaybeInternal ) import Darcs.Patch.Patchy ( Patchy, ShowPatch, Invert, Commute, Apply(..), PatchInspect , ReadPatch ) @@ -17,13 +16,12 @@ ( PrimConstruct, PrimCanonize, PrimClassify , PrimDetails, PrimShow, PrimRead, PrimApply ) import Darcs.Patch.Merge ( Merge) -import Darcs.Patch.Rebase.NameHack ( NameHack ) -import Darcs.Patch.Rebase.Recontext ( RecontextRebase ) import Darcs.Patch.Repair ( Check, RepairToFL ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.Show ( ShowPatchBasic ) import Darcs.Patch.Witnesses.Eq ( MyEq ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Patch.Witnesses.Show ( Show2 ) +import Darcs.Util.Tree( Tree ) data DummyPrim wX wY @@ -50,6 +48,7 @@ instance PrimRead DummyPrim instance PrimApply DummyPrim instance PrimPatch DummyPrim +instance Show2 DummyPrim instance PatchDebug DummyPrim @@ -61,6 +60,7 @@ instance ReadPatch DummyPatch instance ShowPatchBasic DummyPatch instance ShowPatch DummyPatch +instance Show2 DummyPatch instance Commute DummyPatch instance Apply DummyPatch where type ApplyState DummyPatch = Tree @@ -76,9 +76,6 @@ instance RepairToFL DummyPatch instance PrimPatchBase DummyPatch where type PrimOf DummyPatch = DummyPrim -instance MaybeInternal DummyPatch -instance NameHack DummyPatch -instance RecontextRebase DummyPatch instance RepoPatch DummyPatch instance PatchDebug DummyPatch diff --git a/src/Darcs/Patch/Effect.hs b/src/Darcs/Patch/Effect.hs --- a/src/Darcs/Patch/Effect.hs +++ b/src/Darcs/Patch/Effect.hs @@ -1,5 +1,9 @@ +{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} module Darcs.Patch.Effect ( Effect(..) ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Prim.Class ( PrimOf ) import Darcs.Patch.Witnesses.Ordered @@ -17,6 +21,7 @@ effect = reverseRL . effectRL effectRL :: p wX wY -> RL (PrimOf p) wX wY effectRL = reverseFL . effect + {-# MINIMAL effect | effectRL #-} instance Effect p => Effect (FL p) where effect p = concatFL $ mapFL_FL effect p diff --git a/src/Darcs/Patch/FileHunk.hs b/src/Darcs/Patch/FileHunk.hs --- a/src/Darcs/Patch/FileHunk.hs +++ b/src/Darcs/Patch/FileHunk.hs @@ -3,6 +3,9 @@ ) where +import Prelude () +import Darcs.Prelude + import Darcs.Util.Path ( FileName ) import Darcs.Patch.Format ( FileNameFormat ) import Darcs.Patch.Show ( formatFileName ) diff --git a/src/Darcs/Patch/Index/Monad.hs b/src/Darcs/Patch/Index/Monad.hs --- a/src/Darcs/Patch/Index/Monad.hs +++ b/src/Darcs/Patch/Index/Monad.hs @@ -17,22 +17,23 @@ -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} module Darcs.Patch.Index.Monad ( FileModMonad, withPatchMods ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Index.Types ( PatchMod(..) ) -import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) -import Control.Applicative ( Applicative ) +import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) ) import Control.Monad.State import Control.Arrow import Darcs.Util.Path ( FileName, fn2fp, movedirfilename ) import qualified Data.Set as S import Data.Set ( Set ) import Data.List ( isPrefixOf ) -import Storage.Hashed.Tree (Tree) +import Darcs.Util.Tree (Tree) #include "impossible.h" newtype FileModMonad a = FMM (State (Set FileName, [PatchMod FileName]) a) @@ -43,8 +44,13 @@ -- These instances are defined to be used only with -- apply. -instance ApplyMonad FileModMonad Tree where +instance ApplyMonad Tree FileModMonad where type ApplyMonadBase FileModMonad = FileModMonad + nestedApply _ _ = bug "nestedApply FileModMonad" + liftApply _ _ = bug "liftApply FileModMonad" + getApplyState = bug "getApplyState FileModMonad" + +instance ApplyMonadTree FileModMonad where mDoesDirectoryExist d = do fps <- gets fst return $ S.member d fps @@ -52,10 +58,6 @@ fps <- gets fst return $ S.member f fps mReadFilePS _ = bug "mReadFilePS FileModMonad" - nestedApply _ _ = bug "nestedApply FileModMonad" - liftApply _ _ = bug "liftApply FileModMonad" - getApplyState = bug "getApplyState FileModMonad" - putApplyState _ = bug "putApplyState FileModMonad" mCreateFile = createFile mCreateDirectory = createDir mRemoveFile = remove @@ -107,7 +109,7 @@ error $ unwords [ "error: patch index entry for" , if isFile then "file" else "directory" , fn2fp fn - , "created >1 times" + , "created >1 times. Run `darcs repair` and try again." ] remove :: FileName -> FileModMonad () diff --git a/src/Darcs/Patch/Index/Types.hs b/src/Darcs/Patch/Index/Types.hs --- a/src/Darcs/Patch/Index/Types.hs +++ b/src/Darcs/Patch/Index/Types.hs @@ -18,6 +18,9 @@ module Darcs.Patch.Index.Types where +import Prelude () +import Darcs.Prelude + import Darcs.Util.Crypt.SHA1( SHA1(..) ) import Darcs.Util.Path ( fp2fn, fn2fp, FileName ) import Darcs.Patch.Info ( makePatchname, PatchInfo ) diff --git a/src/Darcs/Patch/Info.hs b/src/Darcs/Patch/Info.hs --- a/src/Darcs/Patch/Info.hs +++ b/src/Darcs/Patch/Info.hs @@ -25,6 +25,10 @@ piName, piRename, piAuthor, piTag, piLog, showPatchInfo, isTag, readPatchInfos, escapeXML ) where + +import Prelude () +import Darcs.Prelude + import System.Random ( randomRIO ) import Numeric ( showHex ) import Control.Monad ( when, unless, void ) diff --git a/src/Darcs/Patch/Inspect.hs b/src/Darcs/Patch/Inspect.hs --- a/src/Darcs/Patch/Inspect.hs +++ b/src/Darcs/Patch/Inspect.hs @@ -3,6 +3,9 @@ ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Witnesses.Ordered ( FL, RL, reverseRL, mapFL ) import qualified Data.ByteString.Char8 as BC diff --git a/src/Darcs/Patch/Invert.hs b/src/Darcs/Patch/Invert.hs --- a/src/Darcs/Patch/Invert.hs +++ b/src/Darcs/Patch/Invert.hs @@ -3,6 +3,9 @@ ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), reverseFL, reverseRL ) @@ -11,11 +14,11 @@ invertFL :: Invert p => FL p wX wY -> RL p wY wX invertFL NilFL = NilRL -invertFL (x:>:xs) = invert x :<: invertFL xs +invertFL (x:>:xs) = invertFL xs :<: invert x invertRL :: Invert p => RL p wX wY -> FL p wY wX invertRL NilRL = NilFL -invertRL (x:<:xs) = invert x :>: invertRL xs +invertRL (xs:<:x) = invert x :>: invertRL xs instance Invert p => Invert (FL p) where invert = reverseRL . invertFL diff --git a/src/Darcs/Patch/Match.hs b/src/Darcs/Patch/Match.hs --- a/src/Darcs/Patch/Match.hs +++ b/src/Darcs/Patch/Match.hs @@ -67,6 +67,9 @@ , MatchFlag(..) ) where +import Prelude () +import Darcs.Prelude + import Text.ParserCombinators.Parsec ( parse , CharParser @@ -100,25 +103,27 @@ import Darcs.Util.Path ( AbsolutePath ) import Darcs.Patch ( Patchy + , IsRepoType , hunkMatches , listTouchedFiles - , patchcontents - , Named , invert , invertRL - , patch2patchinfo , apply ) import Darcs.Patch.Info ( justName, justAuthor, justLog, makePatchname, piDate ) +import Darcs.Patch.Named.Wrapped + ( WrappedNamed + , patch2patchinfo + ) import qualified Data.ByteString.Char8 as BC import Darcs.Patch.Dummy ( DummyPatch ) import Darcs.Patch.Matchable ( Matchable ) -import Darcs.Patch.MaybeInternal ( MaybeInternal, patchInternalChecker, isInternal, flIsInternal ) import Darcs.Patch.MonadProgress ( MonadProgress ) +import Darcs.Patch.Named.Wrapped ( runInternalChecker, namedIsInternal, namedInternalChecker ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, conscientiously, hopefully ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL, Origin ) import Darcs.Patch.Type ( PatchType(..) ) @@ -127,7 +132,7 @@ import Darcs.Patch.Depends ( getPatchesBeyondTag, splitOnTag ) import Darcs.Patch.Witnesses.Eq ( isIsEq ) -import Darcs.Patch.Witnesses.Ordered ( RL(..), consRLSealed, FL(..), (:>)(..) ) +import Darcs.Patch.Witnesses.Ordered ( RL(..), snocRLSealed, FL(..), (:>)(..) ) import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), Sealed2(..), seal, flipSeal, seal2, unsealFlipped, unseal2, unseal ) @@ -136,18 +141,18 @@ import Darcs.Util.DateMatcher ( parseDateMatcher ) -import Storage.Hashed.Tree ( Tree ) +import Darcs.Util.Tree ( Tree ) #include "impossible.h" -- | A type for predicates over patches which do not care about -- contexts -type MatchFun p = Sealed2 (PatchInfoAnd p) -> Bool +type MatchFun rt p = Sealed2 (PatchInfoAnd rt p) -> Bool -- | A @Matcher@ is made of a 'MatchFun' which we will use to match -- patches and a @String@ representing it. -data Matcher p = MATCH String (MatchFun p) +data Matcher rt p = MATCH String (MatchFun rt p) -instance Show (Matcher p) where +instance Show (Matcher rt p) where show (MATCH s _) = '"':s ++ "\"" @@ -172,37 +177,37 @@ deriving ( Show ) -makeMatcher :: String -> (Sealed2 (PatchInfoAnd p) -> Bool) -> Matcher p +makeMatcher :: String -> (Sealed2 (PatchInfoAnd rt p) -> Bool) -> Matcher rt p makeMatcher = MATCH -- | @applyMatcher@ applies a matcher to a patch. -applyMatcher :: Matcher p -> PatchInfoAnd p wX wY -> Bool +applyMatcher :: Matcher rt p -> PatchInfoAnd rt p wX wY -> Bool applyMatcher (MATCH _ m) = m . seal2 -parseMatch :: Matchable p => String -> Either String (MatchFun p) +parseMatch :: Matchable p => String -> Either String (MatchFun rt p) parseMatch pattern = case parse matchParser "match" pattern of Left err -> Left $ "Invalid --match pattern '"++ pattern ++ "'.\n"++ unlines (map (" "++) $ lines $ show err) -- indent Right m -> Right m -matchPattern :: Matchable p => String -> Matcher p +matchPattern :: Matchable p => String -> Matcher rt p matchPattern pattern = case parseMatch pattern of Left err -> error err Right m -> makeMatcher pattern m -addInternalMatcher :: Matchable p => Maybe (Matcher p) -> Maybe (Matcher p) +addInternalMatcher :: (IsRepoType rt, Matchable p) => Maybe (Matcher rt p) -> Maybe (Matcher rt p) addInternalMatcher om = - case patchInternalChecker of + case namedInternalChecker of Nothing -> om Just f -> - let matchFun = unseal2 (not . isIsEq . isInternal f . patchcontents . hopefully) + let matchFun = unseal2 (not . isIsEq . runInternalChecker f . hopefully) in case om of Nothing -> Just (MATCH "internal patch" matchFun) Just (MATCH s oldFun) -> Just (MATCH s (\p -> matchFun p && oldFun p)) -matchParser :: Matchable p => CharParser st (MatchFun p) +matchParser :: Matchable p => CharParser st (MatchFun rt p) matchParser = submatcher helpfulErrorMsg where submatcher = do @@ -217,18 +222,18 @@ ++ "\nfor more help, see `darcs help patterns`." -- This type signature is just to bind an ambiguous type var. - ps :: [(String, String, [String], String -> MatchFun DummyPatch)] + ps :: [(String, String, [String], String -> MatchFun rt DummyPatch)] ps = primitiveMatchers -- matchAnyPatch is returned if submatch fails without consuming any -- input, i.e. if we pass --match '', we want to match anything. - matchAnyPatch :: Matchable p => MatchFun p + matchAnyPatch :: Matchable p => MatchFun rt p matchAnyPatch = const True -submatch :: Matchable p => CharParser st (MatchFun p) +submatch :: Matchable p => CharParser st (MatchFun rt p) submatch = buildExpressionParser table match -table :: OperatorTable Char st (MatchFun p) +table :: OperatorTable Char st (MatchFun rt p) table = [ [prefix "not" negate_match, prefix "!" negate_match ] , [binary "||" or_match, @@ -248,13 +253,13 @@ trystring :: String -> CharParser st String trystring s = try $ string s -match :: Matchable p => CharParser st (MatchFun p) +match :: Matchable p => CharParser st (MatchFun rt p) match = between spaces spaces (parens submatch <|> choice matchers_) where matchers_ = map createMatchHelper primitiveMatchers -createMatchHelper :: (String, String, [String], String -> MatchFun p) - -> CharParser st (MatchFun p) +createMatchHelper :: (String, String, [String], String -> MatchFun rt p) + -> CharParser st (MatchFun rt p) createMatchHelper (key,_,_,matcher) = do _ <- trystring key spaces @@ -278,7 +283,7 @@ "- --hash=HASH is a synonym for --matches='hash HASH'", "- --from-patch and --to-patch are synonyms for --from-match='name... and --to-match='name...", "- --from-patch and --to-match can be unproblematically combined:", - " `darcs changes --from-patch='html.*documentation' --to-match='date 20040212'`", + " `darcs log --from-patch='html.*documentation' --to-match='date 20040212'`", "", "The following primitive Boolean expressions are supported:" ,""] @@ -286,7 +291,7 @@ ++ ["", "Here are some examples:", ""] ++ examples where -- This type signature exists to appease GHC. - ps :: [(String, String, [String], String -> MatchFun DummyPatch)] + ps :: [(String, String, [String], String -> MatchFun rt DummyPatch)] ps = primitiveMatchers keywords = [showKeyword k d | (k,d,_,_) <- ps] examples = [showExample k e | (k,_,es,_) <- ps, e <- es] @@ -296,13 +301,10 @@ -- or "exact STRING - match against exact patch name". "- " ++ keyword ++ " - " ++ description ++ "." showExample keyword example = - -- FIXME: this string is long, and its not a use case I've - -- ever seen in practice. Can we use something else, - -- like "darcs changes --matches"? --twb, 2008-12-28 - " darcs annotate --summary --match " + " darcs log --match " ++ "'" ++ keyword ++ " " ++ example ++ "'" -primitiveMatchers :: Matchable p => [(String, String, [String], String -> MatchFun p)] +primitiveMatchers :: Matchable p => [(String, String, [String], String -> MatchFun rt p)] -- ^ keyword (operator), help description, list -- of examples, matcher function primitiveMatchers = @@ -331,8 +333,8 @@ , ["src/foo.c", "src/", "\"src/*.(c|h)\""] , touchmatch ) ] -parens :: CharParser st (MatchFun p) - -> CharParser st (MatchFun p) +parens :: CharParser st (MatchFun rt p) + -> CharParser st (MatchFun rt p) parens = between (string "(") (string ")") quoted :: CharParser st String @@ -345,7 +347,7 @@ "string" namematch, exactmatch, authormatch, hunkmatch, hashmatch, datematch, touchmatch - :: Matchable p => String -> MatchFun p + :: Matchable p => String -> MatchFun rt p namematch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ justName (info hp) @@ -353,12 +355,11 @@ authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ justAuthor (info hp) -logmatch :: Matchable p => String -> MatchFun p +logmatch :: Matchable p => String -> MatchFun rt p logmatch l (Sealed2 hp) = isJust $ matchRegex (mkRegex l) $ justLog (info hp) -hunkmatch r (Sealed2 hp) = let patch = patchcontents $ hopefully hp - regexMatcher = isJust . matchRegex (mkRegex r) . BC.unpack - in hunkMatches regexMatcher patch +hunkmatch r (Sealed2 hp) = let regexMatcher = isJust . matchRegex (mkRegex r) . BC.unpack + in hunkMatches regexMatcher hp hashmatch h (Sealed2 hp) = let rh = show $ makePatchname (info hp) lh = map toLower h @@ -367,7 +368,7 @@ datematch d (Sealed2 hp) = let dm = unsafePerformIO $ parseDateMatcher d in dm $ piDate (info hp) -touchmatch r (Sealed2 hp) = let files = listTouchedFiles $ patchcontents $ hopefully hp +touchmatch r (Sealed2 hp) = let files = listTouchedFiles hp in any (isJust . matchRegex (mkRegex r)) files data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq @@ -376,25 +377,30 @@ -- @flags@ which corresponds to a match that is "non-range". Thus, -- @--match@, @--patch@, @--hash@ and @--index@ make @haveNonrangeMatch@ -- true, but not @--from-patch@ or @--to-patch@. -haveNonrangeMatch :: forall p . Matchable p => PatchType p -> [MatchFlag] -> Bool +haveNonrangeMatch :: forall rt p . (IsRepoType rt, Matchable p) => PatchType rt p -> [MatchFlag] -> Bool haveNonrangeMatch _ fs = case hasIndexRange fs of Just (m,n) | m == n -> True; _ -> False - || isJust (nonrangeMatcher fs::Maybe (Matcher p)) + || isJust (nonrangeMatcher fs::Maybe (Matcher rt p)) -- | @havePatchsetMatch flags@ tells whether there is a "patchset -- match" in the flag list. A patchset match is @--match@ or -- @--patch@, or @--context@, but not @--from-patch@ nor (!) -- @--index@. -- Question: Is it supposed not to be a subset of @haveNonrangeMatch@? -havePatchsetMatch :: [MatchFlag] -> Bool -havePatchsetMatch fs = isJust (nonrangeMatcher fs::Maybe (Matcher DummyPatch)) || hasC fs +havePatchsetMatch + :: forall rt p + . (IsRepoType rt, Matchable p) + => PatchType rt p -> [MatchFlag] -> Bool +havePatchsetMatch _ fs = isJust (nonrangeMatcher fs::Maybe (Matcher rt p)) || hasC fs where hasC [] = False hasC (Context _:_) = True hasC (_:xs) = hasC xs -getNonrangeMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, Matchable p, ApplyState p ~ Tree) +getNonrangeMatchS :: ( ApplyMonad (ApplyState p) m, MonadProgress m + , IsRepoType rt, Matchable p, ApplyState p ~ Tree + ) => [MatchFlag] - -> PatchSet p Origin wX + -> PatchSet rt p Origin wX -> m () getNonrangeMatchS fs repo = case nonrangeMatcher fs of @@ -408,11 +414,11 @@ -- than against all patches since the creation of the repository. firstMatch :: [MatchFlag] -> Bool firstMatch fs = isJust (hasLastn fs) - || isJust (firstMatcher fs::Maybe (Matcher DummyPatch)) + || isJust (firstMatcher fs::Maybe (Matcher rt DummyPatch)) || isJust (hasIndexRange fs) -getFirstMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, Matchable p) - => [MatchFlag] -> PatchSet p Origin wX -> m () +getFirstMatchS :: (ApplyMonad (ApplyState p) m, MonadProgress m, Matchable p, IsRepoType rt) + => [MatchFlag] -> PatchSet rt p Origin wX -> m () getFirstMatchS fs repo = case hasLastn fs of Just n -> unpullLastN repo n @@ -430,10 +436,10 @@ -- is if we match against patches up to a point in the past on, rather -- than against all patches until now. secondMatch :: [MatchFlag] -> Bool -secondMatch fs = isJust (secondMatcher fs::Maybe (Matcher DummyPatch)) || isJust (hasIndexRange fs) +secondMatch fs = isJust (secondMatcher fs::Maybe (Matcher rt DummyPatch)) || isJust (hasIndexRange fs) -unpullLastN :: (ApplyMonad m (ApplyState p), MonadProgress m, Patchy p, MaybeInternal p) - => PatchSet p wX wY +unpullLastN :: (ApplyMonad (ApplyState p) m, MonadProgress m, Patchy p, IsRepoType rt) + => PatchSet rt p wX wY -> Int -> m () unpullLastN repo n = applyInvRL `unsealFlipped` safetake n (newset2RL repo) @@ -442,7 +448,7 @@ checkMatchSyntax opts = case getMatchPattern opts of Nothing -> return () - Just p -> either fail (const $ return ()) (parseMatch p::Either String (MatchFun DummyPatch)) + Just p -> either fail (const $ return ()) (parseMatch p::Either String (MatchFun rt DummyPatch)) getMatchPattern :: [MatchFlag] -> Maybe String getMatchPattern [] = Nothing @@ -450,16 +456,16 @@ getMatchPattern (SeveralPattern m:_) = Just m getMatchPattern (_:fs) = getMatchPattern fs -tagmatch :: Matchable p => String -> Matcher p +tagmatch :: Matchable p => String -> Matcher rt p tagmatch r = makeMatcher ("tag-name "++r) tm where tm (Sealed2 p) = let n = justName (info p) in "TAG " `isPrefixOf` n && isJust (matchRegex (mkRegex r) $ drop 4 n) -patchmatch :: Matchable p => String -> Matcher p +patchmatch :: Matchable p => String -> Matcher rt p patchmatch r = makeMatcher ("patch-name "++r) (namematch r) -hashmatch' :: Matchable p => String -> Matcher p +hashmatch' :: Matchable p => String -> Matcher rt p hashmatch' r = makeMatcher ("hash "++r) (hashmatch r) @@ -472,7 +478,8 @@ -- | @nonrangeMatcher@ is the criterion that is used to match against -- patches in the interval. It is 'Just m' when the @--patch@, @--match@, -- @--tag@ options are passed (or their plural variants). -nonrangeMatcher, nonrangeMatcherArgs :: Matchable p => [MatchFlag] -> Maybe (Matcher p) +nonrangeMatcher :: (IsRepoType rt, Matchable p) => [MatchFlag] -> Maybe (Matcher rt p) +nonrangeMatcherArgs :: Matchable p => [MatchFlag] -> Maybe (Matcher rt p) nonrangeMatcher fs = addInternalMatcher $ nonrangeMatcherArgs fs @@ -496,7 +503,7 @@ -- This left bound is also specified when we use the singular versions -- of @--patch@, @--match@ and @--tag@. Otherwise, @firstMatcher@ -- returns @Nothing@. -firstMatcher :: Matchable p => [MatchFlag] -> Maybe (Matcher p) +firstMatcher :: Matchable p => [MatchFlag] -> Maybe (Matcher rt p) firstMatcher [] = Nothing firstMatcher (OnePattern m:_) = strictJust $ matchPattern m firstMatcher (AfterPattern m:_) = strictJust $ matchPattern m @@ -512,7 +519,7 @@ firstMatcherIsTag (AfterTag _:_) = True firstMatcherIsTag (_:fs) = firstMatcherIsTag fs -secondMatcher :: Matchable p => [MatchFlag] -> Maybe (Matcher p) +secondMatcher :: Matchable p => [MatchFlag] -> Maybe (Matcher rt p) secondMatcher [] = Nothing secondMatcher (OnePattern m:_) = strictJust $ matchPattern m secondMatcher (UpToPattern m:_) = strictJust $ matchPattern m @@ -530,20 +537,20 @@ -- | @matchAPatchread fs p@ tells whether @p@ matches the matchers in -- the flags listed in @fs@. -matchAPatchread :: Matchable p => [MatchFlag] -> PatchInfoAnd p wX wY -> Bool +matchAPatchread :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchInfoAnd rt p wX wY -> Bool matchAPatchread fs = case nonrangeMatcher fs of Nothing -> const True Just m -> applyMatcher m -- | @matchAPatch fs p@ tells whether @p@ matches the matchers in -- the flags @fs@ -matchAPatch :: Matchable p => [MatchFlag] -> PatchInfoAnd p wX wY -> Bool +matchAPatch :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchInfoAnd rt p wX wY -> Bool matchAPatch fs p = case nonrangeMatcher fs of Nothing -> True Just m -> applyMatcher m p -matchPatch :: Matchable p => [MatchFlag] -> PatchSet p wStart wX -> Sealed2 (Named p) +matchPatch :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchSet rt p wStart wX -> Sealed2 (WrappedNamed rt p) matchPatch fs ps = case hasIndexRange fs of Just (a,a') | a == a' -> case unseal myhead $ dropn (a-1) ps of @@ -551,9 +558,9 @@ Nothing -> error "Patch out of range!" | otherwise -> bug ("Invalid index range match given to matchPatch: "++ show (PatchIndexRange a a')) - where myhead :: PatchSet p wStart wX -> Maybe (Sealed2 (PatchInfoAnd p)) - myhead (PatchSet NilRL (Tagged t _ _ :<: _)) = Just $ seal2 t - myhead (PatchSet (x:<:_) _) = Just $ seal2 x + where myhead :: PatchSet rt p wStart wX -> Maybe (Sealed2 (PatchInfoAnd rt p)) + myhead (PatchSet (_ :<: Tagged t _ _) NilRL) = Just $ seal2 t + myhead (PatchSet _ (_:<:x)) = Just $ seal2 x myhead _ = Nothing Nothing -> case nonrangeMatcher fs of Nothing -> bug "Couldn't matchPatch" @@ -575,8 +582,8 @@ -- first matcher, ie the one that comes first dependencywise. Hence, -- patches in @matchFirstPatchset fs ps@ are the context for the ones -- we don't want. -matchFirstPatchset :: Matchable p => [MatchFlag] -> PatchSet p wStart wX - -> SealedPatchSet p wStart +matchFirstPatchset :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchSet rt p wStart wX + -> SealedPatchSet rt p wStart matchFirstPatchset fs patchset = case hasLastn fs of Just n -> dropn n patchset @@ -591,19 +598,19 @@ else matchAPatchset m patchset -- | @dropn n ps@ drops the @n@ last patches from @ps@. -dropn :: MaybeInternal p => Int -> PatchSet p wStart wX -> SealedPatchSet p wStart +dropn :: IsRepoType rt => Int -> PatchSet rt p wStart wX -> SealedPatchSet rt p wStart dropn n ps | n <= 0 = seal ps -dropn n (PatchSet NilRL (Tagged t _ ps :<: ts)) = dropn n $ PatchSet (t:<:ps) ts +dropn n (PatchSet (ts :<: Tagged t _ ps) NilRL) = dropn n $ PatchSet ts (ps:<:t) dropn _ (PatchSet NilRL NilRL) = seal $ PatchSet NilRL NilRL -dropn n (PatchSet (p:<:ps) ts) - | isIsEq (flIsInternal (patchcontents (hopefully p))) - = dropn n $ PatchSet ps ts -dropn n (PatchSet (_:<:ps) ts) = dropn (n-1) $ PatchSet ps ts +dropn n (PatchSet ts (ps:<:p)) + | isIsEq (namedIsInternal (hopefully p)) + = dropn n $ PatchSet ts ps +dropn n (PatchSet ts (ps:<:_)) = dropn (n-1) $ PatchSet ts ps -- | @matchSecondPatchset fs ps@ returns the part of @ps@ before its -- second matcher, ie the one that comes last dependencywise. -matchSecondPatchset :: Matchable p => [MatchFlag] -> PatchSet p wStart wX - -> SealedPatchSet p wStart +matchSecondPatchset :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchSet rt p wStart wX + -> SealedPatchSet rt p wStart matchSecondPatchset fs ps = case hasIndexRange fs of Just (a,_) -> dropn (a-1) ps @@ -618,7 +625,7 @@ -- the earliest patch in a sequence, as opposed to 'matchSecondPatchset' which picks up the -- first match starting from the latest patch splitSecondFL :: Matchable p - => (forall wA wB . q wA wB -> Sealed2 (PatchInfoAnd p)) + => (forall wA wB . q wA wB -> Sealed2 (PatchInfoAnd rt p)) -> [MatchFlag] -> FL q wX wY -> (FL q :> FL q) wX wY -- ^The first element is the patches before and including the first patch matching the second matcher, @@ -634,38 +641,38 @@ -- | @findAPatch m ps@ returns the last patch in @ps@ matching @m@, and -- calls 'error' if there is none. -findAPatch :: Matchable p => Matcher p -> PatchSet p wStart wX -> Sealed2 (Named p) +findAPatch :: Matchable p => Matcher rt p -> PatchSet rt p wStart wX -> Sealed2 (WrappedNamed rt p) findAPatch m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m -findAPatch m (PatchSet NilRL (Tagged t _ ps :<: ts)) = findAPatch m (PatchSet (t:<:ps) ts) -findAPatch m (PatchSet (p:<:ps) ts) | applyMatcher m p = seal2 $ hopefully p - | otherwise = findAPatch m (PatchSet ps ts) +findAPatch m (PatchSet (ts :<: Tagged t _ ps) NilRL) = findAPatch m (PatchSet ts (ps:<:t)) +findAPatch m (PatchSet ts (ps:<:p)) | applyMatcher m p = seal2 $ hopefully p + | otherwise = findAPatch m (PatchSet ts ps) -- | @matchAPatchset m ps@ returns a (the largest?) subset of @ps@ -- ending in patch which matches @m@. Calls 'error' if there is none. -matchAPatchset :: Matchable p => Matcher p -> PatchSet p wStart wX - -> SealedPatchSet p wStart +matchAPatchset :: Matchable p => Matcher rt p -> PatchSet rt p wStart wX + -> SealedPatchSet rt p wStart matchAPatchset m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m -matchAPatchset m (PatchSet NilRL (Tagged t _ ps :<: ts)) = matchAPatchset m (PatchSet (t:<:ps) ts) -matchAPatchset m (PatchSet (p:<:ps) ts) | applyMatcher m p = seal (PatchSet (p:<:ps) ts) - | otherwise = matchAPatchset m (PatchSet ps ts) +matchAPatchset m (PatchSet (ts :<: Tagged t _ ps) NilRL) = matchAPatchset m (PatchSet ts (ps:<:t)) +matchAPatchset m (PatchSet ts (ps:<:p)) | applyMatcher m p = seal (PatchSet ts (ps:<:p)) + | otherwise = matchAPatchset m (PatchSet ts ps) -- | @getMatchingTag m ps@, where @m@ is a 'Matcher' which matches tags -- returns a 'SealedPatchSet' containing all patches in the last tag which -- matches @m@. Last tag means the most recent tag in repository order, --- i.e. the last one you'd see if you ran darcs changes -t @m@. Calls +-- i.e. the last one you'd see if you ran darcs log -t @m@. Calls -- 'error' if there is no matching tag. -getMatchingTag :: Matchable p => Matcher p -> PatchSet p wStart wX -> SealedPatchSet p wStart +getMatchingTag :: Matchable p => Matcher rt p -> PatchSet rt p wStart wX -> SealedPatchSet rt p wStart getMatchingTag m (PatchSet NilRL NilRL) = error $ "Couldn't find a tag matching " ++ show m -getMatchingTag m (PatchSet NilRL (Tagged t _ ps :<: ts)) = getMatchingTag m (PatchSet (t:<:ps) ts) -getMatchingTag m (PatchSet (p:<:ps) ts) +getMatchingTag m (PatchSet (ts :<: Tagged t _ ps) NilRL) = getMatchingTag m (PatchSet ts (ps:<:t)) +getMatchingTag m (PatchSet ts (ps:<:p)) | applyMatcher m p = -- found a non-clean tag, need to commute out the things that it doesn't depend on - case splitOnTag (info p) (PatchSet (p:<:ps) ts) of + case splitOnTag (info p) (PatchSet ts (ps:<:p)) of Nothing -> bug "splitOnTag couldn't find tag we explicitly provided!" Just (patchSet :> _) -> seal patchSet - | otherwise = getMatchingTag m (PatchSet ps ts) + | otherwise = getMatchingTag m (PatchSet ts ps) -splitMatchFL :: Matchable p => (forall wA wB . q wA wB -> Sealed2 (PatchInfoAnd p)) -> Matcher p -> FL q wX wY -> (FL q :> FL q) wX wY +splitMatchFL :: Matchable p => (forall wA wB . q wA wB -> Sealed2 (PatchInfoAnd rt p)) -> Matcher rt p -> FL q wX wY -> (FL q :> FL q) wX wY splitMatchFL _extract m NilFL = error $ "Couldn't find patch matching " ++ show m splitMatchFL extract m (p :>: ps) | unseal2 (applyMatcher m) . extract $ p = (p :>: NilFL) :> ps @@ -674,40 +681,40 @@ -- | @matchExists m ps@ tells whether there is a patch matching -- @m@ in @ps@ -matchExists :: Matcher p -> PatchSet p wStart wX -> Bool +matchExists :: Matcher rt p -> PatchSet rt p wStart wX -> Bool matchExists _ (PatchSet NilRL NilRL) = False -matchExists m (PatchSet NilRL (Tagged t _ ps :<: ts)) = matchExists m (PatchSet (t:<:ps) ts) -matchExists m (PatchSet (p:<:ps) ts) | applyMatcher m p = True - | otherwise = matchExists m (PatchSet ps ts) +matchExists m (PatchSet (ts :<: Tagged t _ ps) NilRL) = matchExists m (PatchSet ts (ps:<:t)) +matchExists m (PatchSet ts (ps:<:p)) | applyMatcher m p = True + | otherwise = matchExists m (PatchSet ts ps) -applyInvToMatcher :: (Matchable p, ApplyMonad m (ApplyState p)) - => InclusiveOrExclusive -> Matcher p -> PatchSet p Origin wX -> m () +applyInvToMatcher :: (Matchable p, ApplyMonad (ApplyState p) m) + => InclusiveOrExclusive -> Matcher rt p -> PatchSet rt p Origin wX -> m () applyInvToMatcher _ _ (PatchSet NilRL NilRL) = impossible -applyInvToMatcher ioe m (PatchSet NilRL (Tagged t _ ps :<: ts)) = applyInvToMatcher ioe m - (PatchSet (t:<:ps) ts) -applyInvToMatcher ioe m (PatchSet (p:<:ps) xs) +applyInvToMatcher ioe m (PatchSet (ts :<: Tagged t _ ps) NilRL) = applyInvToMatcher ioe m + (PatchSet ts (ps:<:t)) +applyInvToMatcher ioe m (PatchSet xs (ps:<:p)) | applyMatcher m p = when (ioe == Inclusive) (applyInvp p) - | otherwise = applyInvp p >> applyInvToMatcher ioe m (PatchSet ps xs) + | otherwise = applyInvp p >> applyInvToMatcher ioe m (PatchSet xs ps) -- | @applyNInv@ n ps applies the inverse of the last @n@ patches of @ps@. -applyNInv :: (Matchable p, ApplyMonad m (ApplyState p)) => Int -> PatchSet p Origin wX -> m () +applyNInv :: (Matchable p, ApplyMonad (ApplyState p) m) => Int -> PatchSet rt p Origin wX -> m () applyNInv n _ | n <= 0 = return () applyNInv _ (PatchSet NilRL NilRL) = error "Index out of range." -applyNInv n (PatchSet NilRL (Tagged t _ ps :<: ts)) = - applyNInv n (PatchSet (t :<: ps) ts) -applyNInv n (PatchSet (p :<: ps) xs) = - applyInvp p >> applyNInv (n - 1) (PatchSet ps xs) +applyNInv n (PatchSet (ts :<: Tagged t _ ps) NilRL) = + applyNInv n (PatchSet ts (ps :<: t)) +applyNInv n (PatchSet xs (ps :<: p)) = + applyInvp p >> applyNInv (n - 1) (PatchSet xs ps) -getMatcherS :: (ApplyMonad m (ApplyState p), Matchable p) => - InclusiveOrExclusive -> Matcher p -> PatchSet p Origin wX -> m () +getMatcherS :: (ApplyMonad (ApplyState p) m, Matchable p) => + InclusiveOrExclusive -> Matcher rt p -> PatchSet rt p Origin wX -> m () getMatcherS ioe m repo = if matchExists m repo then applyInvToMatcher ioe m repo else fail $ "Couldn't match pattern "++ show m -getTagS :: (ApplyMonad m (ApplyState p), MonadProgress m, Matchable p) => - Matcher p -> PatchSet p Origin wX -> m () +getTagS :: (ApplyMonad (ApplyState p) m, MonadProgress m, Matchable p) => + Matcher rt p -> PatchSet rt p Origin wX -> m () getTagS matcher repo = do let pinfo = patch2patchinfo `unseal2` findAPatch matcher repo case getPatchesBeyondTag pinfo repo of @@ -715,23 +722,22 @@ -- | @applyInvp@ tries to get the patch that's in a 'PatchInfoAnd -- patch', and to apply its inverse. If we fail to fetch the patch --- (presumably in a partial repositiory), then we share our sorrow --- with the user. -applyInvp :: (Patchy p, ApplyMonad m (ApplyState p)) => PatchInfoAnd p wX wY -> m () +-- then we share our sorrow with the user. +applyInvp :: (Patchy p, ApplyMonad (ApplyState p) m) => PatchInfoAnd rt p wX wY -> m () applyInvp hp = apply (invert $ fromHopefully hp) where fromHopefully = conscientiously $ \e -> - text "Sorry, partial repository problem. Patch not available:" + text "Sorry, patch not available:" $$ e $$ text "" $$ text "If you think what you're trying to do is ok then" $$ text "report this as a bug on the darcs-user list." -- | a version of 'take' for 'RL' lists that cater for contexts. -safetake :: MaybeInternal p => Int -> RL (PatchInfoAnd p) wX wY -> FlippedSeal (RL (PatchInfoAnd p)) wY +safetake :: IsRepoType rt => Int -> RL (PatchInfoAnd rt p) wX wY -> FlippedSeal (RL (PatchInfoAnd rt p)) wY safetake 0 _ = flipSeal NilRL safetake _ NilRL = error "There aren't that many patches..." -safetake i (a:<:as) | isIsEq (flIsInternal (patchcontents (hopefully a))) = a `consRLSealed` safetake i as -safetake i (a:<:as) = a `consRLSealed` safetake (i-1) as +safetake i (as:<:a) | isIsEq (namedIsInternal (hopefully a)) = safetake i as `snocRLSealed` a +safetake i (as:<:a) = safetake (i-1) as `snocRLSealed` a -applyInvRL :: (ApplyMonad m (ApplyState p), MonadProgress m, Patchy p) => RL (PatchInfoAnd p) wX wR -> m () +applyInvRL :: (ApplyMonad (ApplyState p) m, MonadProgress m, Patchy p) => RL (PatchInfoAnd rt p) wX wR -> m () applyInvRL = applyPatches . invertRL -- this gives nicer feedback diff --git a/src/Darcs/Patch/Matchable.hs b/src/Darcs/Patch/Matchable.hs --- a/src/Darcs/Patch/Matchable.hs +++ b/src/Darcs/Patch/Matchable.hs @@ -4,10 +4,8 @@ module Darcs.Patch.Matchable ( Matchable ) where -import Darcs.Patch.MaybeInternal ( MaybeInternal ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Patchy ( Patchy ) -import Darcs.Patch.Rebase.NameHack ( NameHack ) -class (Patchy p, PatchInspect p, MaybeInternal p, NameHack p) +class (Patchy p, PatchInspect p) => Matchable p diff --git a/src/Darcs/Patch/MaybeInternal.hs b/src/Darcs/Patch/MaybeInternal.hs deleted file mode 100644 --- a/src/Darcs/Patch/MaybeInternal.hs +++ /dev/null @@ -1,33 +0,0 @@ --- Copyright (C) 2009-2012 Ganesh Sittampalam --- --- BSD3 -module Darcs.Patch.MaybeInternal - ( - InternalChecker(..) - , MaybeInternal(..) - , flIsInternal - ) where - -import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) -import Darcs.Patch.Witnesses.Ordered ( FL ) - --- Note: the EqCheck result could be replaced by a Bool if clients were changed to commute the patch --- out if necessary. -newtype InternalChecker p = InternalChecker { isInternal :: forall wX wY . p wX wY -> EqCheck wX wY } - --- |Provides a hook for flagging whether a patch is "internal" to the repo --- and therefore shouldn't be referred to externally, e.g. by inclusion in tags. --- Note that despite the name, every patch type has to implement it, but for --- normal (non-internal) types the default implementation is fine. --- Currently only used for rebase internal patches. -class MaybeInternal p where - -- | @maybe (const NotEq) (fmap isInternal patchInternalChecker) p@ - -- returns 'IsEq' if @p@ is internal, and 'NotEq' otherwise. - -- The two-level structure is purely for efficiency: 'Nothing' and 'Just (InternalChecker (const NotEq))' are - -- semantically identical, but 'Nothing' allows clients to avoid traversing an entire list. - -- The patch type is passed as an 'FL' because that's how the internals of named patches are stored. - patchInternalChecker :: Maybe (InternalChecker (FL p)) - patchInternalChecker = Nothing - -flIsInternal :: MaybeInternal p => FL p wX wY -> EqCheck wX wY -flIsInternal = maybe (const NotEq) isInternal patchInternalChecker diff --git a/src/Darcs/Patch/Merge.hs b/src/Darcs/Patch/Merge.hs --- a/src/Darcs/Patch/Merge.hs +++ b/src/Darcs/Patch/Merge.hs @@ -1,4 +1,3 @@ - -- | -- Module : Darcs.Patch.Merge -- Maintainer : darcs-devel@darcs.net @@ -12,9 +11,6 @@ , mergeFL ) where - -import Data.Maybe ( fromJust ) - import Darcs.Patch.Commute ( Commute ) import Darcs.Patch.CommuteFn ( MergeFn ) import Darcs.Patch.Witnesses.Ordered @@ -31,31 +27,24 @@ merge :: (p :\/: p) wX wY -> (p :/\: p) wX wY - selfMerger :: Merge p => MergeFn p p selfMerger = merge - instance Merge p => Merge (FL p) where merge (NilFL :\/: x) = x :/\: NilFL merge (x :\/: NilFL) = NilFL :/\: x - merge ((x:>:xs) :\/: ys) = fromJust $ do - ys' :/\: x' <- return $ mergeFL (x :\/: ys) - xs' :/\: ys'' <- return $ merge (ys' :\/: xs) - return (ys'' :/\: (x' :>: xs')) - + merge ((x:>:xs) :\/: ys) = case mergeFL (x :\/: ys) of + ys' :/\: x' -> case merge (ys' :\/: xs) of + xs' :/\: ys'' -> ys'' :/\: (x' :>: xs') instance Merge p => Merge (RL p) where merge (x :\/: y) = case merge (reverseRL x :\/: reverseRL y) of - (ry' :/\: rx') -> reverseFL ry' :/\: reverseFL rx' - + (ry' :/\: rx') -> reverseFL ry' :/\: reverseFL rx' mergeFL :: Merge p => (p :\/: FL p) wX wY -> (FL p :/\: p) wX wY mergeFL (p :\/: NilFL) = NilFL :/\: p -mergeFL (p :\/: (x :>: xs)) = fromJust $ do - x' :/\: p' <- return $ merge (p :\/: x) - xs' :/\: p'' <- return $ mergeFL (p' :\/: xs) - return ((x' :>: xs') :/\: p'') - +mergeFL (p :\/: (x :>: xs)) = case merge (p :\/: x) of + x' :/\: p' -> case mergeFL (p' :\/: xs) of + xs' :/\: p'' -> (x' :>: xs') :/\: p'' diff --git a/src/Darcs/Patch/MonadProgress.hs b/src/Darcs/Patch/MonadProgress.hs --- a/src/Darcs/Patch/MonadProgress.hs +++ b/src/Darcs/Patch/MonadProgress.hs @@ -27,10 +27,12 @@ , silentlyRunProgressActions ) where -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude + import Darcs.Util.Printer ( Doc ) import Darcs.Util.Printer.Color () -- for instance Show Doc -import qualified Storage.Hashed.Monad as HSM +import qualified Darcs.Util.Tree.Monad as TM -- |a monadic action, annotated with a progress message that could be printed out -- while running the action, and a message that could be printed out on error. @@ -53,5 +55,5 @@ silentlyRunProgressActions :: Monad m => String -> [ProgressAction m ()] -> m () silentlyRunProgressActions _ = mapM_ paAction -instance (Functor m, Monad m) => MonadProgress (HSM.TreeMonad m) where +instance (Functor m, Monad m) => MonadProgress (TM.TreeMonad m) where runProgressActions = silentlyRunProgressActions diff --git a/src/Darcs/Patch/Named.hs b/src/Darcs/Patch/Named.hs --- a/src/Darcs/Patch/Named.hs +++ b/src/Darcs/Patch/Named.hs @@ -30,6 +30,9 @@ ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( pi ) import Darcs.Patch.CommuteFn ( CommuteFn, commuterIdFL, commuterFLId , MergeFn, mergerIdFL ) @@ -46,7 +49,6 @@ import Darcs.Patch.Prim ( PrimOf, PrimPatchBase ) import Darcs.Patch.ReadMonads ( ParserM, option, lexChar, choice, skipWhile, anyChar ) -import Darcs.Patch.Rebase.NameHack ( NameHack(..) ) import Darcs.Patch.Repair ( mapMaybeSnd, Repair(..), RepairToFL, Check(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), showNamedPrefix ) import Darcs.Patch.Summary ( plainSummary ) @@ -58,11 +60,8 @@ import Darcs.Patch.Witnesses.Sealed ( Sealed, mapSeal ) import Darcs.Patch.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..) ) -import Darcs.Util.Diff ( DiffAlgorithm(MyersDiff) ) import Darcs.Util.Printer ( ($$), (<+>), (<>), prefix, text, vcat ) -import Data.Maybe ( fromMaybe ) - -- | The @Named@ type adds a patch info about a patch, that is a name. data Named p wX wY where NamedP :: !PatchInfo @@ -158,13 +157,12 @@ invert (NamedP n d p) = NamedP (invertName n) (map invertName d) (invert p) -instance (Commute p, NameHack p) => Commute (Named p) where +instance Commute p => Commute (Named p) where commute (NamedP n1 d1 p1 :> NamedP n2 d2 p2) = if n2 `elem` d1 || n1 `elem` d2 then Nothing else do (p2' :> p1') <- commute (p1 :> p2) - let (informAdd, informDel) = fromMaybe (const id, const id) (nameHack MyersDiff) - return (NamedP n2 d2 (informAdd n1 p2') :> NamedP n1 d1 (informDel n2 p1')) + return (NamedP n2 d2 p2' :> NamedP n1 d1 p1') commuterIdNamed :: CommuteFn p1 p2 -> CommuteFn p1 (Named p2) commuterIdNamed commuter (p1 :> NamedP n2 d2 p2) = @@ -176,7 +174,7 @@ do p2' :> p1' <- commuterFLId commuter (p1 :> p2) return (p2' :> NamedP n1 d1 p1') -instance (Merge p, NameHack p) => Merge (Named p) where +instance Merge p => Merge (Named p) where merge (NamedP n1 d1 p1 :\/: NamedP n2 d2 p2) = case merge (p1 :\/: p2) of (p2' :/\: p1') -> NamedP n2 d2 p2' :/\: NamedP n1 d1 p1' @@ -191,8 +189,8 @@ hunkMatches f (NamedP _ _ p) = hunkMatches f p instance (CommuteNoConflicts p, Conflict p) => Conflict (Named p) where - listConflictedFiles (NamedP _ _ p) = listConflictedFiles p resolveConflicts (NamedP _ _ p) = resolveConflicts p + conflictedEffect (NamedP _ _ p) = conflictedEffect p instance Check p => Check (Named p) where isInconsistent (NamedP _ _ p) = isInconsistent p diff --git a/src/Darcs/Patch/Named/Wrapped.hs b/src/Darcs/Patch/Named/Wrapped.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Named/Wrapped.hs @@ -0,0 +1,344 @@ +{-# LANGUAGE StandaloneDeriving, TypeOperators #-} +module Darcs.Patch.Named.Wrapped + ( WrappedNamed(..) + , patch2patchinfo, activecontents + , infopatch, namepatch, anonymous + , getdeps, adddeps + , mkRebase, toRebasing, fromRebasing + , runInternalChecker, namedInternalChecker, namedIsInternal, removeInternalFL + , fmapFL_WrappedNamed, (:~:)(..), (:~~:)(..) + , generaliseRepoTypeWrapped + ) where + +import Prelude () +import Darcs.Prelude + +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.Commute ( Commute(..) ) +import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) ) +import Darcs.Patch.Effect ( Effect(..) ) +import Darcs.Patch.FileHunk ( IsHunk(..) ) +import Darcs.Patch.Format ( PatchListFormat(..), ListFormat, copyListFormat ) +import Darcs.Patch.Info + ( PatchInfo, showPatchInfo, showPatchInfoUI, patchinfo + ) +import Darcs.Patch.Invert ( Invert(..) ) +import Darcs.Patch.Named ( Named(..), fmapFL_Named ) +import qualified Darcs.Patch.Named as Base + ( patch2patchinfo, patchcontents + , infopatch, namepatch, anonymous + , getdeps, adddeps + ) +import Darcs.Patch.Inspect ( PatchInspect(..) ) +import Darcs.Patch.Merge ( Merge(..) ) +import Darcs.Patch.Prim ( FromPrim, PrimOf ) +import Darcs.Patch.Prim.Class ( PrimPatchBase ) +import Darcs.Patch.Read ( ReadPatch(..) ) +import qualified Darcs.Patch.Rebase.Container as Rebase + ( Suspended(..) + , addFixupsToSuspended, removeFixupsFromSuspended + ) +import Darcs.Patch.Repair ( mapMaybeSnd, Repair(..), RepairToFL(..), Check(..) ) +import Darcs.Patch.RepoType + ( RepoType(..), IsRepoType(..), SRepoType(..) + , RebaseType(..), RebaseTypeOf, SRebaseType(..) + ) +import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..) ) + +import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) +import Darcs.Patch.Witnesses.Sealed ( mapSeal ) +import Darcs.Patch.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..) ) +import Darcs.Patch.Witnesses.Ordered + ( FL(..), mapFL_FL, mapFL, (:>)(..) + , (:\/:)(..), (:/\:)(..) + ) + +import Darcs.Util.IsoDate ( getIsoDateTime ) +import Darcs.Util.Text ( formatParas ) +import Darcs.Util.Printer ( ($$), (<>), vcat, prefix ) + +import Control.Applicative ( (<|>) ) + +-- |A layer inbetween the 'Named p' type and 'PatchInfoAnd p' +-- design for holding "internal" patches such as the rebase +-- container. Ideally these patches would be stored at the +-- repository level but this would require some significant +-- refactoring/cleaning up of that code. +data WrappedNamed (rt :: RepoType) p wX wY where + NormalP :: !(Named p wX wY) -> WrappedNamed rt p wX wY + RebaseP + :: (PrimPatchBase p, FromPrim p, Effect p) + => !PatchInfo -- TODO: this should always be the "internal implementation detail" rebase + -- patch description, so could be replaced by just the Ignore-this and Date fields + -> !(Rebase.Suspended p wX wX) + -> WrappedNamed ('RepoType 'IsRebase) p wX wX + + +deriving instance Show2 p => Show (WrappedNamed rt p wX wY) + +instance Show2 p => Show1 (WrappedNamed rt p wX) where + showDict1 = ShowDictClass + +instance Show2 p => Show2 (WrappedNamed rt p) where + showDict2 = ShowDictClass + +-- TODO use Data.Type.Equality and PolyKinds from GHC 7.8/base 4.7 +data (a :: * -> * -> *) :~: b where + ReflPatch :: a :~: a + +data (a :: RebaseType) :~~: b where + ReflRebaseType :: a :~~: a + +-- |lift a function over an 'FL' of patches to one over +-- a 'WrappedNamed rt'. +-- The function is only applied to "normal" patches, +-- and any rebase container patch is left alone. +fmapFL_WrappedNamed + :: (FL p wA wB -> FL q wA wB) + -> (RebaseTypeOf rt :~~: 'IsRebase -> p :~: q) + -- ^If the patch might be a rebase container patch, + -- then 'p' and 'q' must be the same type, as no + -- transformation is applied. This function provides + -- a witness to this requirement: if 'RebaseTypeOf rt' + -- might be 'IsRebase', then it must be able to return + -- a proof that 'p' and 'q' are equal. If 'RebaseTypeOf rt' + -- must be 'NoRebase', then this function can never be called + -- with a valid value. + -> WrappedNamed rt p wA wB + -> WrappedNamed rt q wA wB +fmapFL_WrappedNamed f _ (NormalP n) = NormalP (fmapFL_Named f n) +fmapFL_WrappedNamed _ whenRebase (RebaseP n s) = + case whenRebase ReflRebaseType of + ReflPatch -> RebaseP n s + +patch2patchinfo :: WrappedNamed rt p wX wY -> PatchInfo +patch2patchinfo (NormalP p) = Base.patch2patchinfo p +patch2patchinfo (RebaseP name _) = name + +namepatch :: String -> String -> String -> [String] -> FL p wX wY -> IO (WrappedNamed rt p wX wY) +namepatch date name author desc p = fmap NormalP (Base.namepatch date name author desc p) + +anonymous :: FL p wX wY -> IO (WrappedNamed rt p wX wY) +anonymous p = fmap NormalP (Base.anonymous p) + +infopatch :: PatchInfo -> FL p wX wY -> WrappedNamed rt p wX wY +infopatch i ps = NormalP (Base.infopatch i ps) + +-- |Return a list of the underlying patches that are actually +-- 'active' in the repository, i.e. not suspended as part of a rebase +activecontents :: WrappedNamed rt p wX wY -> FL p wX wY +activecontents (NormalP p) = Base.patchcontents p +activecontents (RebaseP {}) = NilFL + +adddeps :: WrappedNamed rt p wX wY -> [PatchInfo] -> WrappedNamed rt p wX wY +adddeps (NormalP n) pis = NormalP (Base.adddeps n pis) +adddeps (RebaseP {}) _ = error "Internal error: can't add dependencies to a rebase internal patch" + +getdeps :: WrappedNamed rt p wX wY -> [PatchInfo] +getdeps (NormalP n) = Base.getdeps n +getdeps (RebaseP {}) = [] + +mkRebase :: (PrimPatchBase p, FromPrim p, Effect p) + => Rebase.Suspended p wX wX + -> IO (WrappedNamed ('RepoType 'IsRebase) p wX wX) +mkRebase s = do + let name = "DO NOT TOUCH: Rebase patch" + let desc = formatParas 72 + ["This patch is an internal implementation detail of rebase, used to store suspended patches, " ++ + "and should not be visible in the user interface. Please report a bug if a darcs " ++ + "command is showing you this patch."] + date <- getIsoDateTime + let author = "Invalid " + info <- patchinfo date name author desc + return $ RebaseP info s + +toRebasing :: Named p wX wY -> WrappedNamed ('RepoType 'IsRebase) p wX wY +toRebasing n = NormalP n + +fromRebasing :: WrappedNamed ('RepoType 'IsRebase) p wX wY -> Named p wX wY +fromRebasing (NormalP n) = n +fromRebasing (RebaseP {}) = error "internal error: found rebasing internal patch" + +generaliseRepoTypeWrapped + :: WrappedNamed ('RepoType 'NoRebase) p wA wB + -> WrappedNamed rt p wA wB +generaliseRepoTypeWrapped (NormalP p) = NormalP p + +-- Note: the EqCheck result could be replaced by a Bool if clients were changed to commute the patch +-- out if necessary. +newtype InternalChecker p = + InternalChecker { runInternalChecker :: forall wX wY . p wX wY -> EqCheck wX wY } + +-- |Is the given 'WrappedNamed' patch an internal implementation detail +-- that shouldn't be visible in the UI or included in tags/matchers etc? +-- Two-level checker for efficiency: if the value of this is 'Nothing' for a given +-- patch type then there's no need to inspect patches of this type at all, +-- as none of them can be internal. +namedInternalChecker :: forall rt p . IsRepoType rt => Maybe (InternalChecker (WrappedNamed rt p)) +namedInternalChecker = + case singletonRepoType :: SRepoType rt of + SRepoType SNoRebase -> Nothing + SRepoType SIsRebase -> + let + isInternal :: WrappedNamed rt p wX wY -> EqCheck wX wY + isInternal (NormalP {}) = NotEq + isInternal (RebaseP {}) = IsEq + in Just (InternalChecker isInternal) + +-- |Is the given 'WrappedNamed' patch an internal implementation detail +-- that shouldn't be visible in the UI or included in tags/matchers etc? +namedIsInternal :: IsRepoType rt => WrappedNamed rt p wX wY -> EqCheck wX wY +namedIsInternal = maybe (const NotEq) runInternalChecker namedInternalChecker + +removeInternalFL :: IsRepoType rt => FL (WrappedNamed rt p) wX wY -> FL (Named p) wX wY +removeInternalFL NilFL = NilFL +removeInternalFL (NormalP n :>: ps) = n :>: removeInternalFL ps +removeInternalFL (RebaseP {} :>: ps) = removeInternalFL ps + +instance PrimPatchBase p => PrimPatchBase (WrappedNamed rt p) where + type PrimOf (WrappedNamed rt p) = PrimOf p + +instance Invert p => Invert (WrappedNamed rt p) where + invert (NormalP n) = NormalP (invert n) + invert (RebaseP i s) = RebaseP i s -- TODO is this sensible? + +instance PatchListFormat (WrappedNamed rt p) + +instance IsHunk (WrappedNamed rt p) where + isHunk _ = Nothing + +instance (ShowPatchBasic p, PatchListFormat p) + => ShowPatchBasic (WrappedNamed rt p) where + + showPatch (NormalP n) = showPatch n + showPatch (RebaseP i s) = showPatchInfo i <> showPatch s + +instance ( ShowPatch p, PatchListFormat p, Apply p + , PrimPatchBase p, IsHunk p, Conflict p, CommuteNoConflicts p + ) + => ShowPatch (WrappedNamed rt p) where + + showContextPatch (NormalP n) = showContextPatch n + showContextPatch (RebaseP i s) = fmap (showPatchInfo i <>) $ showContextPatch s + + description (NormalP n) = description n + description (RebaseP i _) = showPatchInfoUI i + + summary (NormalP n) = summary n + summary (RebaseP i _) = showPatchInfoUI i + + summaryFL = vcat . mapFL summary + + showNicely (NormalP n) = showNicely n + showNicely (RebaseP i s) = showPatchInfoUI i $$ + prefix " " (showNicely s) + +instance PatchInspect p => PatchInspect (WrappedNamed rt p) where + listTouchedFiles (NormalP n) = listTouchedFiles n + listTouchedFiles (RebaseP _ s) = listTouchedFiles s + + hunkMatches f (NormalP n) = hunkMatches f n + hunkMatches f (RebaseP _ s) = hunkMatches f s + +instance RepairToFL p => Repair (WrappedNamed rt p) where + applyAndTryToFix (NormalP n) = fmap (mapMaybeSnd NormalP) $ applyAndTryToFix n + applyAndTryToFix (RebaseP i s) = fmap (mapMaybeSnd (RebaseP i)) $ applyAndTryToFix s + +-- This is a local hack to maintain backwards compatibility with +-- the on-disk format for rebases. Previously the rebase container +-- was internally represented via a 'Rebasing' type that sat *inside* +-- a 'Named', and so the rebase container patch had the structure +-- 'NamedP i [] (Suspendended s :>: NilFL)'. This structure was reflected +-- in the way it was saved on disk. +-- The easiest to read this structure is to use an intermediate type +-- that reflects the old structure. +-- TODO: switch to a more natural on-disk structure that directly +-- saves/reads 'RebaseP'. +data ReadRebasing p wX wY where + ReadNormal :: p wX wY -> ReadRebasing p wX wY + ReadSuspended :: Rebase.Suspended p wX wX -> ReadRebasing p wX wX + +instance ( ReadPatch p, PrimPatchBase p, FromPrim p, Effect p, PatchListFormat p + , IsRepoType rt + ) => ReadPatch (WrappedNamed rt p) where + readPatch' = + case singletonRepoType :: SRepoType rt of + SRepoType SIsRebase -> + let wrapNamed :: Named (ReadRebasing p) wX wY -> WrappedNamed rt p wX wY + wrapNamed (NamedP i [] (ReadSuspended s :>: NilFL)) + = RebaseP i s + wrapNamed (NamedP i deps ps) = NormalP (NamedP i deps (mapFL_FL unRead ps)) + + unRead (ReadNormal p) = p + unRead (ReadSuspended _) = error "unexpected suspended patch" + + in fmap (mapSeal wrapNamed) readPatch' + + _ -> fmap (mapSeal NormalP) readPatch' + +instance PatchListFormat p => PatchListFormat (ReadRebasing p) where + patchListFormat = copyListFormat (patchListFormat :: ListFormat p) + +instance (ReadPatch p, PatchListFormat p, PrimPatchBase p) => ReadPatch (ReadRebasing p) where + readPatch' = + mapSeal toSuspended <$> readPatch' + <|> mapSeal ReadNormal <$> readPatch' + where -- needed to get a suitably polymorphic type + toSuspended :: Rebase.Suspended p wX wY -> ReadRebasing p wX wY + toSuspended (Rebase.Items ps) = ReadSuspended (Rebase.Items ps) + +instance (CommuteNoConflicts p, Conflict p) => Conflict (WrappedNamed rt p) where + resolveConflicts (NormalP n) = resolveConflicts n + resolveConflicts (RebaseP _ s) = resolveConflicts s + + conflictedEffect (NormalP n) = conflictedEffect n + conflictedEffect (RebaseP _ s) = conflictedEffect s + +instance Check p => Check (WrappedNamed rt p) where + isInconsistent (NormalP n) = isInconsistent n + isInconsistent (RebaseP _ s) = isInconsistent s + +instance Apply p => Apply (WrappedNamed rt p) where + type ApplyState (WrappedNamed rt p) = ApplyState p + apply (NormalP n) = apply n + apply (RebaseP _ s) = apply s + +instance Effect p => Effect (WrappedNamed rt p) where + effect (NormalP n) = effect n + effect (RebaseP _ s) = effect s + + effectRL (NormalP n) = effectRL n + effectRL (RebaseP _ s) = effectRL s + +instance Commute p => Commute (WrappedNamed rt p) where + commute (NormalP n1 :> NormalP n2) = do + n2' :> n1' <- commute (n1 :> n2) + return (NormalP n2' :> NormalP n1') + + commute (RebaseP i1 s1 :> RebaseP i2 s2) = + -- Two rebases in sequence must have the same starting context, + -- so they should trivially commute. + -- This case shouldn't actually happen since each repo only has + -- a single Suspended patch. + return (RebaseP i2 s2 :> RebaseP i1 s1) + + commute (NormalP n1 :> RebaseP i2 s2) = + return (RebaseP i2 (Rebase.addFixupsToSuspended n1 s2) :> NormalP n1) + + commute (RebaseP i1 s1 :> NormalP n2) = + return (NormalP n2 :> RebaseP i1 (Rebase.removeFixupsFromSuspended n2 s1)) + +instance Merge p => Merge (WrappedNamed rt p) where + merge (NormalP n1 :\/: NormalP n2) = + case merge (n1 :\/: n2) of + n2' :/\: n1' -> NormalP n2' :/\: NormalP n1' + + -- shouldn't happen as each repo only has a single Suspended patch + merge (RebaseP i1 items1 :\/: RebaseP i2 items2) = + RebaseP i2 items2 :/\: RebaseP i1 items1 + + merge (NormalP n1 :\/: RebaseP i2 s2) = + RebaseP i2 (Rebase.removeFixupsFromSuspended n1 s2) :/\: NormalP n1 + + merge (RebaseP i1 s1 :\/: NormalP n2) = + NormalP n2 :/\: RebaseP i1 (Rebase.removeFixupsFromSuspended n2 s1) diff --git a/src/Darcs/Patch/OldDate.hs b/src/Darcs/Patch/OldDate.hs --- a/src/Darcs/Patch/OldDate.hs +++ b/src/Darcs/Patch/OldDate.hs @@ -22,6 +22,9 @@ module Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime ) where +import Prelude ( (^) ) +import Darcs.Prelude + import Text.ParserCombinators.Parsec import System.Time import Data.Char ( toUpper, isDigit ) diff --git a/src/Darcs/Patch/PatchInfoAnd.hs b/src/Darcs/Patch/PatchInfoAnd.hs --- a/src/Darcs/Patch/PatchInfoAnd.hs +++ b/src/Darcs/Patch/PatchInfoAnd.hs @@ -21,11 +21,14 @@ module Darcs.Patch.PatchInfoAnd ( Hopefully(..), SimpleHopefully(..), PatchInfoAnd(..), WPatchInfo, unWPatchInfo, compareWPatchInfo, piap, n2pia, patchInfoAndPatch, - fmapPIAP, fmapFLPIAP, + fmapFLPIAP, generaliseRepoTypePIAP, conscientiously, hopefully, info, winfo, hopefullyM, createHashed, extractHash, actually, unavailable, patchDesc ) where +import Prelude () +import Darcs.Prelude + import System.IO.Unsafe ( unsafeInterleaveIO ) import Darcs.Util.SignalHandler ( catchNonSignal ) @@ -33,19 +36,21 @@ ( Doc, renderString, errorDoc, text, ($$), vcat , RenderMode(..) ) import Darcs.Patch.Info ( PatchInfo, showPatchInfoUI, justName ) -import Darcs.Patch ( Named, patch2patchinfo ) import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts ) import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Merge ( Merge(..) ) -import Darcs.Patch.Named ( fmapNamed, fmapFL_Named ) -import Darcs.Patch.Prim ( PrimPatchBase(..) ) +import Darcs.Patch.Named.Wrapped + ( WrappedNamed, patch2patchinfo, fmapFL_WrappedNamed, (:~:), (:~~:) + , generaliseRepoTypeWrapped + ) +import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim ) import Darcs.Patch.Patchy ( Patchy, ReadPatch(..), Apply(..), Invert(..), ShowPatch(..), Commute(..), PatchInspect(..) ) -import Darcs.Patch.Rebase.NameHack ( NameHack ) import Darcs.Patch.Repair ( Repair(..), RepairToFL ) +import Darcs.Patch.RepoType ( RepoType(..), IsRepoType, RebaseTypeOf, RebaseType(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..) ) import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) @@ -53,9 +58,7 @@ import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, mapSeal ) import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) ) import Darcs.Util.Exception ( prettyException ) -import Storage.Hashed.Tree( Tree ) - -import Control.Applicative ( (<$>) ) +import Darcs.Util.Tree( Tree ) -- | @'Hopefully' p C@ @(x y)@ is @'Either' String (p C@ @(x y))@ in a -- form adapted to darcs patches. The @C@ @(x y)@ represents the type @@ -76,17 +79,17 @@ -- | @'PatchInfoAnd' p wA wB@ represents a hope we have to get a -- patch through its info. We're not sure we have the patch, but we -- know its info. -data PatchInfoAnd p wA wB = PIAP !PatchInfo (Hopefully (Named p) wA wB) +data PatchInfoAnd rt p wA wB = PIAP !PatchInfo (Hopefully (WrappedNamed rt p) wA wB) deriving Show -instance Show2 p => Show1 (PatchInfoAnd p wX) where +instance Show2 p => Show1 (PatchInfoAnd rt p wX) where showDict1 = ShowDictClass -instance Show2 p => Show2 (PatchInfoAnd p) where +instance Show2 p => Show2 (PatchInfoAnd rt p) where showDict2 = ShowDictClass -instance PrimPatchBase p => PrimPatchBase (PatchInfoAnd p) where - type PrimOf (PatchInfoAnd p) = PrimOf p +instance PrimPatchBase p => PrimPatchBase (PatchInfoAnd rt p) where + type PrimOf (PatchInfoAnd rt p) = PrimOf p -- | @'WPatchInfo' wA wB@ represents the info of a patch, marked with -- the patch's witnesses. @@ -109,44 +112,51 @@ where ff (Actually a) = Actually (f a) ff (Unavailable e) = Unavailable e -info :: PatchInfoAnd p wA wB -> PatchInfo +info :: PatchInfoAnd rt p wA wB -> PatchInfo info (PIAP i _) = i -patchDesc :: forall p wX wY . PatchInfoAnd p wX wY -> String +patchDesc :: forall rt p wX wY . PatchInfoAnd rt p wX wY -> String patchDesc p = justName $ info p -winfo :: PatchInfoAnd p wA wB -> WPatchInfo wA wB +winfo :: PatchInfoAnd rt p wA wB -> WPatchInfo wA wB winfo (PIAP i _) = WPatchInfo i -- | @'piap' i p@ creates a PatchInfoAnd containing p with info i. -piap :: PatchInfo -> Named p wA wB -> PatchInfoAnd p wA wB +piap :: PatchInfo -> WrappedNamed rt p wA wB -> PatchInfoAnd rt p wA wB piap i p = PIAP i (Hopefully $ Actually p) -- | @n2pia@ creates a PatchInfoAnd representing a @Named@ patch. -n2pia :: Named p wX wY -> PatchInfoAnd p wX wY +n2pia :: WrappedNamed rt p wX wY -> PatchInfoAnd rt p wX wY n2pia x = patch2patchinfo x `piap` x -patchInfoAndPatch :: PatchInfo -> Hopefully (Named p) wA wB -> PatchInfoAnd p wA wB +patchInfoAndPatch :: PatchInfo -> Hopefully (WrappedNamed rt p) wA wB -> PatchInfoAnd rt p wA wB patchInfoAndPatch = PIAP -fmapPIAP :: (forall wA wB . p wA wB -> q wA wB) -> PatchInfoAnd p wX wY -> PatchInfoAnd q wX wY -fmapPIAP f (PIAP i hp) = PIAP i (fmapH (fmapNamed f) hp) +fmapFLPIAP + :: (FL p wX wY -> FL q wX wY) + -> (RebaseTypeOf rt :~~: 'IsRebase -> p :~: q) + -> PatchInfoAnd rt p wX wY + -> PatchInfoAnd rt q wX wY +fmapFLPIAP f whenRebase (PIAP i hp) + = PIAP i (fmapH (fmapFL_WrappedNamed f whenRebase) hp) -fmapFLPIAP :: (FL p wX wY -> FL q wX wY) -> PatchInfoAnd p wX wY -> PatchInfoAnd q wX wY -fmapFLPIAP f (PIAP i hp) = PIAP i (fmapH (fmapFL_Named f) hp) +generaliseRepoTypePIAP + :: PatchInfoAnd ('RepoType 'NoRebase) p wA wB + -> PatchInfoAnd rt p wA wB +generaliseRepoTypePIAP (PIAP i hp) = PIAP i (fmapH generaliseRepoTypeWrapped hp) -- | @'hopefully' hp@ tries to get a patch from a 'PatchInfoAnd' -- value. If it fails, it outputs an error \"failed to read patch: -- \\". We get the description of the patch -- from the info part of 'hp' -hopefully :: PatchInfoAnd p wA wB -> Named p wA wB +hopefully :: PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB hopefully = conscientiously $ \e -> text "failed to read patch:" $$ e -- | @'conscientiously' er hp@ tries to extract a patch from a 'PatchInfoAnd'. -- If it fails, it applies the error handling function @er@ to a description -- of the patch info component of @hp@. conscientiously :: (Doc -> Doc) - -> PatchInfoAnd p wA wB -> Named p wA wB + -> PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB conscientiously er (PIAP pinf hp) = case hopefully2either hp of Right p -> p @@ -154,7 +164,7 @@ -- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a -- monad instead of erroring. -hopefullyM :: Monad m => PatchInfoAnd p wA wB -> m (Named p wA wB) +hopefullyM :: Monad m => PatchInfoAnd rt p wA wB -> m (WrappedNamed rt p wA wB) hopefullyM (PIAP pinf hp) = case hopefully2either hp of Right p -> return p Left e -> fail $ renderString Encode @@ -177,7 +187,7 @@ return (Sealed (Actually x)) handler e = return $ seal $ Unavailable $ prettyException e -extractHash :: PatchInfoAnd p wA wB -> Either (Named p wA wB) String +extractHash :: PatchInfoAnd rt p wA wB -> Either (WrappedNamed rt p wA wB) String extractHash (PIAP _ (Hashed s _)) = Right s extractHash hp = Left $ conscientiously (\e -> text "unable to read patch:" $$ e) hp @@ -187,21 +197,21 @@ -- Equality on PatchInfoAnd is solely determined by the PatchInfo -- It is a global invariant of darcs that once a patch is recorded, -- it should always have the same representation in the same context. -instance MyEq (PatchInfoAnd p) where +instance MyEq (PatchInfoAnd rt p) where unsafeCompare (PIAP i _) (PIAP i2 _) = i == i2 -instance Invert p => Invert (PatchInfoAnd p) where +instance Invert p => Invert (PatchInfoAnd rt p) where invert (PIAP i p) = PIAP i (invert `fmapH` p) -instance PatchListFormat (PatchInfoAnd p) +instance PatchListFormat (PatchInfoAnd rt p) -instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (PatchInfoAnd p) where +instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (PatchInfoAnd rt p) where showPatch (PIAP n p) = case hopefully2either p of Right x -> showPatch x Left _ -> showPatchInfoUI n instance (Apply p, Conflict p, CommuteNoConflicts p, IsHunk p, PatchListFormat p, PrimPatchBase p, - ShowPatch p, ApplyState p ~ Tree) => ShowPatch (PatchInfoAnd p) where + ShowPatch p, ApplyState p ~ Tree) => ShowPatch (PatchInfoAnd rt p) where showContextPatch (PIAP n p) = case hopefully2either p of Right x -> showContextPatch x Left _ -> return $ showPatchInfoUI n @@ -214,39 +224,42 @@ Right x -> showNicely x Left _ -> showPatchInfoUI n -instance (Commute p, NameHack p) => Commute (PatchInfoAnd p) where +instance Commute p => Commute (PatchInfoAnd rt p) where commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y) return $ (info y `piap` y') :> (info x `piap` x') -instance (Merge p, NameHack p) => Merge (PatchInfoAnd p) where +instance Merge p => Merge (PatchInfoAnd rt p) where merge (x :\/: y) = case merge (hopefully x :\/: hopefully y) of y' :/\: x' -> (info y `piap` y') :/\: (info x `piap` x') -instance PatchInspect p => PatchInspect (PatchInfoAnd p) where +instance PatchInspect p => PatchInspect (PatchInfoAnd rt p) where listTouchedFiles = listTouchedFiles . hopefully - hunkMatches _ _ = error "hunkmatches not implemented for PatchInfoAnd" + hunkMatches f = hunkMatches f . hopefully -instance Apply p => Apply (PatchInfoAnd p) where - type ApplyState (PatchInfoAnd p) = ApplyState p +instance Apply p => Apply (PatchInfoAnd rt p) where + type ApplyState (PatchInfoAnd rt p) = ApplyState p apply p = apply $ hopefully p -instance RepairToFL p => Repair (PatchInfoAnd p) where +instance RepairToFL p => Repair (PatchInfoAnd rt p) where applyAndTryToFix p = do mp' <- applyAndTryToFix $ hopefully p case mp' of Nothing -> return Nothing Just (e,p') -> return $ Just (e, n2pia p') -instance (ReadPatch p, PatchListFormat p) => ReadPatch (PatchInfoAnd p) where +instance ( ReadPatch p, PatchListFormat p, PrimPatchBase p, Effect p, FromPrim p + , IsRepoType rt + ) => ReadPatch (PatchInfoAnd rt p) where + readPatch' = mapSeal n2pia <$> readPatch' -instance Effect p => Effect (PatchInfoAnd p) where +instance Effect p => Effect (PatchInfoAnd rt p) where effect = effect . hopefully effectRL = effectRL . hopefully -instance IsHunk (PatchInfoAnd p) where +instance IsHunk (PatchInfoAnd rt p) where isHunk _ = Nothing -instance PatchDebug p => PatchDebug (PatchInfoAnd p) +instance PatchDebug p => PatchDebug (PatchInfoAnd rt p) -instance (Patchy p, NameHack p, ApplyState p ~ Tree) => Patchy (PatchInfoAnd p) +instance (Patchy p, ApplyState p ~ Tree) => Patchy (PatchInfoAnd rt p) diff --git a/src/Darcs/Patch/Permutations.hs b/src/Darcs/Patch/Permutations.hs --- a/src/Darcs/Patch/Permutations.hs +++ b/src/Darcs/Patch/Permutations.hs @@ -31,6 +31,9 @@ inverseCommuter ) where +import Prelude () +import Darcs.Prelude + import Data.Maybe ( mapMaybe ) import Darcs.Patch.Commute ( Commute, commute, commuteFLorComplain, commuteRL ) import Darcs.Patch.CommuteFn ( CommuteFn ) @@ -68,10 +71,10 @@ Just (p' :> right') -> case commuteRL (middle :> p') of Just (p'' :> middle') -> case partitionFL' keepleft middle' right' ps of (a :> b :> c) -> p'' :>: a :> b :> c - Nothing -> partitionFL' keepleft (p' :<: middle) right' ps + Nothing -> partitionFL' keepleft (middle :<: p') right' ps Nothing -> case commuteWhatWeCanRL (right :> p) of - (tomiddle :> p' :> right') -> partitionFL' keepleft (p' :<: tomiddle +<+ middle) right' ps - | otherwise = partitionFL' keepleft middle (p :<: right) ps + (tomiddle :> p' :> right') -> partitionFL' keepleft (middle +<+ tomiddle :<: p') right' ps + | otherwise = partitionFL' keepleft middle (right :<: p) ps -- |split an 'RL' into "left" and "right" lists according to a predicate, using commutation as necessary. @@ -93,11 +96,11 @@ partitionRL' _ NilRL qs = reverseFL qs :> NilRL -partitionRL' keepright (p :<: ps) qs +partitionRL' keepright (ps :<: p) qs | keepright p, Right (qs' :> p') <- commuteFLorComplain (p :> qs) = case partitionRL' keepright ps qs' of - a :> b -> a :> p' :<: b + a :> b -> a :> b :<: p' | otherwise = partitionRL' keepright ps (p :>: qs) commuteWhatWeCanFL :: Commute p => (p :> FL p) wX wY -> (FL p :> p :> FL p) wX wY @@ -121,13 +124,13 @@ genCommuteWhatWeCanRL :: Commute p => (forall wA wB . ((p :> q) wA wB -> Maybe ((q :> p) wA wB))) -> (RL p :> q) wX wY -> (RL p :> q :> RL p) wX wY -genCommuteWhatWeCanRL com (x :<: xs :> p) = +genCommuteWhatWeCanRL com (xs :<: x :> p) = case com (x :> p) of Nothing -> case commuteWhatWeCanRL (xs :> x) of xs1 :> x' :> xs2 -> case genCommuteWhatWeCanRL com (xs2 :> p) of - xs1' :> p' :> xs2' -> xs1' +<+ x' :<: xs1 :> p' :> xs2' + xs1' :> p' :> xs2' -> xs1 :<: x' +<+ xs1' :> p' :> xs2' Just (p' :> x') -> case genCommuteWhatWeCanRL com (xs :> p') of - a :> p'' :> c -> a :> p'' :> x' :<: c + xs1 :> p'' :> xs2 -> xs1 :> p'' :> xs2 :<: x' genCommuteWhatWeCanRL _ (NilRL :> y) = NilRL :> y :> NilRL @@ -154,7 +157,7 @@ removeRL :: (MyEq p, Commute p) => p wY wZ -> RL p wX wZ -> Maybe (RL p wX wY) removeRL x xs = r x $ headPermutationsRL xs where r :: (MyEq p, Commute p) => p wY wZ -> [RL p wX wZ] -> Maybe (RL p wX wY) - r z ((z':<:zs):zss) | IsEq <- z =/\= z' = Just zs + r z ((zs:<:z'):zss) | IsEq <- z =/\= z' = Just zs | otherwise = r z zss r _ _ = Nothing @@ -178,7 +181,7 @@ | otherwise = rsRL a b where rsRL :: (MyEq p, Commute p) => RL p wAb wAbc -> RL p wA wAbc -> Maybe (RL p wA wAb) rsRL NilRL ys = Just ys - rsRL (x:<:xs) yys = removeRL x yys >>= removeSubsequenceRL xs + rsRL (xs:<:x) yys = removeRL x yys >>= removeSubsequenceRL xs -- | This is a minor variant of 'headPermutationsFL' with each permutation -- is simply returned as a 'FL' @@ -213,10 +216,10 @@ -- patch sequence instead of to the beginning). headPermutationsRL :: Commute p => RL p wX wY -> [RL p wX wY] headPermutationsRL NilRL = [] -headPermutationsRL (p:<:ps) = - (p:<:ps) : mapMaybe (swapfirstRL.(p:<:)) (headPermutationsRL ps) - where swapfirstRL (p1:<:p2:<:xs) = do p1':>p2' <- commute (p2:>p1) - Just $ p2':<:p1':<:xs +headPermutationsRL (ps:<:p) = + (ps:<:p) : mapMaybe (swapfirstRL.(:<:p)) (headPermutationsRL ps) + where swapfirstRL (xs:<:p2:<:p1) = do p1':>p2' <- commute (p2:>p1) + Just $ xs:<:p1':<:p2' swapfirstRL _ = Nothing instance (MyEq p, Commute p) => MyEq (FL p) where @@ -233,7 +236,7 @@ a =/\= b | lengthRL a /= lengthRL b = NotEq | otherwise = cmpSameLength a b where cmpSameLength :: RL p wX wY -> RL p wW wY -> EqCheck wX wW - cmpSameLength (x:<:xs) xys | Just ys <- removeRL x xys = cmpSameLength xs ys + cmpSameLength (xs:<:x) xys | Just ys <- removeRL x xys = cmpSameLength xs ys cmpSameLength NilRL NilRL = IsEq cmpSameLength _ _ = NotEq xs =\/= ys = reverseRL xs =\/= reverseRL ys diff --git a/src/Darcs/Patch/Prim/Class.hs b/src/Darcs/Patch/Prim/Class.hs --- a/src/Darcs/Patch/Prim/Class.hs +++ b/src/Darcs/Patch/Prim/Class.hs @@ -8,6 +8,9 @@ ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.ApplyMonad ( ApplyMonad ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.FileHunk ( FileHunk, IsHunk ) @@ -23,6 +26,7 @@ import Darcs.Patch.Witnesses.Eq ( MyEq(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL, (:>), mapFL, mapFL_FL, reverseFL ) +import Darcs.Patch.Witnesses.Show ( Show2 ) import Darcs.Patch.Witnesses.Sealed ( Sealed ) import Darcs.Util.Printer ( Doc, vcat ) @@ -34,6 +38,7 @@ class (Patchy prim, MyEq prim ,PatchListFormat prim, IsHunk prim, RepairToFL prim ,PatchInspect prim, ReadPatch prim, ShowPatch prim + ,Show2 prim ,PrimConstruct prim, PrimCanonize prim ,PrimClassify prim, PrimDetails prim ,PrimShow prim, PrimRead prim, PrimApply prim @@ -146,4 +151,4 @@ readPrim :: ParserM m => FileNameFormat -> m (Sealed (prim wX)) class PrimApply prim where - applyPrimFL :: ApplyMonad m (ApplyState prim) => FL prim wX wY -> m () + applyPrimFL :: ApplyMonad (ApplyState prim) m => FL prim wX wY -> m () diff --git a/src/Darcs/Patch/Prim/FileUUID.hs b/src/Darcs/Patch/Prim/FileUUID.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Prim/FileUUID.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Darcs.Patch.Prim.FileUUID ( Prim ) where + +import Prelude () +import Darcs.Prelude + +import Darcs.Patch.Prim.FileUUID.Apply () +import Darcs.Patch.Prim.FileUUID.Coalesce () +import Darcs.Patch.Prim.FileUUID.Commute () +import Darcs.Patch.Prim.FileUUID.Core ( Prim ) +import Darcs.Patch.Prim.FileUUID.Details () +import Darcs.Patch.Prim.FileUUID.Read () +import Darcs.Patch.Prim.FileUUID.Show () + +import Darcs.Patch.Prim.Class ( PrimPatch, PrimPatchBase(..), FromPrim(..) ) +import Darcs.Patch.Patchy ( Patchy ) + +instance PrimPatch Prim +instance Patchy Prim + +instance PrimPatchBase Prim where + type PrimOf Prim = Prim + +instance FromPrim Prim where + fromPrim = id diff --git a/src/Darcs/Patch/Prim/FileUUID/Apply.hs b/src/Darcs/Patch/Prim/FileUUID/Apply.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Prim/FileUUID/Apply.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-methods #-} +module Darcs.Patch.Prim.FileUUID.Apply ( ObjectMap(..) ) where + +import Prelude () +import Darcs.Prelude + +import Darcs.Patch.Apply ( Apply(..) ) +import Darcs.Patch.ApplyMonad + ( ApplyMonad(..), ApplyMonadTrans(..), ToTree(..), ApplyMonadState(..) + ) +import Darcs.Patch.Repair ( RepairToFL(..) ) + +import Darcs.Patch.Prim.Class ( PrimApply(..) ) +import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), hunkEdit ) +import Darcs.Patch.Prim.FileUUID.ObjectMap + +import Control.Monad.State( StateT, runStateT, gets, lift, put ) +import qualified Data.Map as M + +-- import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) + +import Darcs.Patch.Witnesses.Ordered ( FL(..) ) +import Darcs.Util.Hash( Hash(..) ) + +import qualified Data.ByteString as B + +#include "impossible.h" + +instance Apply Prim where + type ApplyState Prim = ObjectMap + apply (Manifest i (dirid, name)) = editDirectory dirid (M.insert name i) + apply (Demanifest _ (dirid, name)) = editDirectory dirid (M.delete name) + apply (TextHunk i hunk) = editFile i (hunkEdit hunk) + apply (BinaryHunk i hunk) = editFile i (hunkEdit hunk) + apply Identity = return () + apply (Move{}) = bug "apply for move not implemented" + +instance RepairToFL Prim where + applyAndTryToFixFL p = apply p >> return Nothing + +instance PrimApply Prim where + applyPrimFL NilFL = return () + applyPrimFL (p:>:ps) = apply p >> applyPrimFL ps + +instance ToTree ObjectMap -- TODO + +editObject :: (Monad m) => UUID -> (Maybe (Object m) -> Object m) -> (StateT (ObjectMap m) m) () +editObject i edit = do load <- gets getObject + store <- gets putObject + obj <- lift $ load i + new <- lift $ store i $ edit obj + put new + return () + + +class ApplyMonadObjectMap m where + -- a semantic, ObjectMap-based interface for patch application + editFile :: UUID -> (B.ByteString -> B.ByteString) -> m () + editDirectory :: UUID -> (DirContent -> DirContent) -> m () + +instance ApplyMonadState ObjectMap where + type ApplyMonadStateOperations ObjectMap = ApplyMonadObjectMap + +instance (Functor m, Monad m) => ApplyMonad ObjectMap (StateT (ObjectMap m) m) where + type ApplyMonadBase (StateT (ObjectMap m) m) = m + +instance (Functor m, Monad m) => ApplyMonadObjectMap (StateT (ObjectMap m) m) where + editFile i edit = editObject i edit' + where edit' (Just (Blob x _)) = Blob (edit `fmap` x) NoHash + edit' (Just (Directory x)) = Directory x -- error? + edit' Nothing = Blob (return $ edit "") NoHash + editDirectory i edit = editObject i edit' + where edit' (Just (Directory x)) = Directory $ edit x + edit' (Just (Blob x y)) = Blob x y -- error? + edit' Nothing = Directory $ edit M.empty + +instance (Functor m, Monad m) => ApplyMonadTrans ObjectMap m where + type ApplyMonadOver ObjectMap m = StateT (ObjectMap m) m + runApplyMonad = runStateT + diff --git a/src/Darcs/Patch/Prim/FileUUID/Coalesce.hs b/src/Darcs/Patch/Prim/FileUUID/Coalesce.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Prim/FileUUID/Coalesce.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Darcs.Patch.Prim.FileUUID.Coalesce () where + +import Prelude () +import Darcs.Prelude + +import Darcs.Patch.Prim.Class ( PrimCanonize(..) ) +import Darcs.Patch.Witnesses.Ordered( FL(..) ) +import Darcs.Patch.Prim.FileUUID.Core( Prim ) + +-- TODO +instance PrimCanonize Prim where + tryToShrink = error "tryToShrink" + tryShrinkingInverse _ = error "tryShrinkingInverse" + sortCoalesceFL = id + canonize _ = (:>: NilFL) + canonizeFL _ = id + coalesce = const Nothing diff --git a/src/Darcs/Patch/Prim/FileUUID/Commute.hs b/src/Darcs/Patch/Prim/FileUUID/Commute.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Prim/FileUUID/Commute.hs @@ -0,0 +1,73 @@ +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-overlapping-patterns #-} +{-# LANGUAGE CPP #-} +module Darcs.Patch.Prim.FileUUID.Commute + ( CommuteMonad(..) ) + where + +import Prelude () +import Darcs.Prelude + +import Data.List ( intersect ) + +import qualified Data.ByteString as BS (length) + +import Darcs.Patch.Witnesses.Ordered ( (:>)(..) ) +import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) +import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Hunk(..), touches ) +import Darcs.Patch.Commute ( Commute(..) ) +import Darcs.Patch.Permutations () -- for Invert instance of FL + +#include "impossible.h" + +class Monad m => CommuteMonad m where + commuteFail :: m a + -- TODO we eventually have to get rid of runCommute with this signature, + -- since m might involve IO at some point, which we can't "run"; + -- alternatively, for IO it could always yield Nothing, having a separate + -- IO-specific function to "run" commutes in IO + +instance CommuteMonad Maybe where + commuteFail = Nothing + +instance Commute Prim where + commute = commute' + +class Commute' p where + commute' :: (CommuteMonad m) => (p :> p) wX wY -> m ((p :> p) wX wY) + +typematch :: Prim wX wY -> Prim wY wZ -> Bool +typematch _ _ = True -- TODO + +instance Commute' Prim where + commute' (a :> b) | null (touches a `intersect` touches b) = return (unsafeCoerceP b :> unsafeCoerceP a) + | not (a `typematch` b) = commuteFail + | otherwise = commuteOverlapping (a :> b) + +-- Commute patches that have actual overlap in terms of touched objects, and their types allow +commuteOverlapping :: (CommuteMonad m) => (Prim :> Prim) wX wY -> m ((Prim :> Prim) wX wY) +commuteOverlapping (BinaryHunk a x :> BinaryHunk _ y) = + do (y' :> x') <- commuteHunk (x :> y) + return $ unsafeCoerceP (BinaryHunk a y' :> BinaryHunk a x') +commuteOverlapping (TextHunk a x :> TextHunk _ y) = + do (y' :> x') <- commuteHunk (x :> y) + return $ unsafeCoerceP (TextHunk a y' :> TextHunk a x') +commuteOverlapping _ = commuteFail + +commuteHunk :: (CommuteMonad m) => (Hunk :> Hunk) wX wY -> m ((Hunk :> Hunk) wY wX) +commuteHunk (Hunk off1 old1 new1 :> Hunk off2 old2 new2) + | off1 + lengthnew1 < off2 = + return $ Hunk (off2 - lengthnew1 + lengthold1) old2 new2 :> Hunk off1 old1 new1 + | off2 + lengthold2 < off1 = + return $ Hunk off2 old2 new2 :> Hunk (off1 + lengthnew2 - lengthold2) old1 new1 + | off1 + lengthnew1 == off2 && + lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = + return $ Hunk (off2 - lengthnew1 + lengthold1) old2 new2 :> Hunk off1 old1 new1 + | off2 + lengthold2 == off1 && + lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = + return $ Hunk off2 old2 new2 :> Hunk (off1 + lengthnew2 - lengthold2) old1 new1 + | otherwise = commuteFail + where lengthnew1 = BS.length new1 + lengthnew2 = BS.length new2 + lengthold1 = BS.length old1 + lengthold2 = BS.length old2 +commuteHunk _ = impossible diff --git a/src/Darcs/Patch/Prim/FileUUID/Core.hs b/src/Darcs/Patch/Prim/FileUUID/Core.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Prim/FileUUID/Core.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP, OverloadedStrings, StandaloneDeriving #-} + +-- Copyright (C) 2011 Petr Rockai +-- +-- Permission is hereby granted, free of charge, to any person +-- obtaining a copy of this software and associated documentation +-- files (the "Software"), to deal in the Software without +-- restriction, including without limitation the rights to use, copy, +-- modify, merge, publish, distribute, sublicense, and/or sell copies +-- of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be +-- included in all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +-- SOFTWARE. + + +module Darcs.Patch.Prim.FileUUID.Core + ( Prim(..), Hunk(..), UUID(..), Location, Object(..), touches, hunkEdit ) + where + +import Prelude () +import Darcs.Prelude + +import qualified Data.ByteString as BS + +import Darcs.Patch.Witnesses.Eq ( MyEq(..) ) +import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) ) +import Darcs.Patch.FileHunk( IsHunk(..) ) +import Darcs.Patch.Invert ( Invert(..) ) +import Darcs.Patch.Inspect ( PatchInspect(..) ) +import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimClassify(..) ) +import Darcs.Patch.Prim.FileUUID.ObjectMap + +-- TODO: elaborate + +data Hunk wX wY where + Hunk :: !Int -> BS.ByteString -> BS.ByteString -> Hunk wX wY + deriving Show + +instance Show1 (Hunk wX) where + showDict1 = ShowDictClass + +instance Show2 Hunk where + showDict2 = ShowDictClass + +invertHunk :: Hunk wX wY -> Hunk wY wX +invertHunk (Hunk off old new) = Hunk off new old + +hunkEdit :: Hunk wX wY -> BS.ByteString -> BS.ByteString +hunkEdit (Hunk off old new) bs = case splice bs (off) (off + BS.length old) of + x | x == old -> BS.concat [ BS.take off bs, new, BS.drop (off + BS.length old) bs ] + | otherwise -> error $ "error applying hunk: " ++ show off ++ " " ++ show old ++ " " + ++ show new ++ " to " ++ show bs + where splice bs' x y = BS.drop x $ BS.take y bs' + +instance MyEq Hunk where + unsafeCompare (Hunk i x y) (Hunk i' x' y') = i == i' && x == x' && y == y' + +data Prim wX wY where + BinaryHunk :: !UUID -> Hunk wX wY -> Prim wX wY + TextHunk :: !UUID -> Hunk wX wY -> Prim wX wY + + -- TODO: String is not the right type here. However, what it represents is + -- a single file *name* (not a path). No slashes allowed, no "." and ".." + -- allowed either. + Manifest :: !UUID -> Location -> Prim wX wY + Demanifest :: !UUID -> Location -> Prim wX wY + Move :: !UUID -> Location -> Location -> Prim wX wY + Identity :: Prim wX wX + +deriving instance Show (Prim wX wY) + +instance Show1 (Prim wX) where + showDict1 = ShowDictClass + +instance Show2 Prim where + showDict2 = ShowDictClass + +touches :: Prim wX wY -> [UUID] +touches (BinaryHunk x _) = [x] +touches (TextHunk x _) = [x] +touches (Manifest _ (x, _)) = [x] +touches (Demanifest _ (x, _)) = [x] +touches (Move _ (x, _) (y, _)) = [x, y] +touches Identity = [] + +-- TODO: PrimClassify doesn't make sense for FileUUID prims +instance PrimClassify Prim where + primIsAddfile _ = False + primIsRmfile _ = False + primIsAdddir _ = False + primIsRmdir _ = False + primIsHunk _ = False + primIsMove _ = False + primIsBinary _ = False + primIsTokReplace _ = False + primIsSetpref _ = False + is_filepatch _ = Nothing + +-- TODO: PrimConstruct makes no sense for FileUUID prims +instance PrimConstruct Prim where + addfile _ = error "PrimConstruct addfile" + rmfile _ = error "PrimConstruct rmfile" + adddir _ = error "PrimConstruct adddir" + rmdir _ = error "PrimConstruct rmdir" + move _ _ = error "PrimConstruct move" + changepref _ _ _ = error "PrimConstruct changepref" + hunk _ _ _ _ = error "PrimConstruct hunk" + tokreplace _ _ _ _ = error "PrimConstruct tokreplace" + binary _ _ _ = error "PrimConstruct binary" + primFromHunk _ = error "PrimConstruct primFromHunk" + anIdentity = Identity + +instance IsHunk Prim where + isHunk _ = Nothing + +instance Invert Prim where + invert (BinaryHunk x h) = BinaryHunk x $ invertHunk h + invert (TextHunk x h) = TextHunk x $ invertHunk h + invert (Manifest x y) = Demanifest x y + invert (Demanifest x y) = Manifest x y + invert (Move x y z) = Move x z y + invert Identity = Identity + +instance PatchInspect Prim where + -- We don't need this for FileUUID. Slashes are not allowed in Manifest and + -- Demanifest patches and nothing else uses working-copy paths. + listTouchedFiles _ = [] + + -- TODO (used for --match 'hunk ...', presumably) + hunkMatches _ _ = False + +instance MyEq Prim where + unsafeCompare (BinaryHunk a b) (BinaryHunk c d) = a == c && b `unsafeCompare` d + unsafeCompare (TextHunk a b) (TextHunk c d) = a == c && b `unsafeCompare` d + unsafeCompare (Manifest a b) (Manifest c d) = a == c && b == d + unsafeCompare (Demanifest a b) (Demanifest c d) = a == c && b == d + unsafeCompare Identity Identity = True + unsafeCompare _ _ = False + +instance Eq (Prim wX wY) where + (==) = unsafeCompare diff --git a/src/Darcs/Patch/Prim/FileUUID/Details.hs b/src/Darcs/Patch/Prim/FileUUID/Details.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Prim/FileUUID/Details.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Darcs.Patch.Prim.FileUUID.Details + () + where + +import Darcs.Patch.Prim.Class ( PrimDetails(..) ) +import Darcs.Patch.Prim.FileUUID.Core ( Prim(..) ) + + +-- TODO +instance PrimDetails Prim where + summarizePrim _ = [] diff --git a/src/Darcs/Patch/Prim/FileUUID/ObjectMap.hs b/src/Darcs/Patch/Prim/FileUUID/ObjectMap.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Prim/FileUUID/ObjectMap.hs @@ -0,0 +1,43 @@ +-- Copyright (C) 2011 Petr Rockai +-- +-- Permission is hereby granted, free of charge, to any person +-- obtaining a copy of this software and associated documentation +-- files (the "Software"), to deal in the Software without +-- restriction, including without limitation the rights to use, copy, +-- modify, merge, publish, distribute, sublicense, and/or sell copies +-- of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be +-- included in all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +-- SOFTWARE. + +module Darcs.Patch.Prim.FileUUID.ObjectMap( UUID(..), Location, Object(..), + ObjectMap(..), DirContent ) where + +import Prelude () +import Darcs.Prelude + +import Darcs.Util.Hash( Hash ) +import qualified Data.ByteString as BS (ByteString) +import qualified Data.Map as M + + +newtype UUID = UUID BS.ByteString deriving (Eq, Ord, Show) +type Location = (UUID, BS.ByteString) +type DirContent = M.Map BS.ByteString UUID +data Object (m :: * -> *) = Directory DirContent + | Blob (m BS.ByteString) !Hash + +data ObjectMap (m :: * -> *) = ObjectMap { getObject :: UUID -> m (Maybe (Object m)) + , putObject :: UUID -> Object m -> m (ObjectMap m) + , listObjects :: m [UUID] + } diff --git a/src/Darcs/Patch/Prim/FileUUID/Read.hs b/src/Darcs/Patch/Prim/FileUUID/Read.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Prim/FileUUID/Read.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP, ViewPatterns, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Darcs.Patch.Prim.FileUUID.Read () where + +import Prelude () +import Darcs.Prelude + +import Darcs.Patch.Read ( ReadPatch(..) ) +import Darcs.Patch.ReadMonads +import Darcs.Patch.Prim.Class( PrimRead(..) ) +import Darcs.Patch.Prim.FileUUID.Core( Prim(..), Hunk(..) ) +import Darcs.Patch.Prim.FileUUID.ObjectMap +import Darcs.Patch.Witnesses.Sealed( seal ) + +import Control.Monad ( liftM, liftM2 ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Data.Char ( chr ) + +#include "impossible.h" + +instance PrimRead Prim where + readPrim _ = do skipSpace + choice $ map (liftM seal) [ + identity, + hunk "hunk" TextHunk, + hunk "binhunk" BinaryHunk, + manifest "manifest" Manifest, + manifest "demanifest" Demanifest ] + + where manifest kind ctor = liftM2 ctor (patch kind) location + identity = lexString "identity" >> return Identity + patch x = string x >> uuid + uuid = UUID <$> myLex' + filename = encoded + encoded = decodeWhite <$> myLex' + hunktext = skipSpace >> choice [ string "." >> encoded, string "!" >> return B.empty ] + location = liftM2 (,) uuid filename + hunk kind ctor = do uid <- patch kind + offset <- int + old <- hunktext + new <- hunktext + return $ ctor uid (Hunk offset old new) + +instance ReadPatch Prim where + readPatch' = readPrim undefined + +-- XXX a bytestring version of decodeWhite from Darcs.FileName +decodeWhite :: B.ByteString -> B.ByteString +decodeWhite (BC.uncons -> Just ('\\', cs)) = + case BC.break (=='\\') cs of + (theord, BC.uncons -> Just ('\\', rest)) -> + chr (read $ BC.unpack theord) `BC.cons` decodeWhite rest + _ -> error "malformed filename" +decodeWhite (BC.uncons -> Just (c, cs)) = c `BC.cons` decodeWhite cs +decodeWhite (BC.uncons -> Nothing) = BC.empty +decodeWhite _ = impossible + diff --git a/src/Darcs/Patch/Prim/FileUUID/Show.hs b/src/Darcs/Patch/Prim/FileUUID/Show.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Prim/FileUUID/Show.hs @@ -0,0 +1,70 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP, OverloadedStrings #-} +module Darcs.Patch.Prim.FileUUID.Show + ( showHunk ) + where + +import Prelude () +import Darcs.Prelude + +import Prelude hiding ( pi ) + +import Data.Char ( isSpace, ord ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC + +import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) ) +import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..) ) +import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims ) +import Darcs.Patch.Prim.Class ( PrimShow(..) ) +import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Hunk(..), UUID(..) ) +import Darcs.Patch.Prim.FileUUID.Details () +import Darcs.Util.Printer ( text, packedString, blueText, (<+>), (<>), Doc ) + +#include "impossible.h" + +-- TODO this instance shouldn't really be necessary, as Prims aren't used generically +instance PatchListFormat Prim + +instance ShowPatchBasic Prim where + showPatch = showPrim OldFormat + +instance ShowPatch Prim where + showContextPatch p = return $ showPatch p + summary = plainSummaryPrim + summaryFL = plainSummaryPrims False [] + thing _ = "change" + +instance PrimShow Prim where + showPrim _ (TextHunk u h) = showHunk "hunk" u h + showPrim _ (BinaryHunk u h) = showHunk "binhunk" u h + showPrim _ (Manifest f (d,p)) = showManifest "manifest" d f p + showPrim _ (Demanifest f (d,p)) = showManifest "demanifest" d f p + showPrim _ Identity = blueText "identity" + showPrim _ (Move{}) = bug "show for move not implemented" + +showManifest :: String -> UUID -> UUID -> BC.ByteString -> Doc +showManifest txt dir file path = blueText txt <+> + formatUUID file <+> + formatUUID dir <+> + packedString (encodeWhite path) + +showHunk :: String -> UUID -> Hunk wX wY -> Doc +showHunk txt uid (Hunk off old new) = blueText txt <+> + formatUUID uid <+> + text (show off) <+> + hunktext old <+> + hunktext new + where hunktext bit | B.null bit = text "!" + | otherwise = text "." <> packedString (encodeWhite bit) + +formatUUID :: UUID -> Doc +formatUUID (UUID x) = packedString x + +-- XXX a bytestring version of encodeWhite from Darcs.FileName +encodeWhite :: B.ByteString -> B.ByteString +encodeWhite = BC.concatMap encode + where encode c + | isSpace c || c == '\\' = B.concat [ "\\", BC.pack $ show $ ord c, "\\" ] + | otherwise = BC.singleton c + diff --git a/src/Darcs/Patch/Prim/V1.hs b/src/Darcs/Patch/Prim/V1.hs --- a/src/Darcs/Patch/Prim/V1.hs +++ b/src/Darcs/Patch/Prim/V1.hs @@ -1,6 +1,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V1 ( Prim ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Prim.V1.Apply () import Darcs.Patch.Prim.V1.Coalesce () import Darcs.Patch.Prim.V1.Commute () diff --git a/src/Darcs/Patch/Prim/V1/Apply.hs b/src/Darcs/Patch/Prim/V1/Apply.hs --- a/src/Darcs/Patch/Prim/V1/Apply.hs +++ b/src/Darcs/Patch/Prim/V1/Apply.hs @@ -1,7 +1,10 @@ -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} module Darcs.Patch.Prim.V1.Apply () where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Repair ( RepairToFL(..) ) @@ -15,8 +18,8 @@ import Darcs.Patch.Format ( FileNameFormat(..) ) import Darcs.Patch.TokenReplace ( tryTokInternal ) -import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) ) +import Darcs.Util.Tree( Tree ) import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, spanFL, (:>)(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePStart ) @@ -95,7 +98,7 @@ applyPrimFL ps' where f_hunk (FP f' (Hunk{})) | f == f' = True f_hunk _ = False - hunkmod :: ApplyMonad m Tree => FL FilePatchType wX wY + hunkmod :: ApplyMonad Tree m => FL FilePatchType wX wY -> B.ByteString -> m B.ByteString hunkmod NilFL ps = return ps hunkmod (Hunk line old new:>:hs) ps diff --git a/src/Darcs/Patch/Prim/V1/Coalesce.hs b/src/Darcs/Patch/Prim/V1/Coalesce.hs --- a/src/Darcs/Patch/Prim/V1/Coalesce.hs +++ b/src/Darcs/Patch/Prim/V1/Coalesce.hs @@ -4,6 +4,9 @@ () where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( pi ) import Control.Arrow ( second ) import Data.Maybe ( fromMaybe ) @@ -22,7 +25,7 @@ import Darcs.Patch.Prim.V1.Show () import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered - ( FL(..), RL(..), (:>)(..), (:<)(..) + ( FL(..), RL(..), (:>)(..) , reverseRL, mapFL, mapFL_FL , concatFL, lengthFL, (+>+) ) import Darcs.Patch.Witnesses.Sealed @@ -32,7 +35,6 @@ import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Commute ( Commute(..) ) --- import Darcs.Patch.Permutations () -- for Invert instance of FL import Darcs.Util.Diff ( getChanges ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) @@ -41,23 +43,23 @@ #include "impossible.h" --- | 'coalesceRev' @p2 :< p1@ tries to combine @p1@ and @p2@ into a single +-- | 'coalesceFwd' @p1 :> p2@ tries to combine @p1@ and @p2@ into a single -- patch without intermediary changes. For example, two hunk patches -- modifying adjacent lines can be coalesced into a bigger hunk patch. -- Or a patch which moves file A to file B can be coalesced with a -- patch that moves file B into file C, yielding a patch that moves -- file A to file C. -coalesceRev :: (Prim :< Prim) wX wY -> Maybe (FL Prim wX wY) -coalesceRev (FP f1 _ :< FP f2 _) | f1 /= f2 = Nothing -coalesceRev (p2 :< p1) | IsEq <- p2 =\/= invert p1 = Just NilFL -coalesceRev (FP f1 p1 :< FP _ p2) = fmap (:>: NilFL) $ coalesceFilePrim f1 (p1 :< p2) -- f1 = f2 -coalesceRev (Move a b :< Move b' a') | a == a' = Just $ Move b' b :>: NilFL -coalesceRev (Move a b :< FP f AddFile) | f == a = Just $ FP b AddFile :>: NilFL -coalesceRev (Move a b :< DP f AddDir) | f == a = Just $ DP b AddDir :>: NilFL -coalesceRev (FP f RmFile :< Move a b) | b == f = Just $ FP a RmFile :>: NilFL -coalesceRev (DP f RmDir :< Move a b) | b == f = Just $ DP a RmDir :>: NilFL -coalesceRev (ChangePref p f1 t1 :< ChangePref p2 f2 t2) | p == p2 && t2 == f1 = Just $ ChangePref p f2 t1 :>: NilFL -coalesceRev _ = Nothing +coalesceFwd :: (Prim :> Prim) wX wY -> Maybe (FL Prim wX wY) +coalesceFwd (FP f1 _ :> FP f2 _) | f1 /= f2 = Nothing +coalesceFwd (p1 :> p2) | IsEq <- invert p1 =\/= p2 = Just NilFL +coalesceFwd (FP f1 p1 :> FP _ p2) = fmap (:>: NilFL) $ coalesceFilePrim f1 (p1 :> p2) -- f1 = f2 +coalesceFwd (Move a b :> Move b' a') | b == b' = Just $ Move a a' :>: NilFL +coalesceFwd (FP f AddFile :> Move a b) | f == a = Just $ FP b AddFile :>: NilFL +coalesceFwd (DP f AddDir :> Move a b) | f == a = Just $ DP b AddDir :>: NilFL +coalesceFwd (Move a b :> FP f RmFile) | b == f = Just $ FP a RmFile :>: NilFL +coalesceFwd (Move a b :> DP f RmDir) | b == f = Just $ DP a RmDir :>: NilFL +coalesceFwd (ChangePref p1 f1 t1 :> ChangePref p2 f2 t2) | p1 == p2 && t1 == f2 = Just $ ChangePref p1 f1 t2 :>: NilFL +coalesceFwd _ = Nothing mapPrimFL :: (forall wX wY . FL Prim wX wY -> FL Prim wX wY) -> FL Prim wW wZ -> FL Prim wW wZ @@ -124,11 +126,11 @@ -> Maybe (FL Prim wW wZ) tryOne _ _ NilFL = Nothing tryOne sofar p (p1:>:ps) = - case coalesceRev (p1 :< p) of + case coalesceFwd (p :> p1) of Just p' -> Just (reverseRL sofar +>+ p' +>+ ps) Nothing -> case commute (p :> p1) of Nothing -> Nothing - Just (p1' :> p') -> tryOne (p1':<:sofar) p' ps + Just (p1' :> p') -> tryOne (sofar:<:p1') p' ps -- | The heart of "sortCoalesceFL" sortCoalesceFL2 :: FL Prim wX wY -> FL Prim wX wY @@ -158,7 +160,7 @@ -> Either (FL Prim wX wZ) (FL Prim wX wZ) pushCoalescePatch new NilFL = Left (new:>:NilFL) pushCoalescePatch new ps@(p:>:ps') - = case coalesceRev (p :< new) of + = case coalesceFwd (new :> p) of Just (new' :>: NilFL) -> Right $ either id id $ pushCoalescePatch new' ps' Just NilFL -> Right ps' Just _ -> impossible -- coalesce either returns a singleton or empty @@ -171,17 +173,17 @@ Left r -> Left (p' :>: r) Nothing -> Left (new:>:ps) -coalesceFilePrim :: FileName -> (FilePatchType :< FilePatchType) wX wY +coalesceFilePrim :: FileName -> (FilePatchType :> FilePatchType) wX wY -> Maybe (Prim wX wY) -coalesceFilePrim f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) - = coalesceHunk f line1 old1 new1 line2 old2 new2 +coalesceFilePrim f (Hunk line1 old1 new1 :> Hunk line2 old2 new2) + = coalesceHunk f line2 old2 new2 line1 old1 new1 -- Token replace patches operating right after (or before) AddFile (RmFile) -- is an identity patch, as far as coalescing is concerned. -coalesceFilePrim f (TokReplace{} :< AddFile) = Just $ FP f AddFile -coalesceFilePrim f (RmFile :< TokReplace{}) = Just $ FP f RmFile -coalesceFilePrim f (TokReplace t1 o1 n1 :< TokReplace t2 o2 n2) - | t1 == t2 && n2 == o1 = Just $ FP f $ TokReplace t1 o2 n1 -coalesceFilePrim f (Binary m n :< Binary o m') +coalesceFilePrim f (AddFile :> TokReplace{}) = Just $ FP f AddFile +coalesceFilePrim f (TokReplace{} :> RmFile) = Just $ FP f RmFile +coalesceFilePrim f (TokReplace t1 o1 n1 :> TokReplace t2 o2 n2) + | t1 == t2 && n1 == o2 = Just $ FP f $ TokReplace t1 o1 n2 +coalesceFilePrim f (Binary o m' :> Binary m n) | m == m' = Just $ FP f $ Binary o n coalesceFilePrim _ _ = Nothing @@ -244,4 +246,4 @@ -- would be nice to understand why. canonizeFL da = concatFL . mapFL_FL (canonize da) . sortCoalesceFL . concatFL . mapFL_FL (canonize da) - coalesce (x :> y) = coalesceRev (y :< x) + coalesce = coalesceFwd diff --git a/src/Darcs/Patch/Prim/V1/Commute.hs b/src/Darcs/Patch/Prim/V1/Commute.hs --- a/src/Darcs/Patch/Prim/V1/Commute.hs +++ b/src/Darcs/Patch/Prim/V1/Commute.hs @@ -6,20 +6,23 @@ ) where -import Prelude hiding ( pi ) +import Prelude () +import Darcs.Prelude + +import Prelude hiding ( pi, Applicative(..) ) import Control.Monad ( MonadPlus, msum, mzero, mplus ) -import Control.Applicative ( Applicative(..), Alternative(..) ) +import Control.Applicative ( Alternative(..) ) import qualified Data.ByteString as B (ByteString, concat) import qualified Data.ByteString.Char8 as BC (pack) import Darcs.Util.Path ( FileName, fn2fp, movedirfilename ) -import Darcs.Patch.Witnesses.Ordered ( (:<)(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) +import Darcs.Patch.Witnesses.Ordered ( (:>)(..) ) import Darcs.Patch.Prim.V1.Core ( Prim(..), FilePatchType(..) ) import Darcs.Patch.Invert ( Invert(..) ) -import Darcs.Patch.Commute ( Commute(..), toFwdCommute, toRevCommute ) +import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Permutations () -- for Invert instance of FL import Darcs.Patch.TokenReplace ( tryTokInternal ) @@ -75,12 +78,12 @@ toPerhaps Nothing = Failed cleverCommute :: CommuteFunction -> CommuteFunction -cleverCommute c (p1:p2) = + case c (p1 :> p2) of Succeeded x -> Succeeded x Failed -> Failed - Unknown -> case c (invert p2 :< invert p1) of - Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1') + Unknown -> case c (invert p2 :> invert p1) of + Succeeded (p1' :> p2') -> Succeeded (invert p2' :> invert p1') Failed -> Failed Unknown -> Unknown --cleverCommute c (p1,p2) = c (p1,p2) `mplus` @@ -91,17 +94,17 @@ speedyCommute :: CommuteFunction -- Deal with common cases quickly! -- Two file-patches modifying different files trivially commute. -speedyCommute (p2@(FP f' _) :< p1@(FP f _)) - | f /= f' = Succeeded (unsafeCoerceP p1 :< unsafeCoerceP p2) +speedyCommute (p1@(FP f1 _) :> p2@(FP f2 _)) + | f1 /= f2 = Succeeded (unsafeCoerceP p2 :> unsafeCoerceP p1) speedyCommute _other = Unknown everythingElseCommute :: CommuteFunction everythingElseCommute = eec - where + where eec :: CommuteFunction - eec (ChangePref p f t : ChangePref p f t) = Succeeded (ChangePref p f t :> unsafeCoerceP p1) + eec (ChangePref p f t :> p2) = Succeeded (unsafeCoerceP p2 :> ChangePref p f t) + eec xx = cleverCommute commuteFiledir xx {- Note that it must be true that @@ -115,8 +118,8 @@ -} instance Commute Prim where - commute x = toMaybe $ msum [toFwdCommute speedyCommute x, - toFwdCommute everythingElseCommute x + commute x = toMaybe $ msum [speedyCommute x, + everythingElseCommute x ] isSuperdir :: FileName -> FileName -> Bool @@ -125,40 +128,40 @@ length s2 >= length s1 + 1 && take (length s1 + 1) s2 == s1 ++ "/" commuteFiledir :: CommuteFunction -commuteFiledir (FP f1 p1 :< FP f2 p2) = - if f1 /= f2 then Succeeded ( FP f2 (unsafeCoerceP p2) :< FP f1 (unsafeCoerceP p1) ) - else commuteFP f1 (p1 :< p2) -commuteFiledir (DP d1 p1 :< DP d2 p2) = +commuteFiledir (FP f1 p1 :> FP f2 p2) = + if f1 /= f2 then Succeeded ( FP f2 (unsafeCoerceP p2) :> FP f1 (unsafeCoerceP p1) ) + else commuteFP f1 (p1 :> p2) +commuteFiledir (DP d1 p1 :> DP d2 p2) = if not (isInDirectory d1 d2 || isInDirectory d2 d1) && d1 /= d2 - then Succeeded ( DP d2 (unsafeCoerceP p2) :< DP d1 (unsafeCoerceP p1) ) + then Succeeded ( DP d2 (unsafeCoerceP p2) :> DP d1 (unsafeCoerceP p1) ) else Failed -commuteFiledir (DP d dp :< FP f fp) = +commuteFiledir (FP f fp :> DP d dp) = if not $ isInDirectory d f - then Succeeded (FP f (unsafeCoerceP fp) :< DP d (unsafeCoerceP dp)) + then Succeeded (DP d (unsafeCoerceP dp) :> FP f (unsafeCoerceP fp)) else Failed -commuteFiledir (Move d d' :< FP f2 p2) - | f2 == d' = Failed - | (p2 == AddFile || p2 == RmFile) && d == f2 = Failed - | otherwise = Succeeded (FP (movedirfilename d d' f2) (unsafeCoerceP p2) :< Move d d') -commuteFiledir (Move d d' :< DP d2 p2) - | isSuperdir d2 d' || isSuperdir d2 d = Failed - | d == d2 = Failed -- The exact guard is p2 == AddDir && d == d2 - -- but note d == d2 suffices because we know p2 != RmDir - -- (and hence p2 == AddDir) since patches must be sequential. - | d2 == d' = Failed - | otherwise = Succeeded (DP (movedirfilename d d' d2) (unsafeCoerceP p2) :< Move d d') -commuteFiledir (Move d d' :< Move f f') +commuteFiledir (FP f1 p1 :> Move d d') + | f1 == d' = Failed + | (p1 == AddFile || p1 == RmFile) && d == f1 = Failed + | otherwise = Succeeded (Move d d' :> FP (movedirfilename d d' f1) (unsafeCoerceP p1)) +commuteFiledir (DP d1 p1 :> Move d d') + | isSuperdir d1 d' || isSuperdir d1 d = Failed + | d == d1 = Failed -- The exact guard is p1 == AddDir && d == d1 + -- but note d == d1 suffices because we know p1 != RmDir + -- (and hence p1 == AddDir) since patches must be sequential. + | d1 == d' = Failed + | otherwise = Succeeded (Move d d' :> DP (movedirfilename d d' d1) (unsafeCoerceP p1)) +commuteFiledir (Move f f' :> Move d d') | f == d' || f' == d = Failed | f == d || f' == d' = Failed | d `isSuperdir` f && f' `isSuperdir` d' = Failed | otherwise = - Succeeded (Move (movedirfilename d d' f) (movedirfilename d d' f') :< - Move (movedirfilename f' f d) (movedirfilename f' f d')) + Succeeded (Move (movedirfilename f' f d) (movedirfilename f' f d') :> + Move (movedirfilename d d' f) (movedirfilename d d' f')) commuteFiledir _ = Unknown -type CommuteFunction = forall wX wY . (Prim :< Prim) wX wY -> Perhaps ((Prim :< Prim) wX wY) +type CommuteFunction = forall wX wY . (Prim :> Prim) wX wY -> Perhaps ((Prim :> Prim) wX wY) newtype WrappedCommuteFunction = WrappedCommuteFunction { runWrappedCommuteFunction :: CommuteFunction } subcommutes :: [(String, WrappedCommuteFunction)] @@ -166,56 +169,56 @@ [("speedyCommute", WrappedCommuteFunction speedyCommute), ("commuteFiledir", WrappedCommuteFunction (cleverCommute commuteFiledir)), ("commuteFilepatches", WrappedCommuteFunction (cleverCommute commuteFilepatches)), - ("commutex", WrappedCommuteFunction (toPerhaps . toRevCommute commute)) + ("commutex", WrappedCommuteFunction (toPerhaps . commute)) ] commuteFilepatches :: CommuteFunction -commuteFilepatches (FP f1 p1 :< FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :< p2) +commuteFilepatches (FP f1 p1 :> FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :> p2) commuteFilepatches _ = Unknown -commuteFP :: FileName -> (FilePatchType :< FilePatchType) wX wY - -> Perhaps ((Prim :< Prim) wX wY) -commuteFP f (Hunk line1 [] [] :< p2) = - seq f $ Succeeded (FP f (unsafeCoerceP p2) :< FP f (Hunk line1 [] [])) -commuteFP f (p2 :< Hunk line1 [] []) = - seq f $ Succeeded (FP f (Hunk line1 [] []) :< FP f (unsafeCoerceP p2)) -commuteFP f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) = seq f $ - toPerhaps $ commuteHunk f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) -commuteFP f (TokReplace t o n :< Hunk line2 old2 new2) = seq f $ - case tryTokReplace t o n old2 of +commuteFP :: FileName -> (FilePatchType :> FilePatchType) wX wY + -> Perhaps ((Prim :> Prim) wX wY) +commuteFP f (p1 :> Hunk line1 [] []) = + seq f $ Succeeded (FP f (Hunk line1 [] []) :> FP f (unsafeCoerceP p1)) +commuteFP f (Hunk line1 [] [] :> p2) = + seq f $ Succeeded (FP f (unsafeCoerceP p2) :> FP f (Hunk line1 [] [])) +commuteFP f (Hunk line1 old1 new1 :> Hunk line2 old2 new2) = seq f $ + toPerhaps $ commuteHunk f (Hunk line1 old1 new1 :> Hunk line2 old2 new2) +commuteFP f (Hunk line1 old1 new1 :> TokReplace t o n) = seq f $ + case tryTokReplace t o n old1 of Nothing -> Failed - Just old2' -> - case tryTokReplace t o n new2 of - Nothing -> Failed - Just new2' -> Succeeded (FP f (Hunk line2 old2' new2') :< - FP f (TokReplace t o n)) -commuteFP f (TokReplace t o n :< TokReplace t2 o2 n2) - | seq f $ t /= t2 = Failed - | o == o2 = Failed - | n == o2 = Failed - | o == n2 = Failed - | n == n2 = Failed - | otherwise = Succeeded (FP f (TokReplace t2 o2 n2) :< - FP f (TokReplace t o n)) + Just old1' -> + case tryTokReplace t o n new1 of + Nothing -> Failed + Just new1' -> Succeeded (FP f (TokReplace t o n) :> + FP f (Hunk line1 old1' new1')) +commuteFP f (TokReplace t1 o1 n1 :> TokReplace t2 o2 n2) + | seq f $ t1 /= t2 = Failed + | o1 == o2 = Failed + | n1 == o2 = Failed + | o1 == n2 = Failed + | n1 == n2 = Failed + | otherwise = Succeeded (FP f (TokReplace t2 o2 n2) :> + FP f (TokReplace t1 o1 n1)) commuteFP _ _ = Unknown -commuteHunk :: FileName -> (FilePatchType :< FilePatchType) wX wY - -> Maybe ((Prim :< Prim) wX wY) -commuteHunk f (Hunk line2 old2 new2 :< Hunk line1 old1 new1) +commuteHunk :: FileName -> (FilePatchType :> FilePatchType) wX wY + -> Maybe ((Prim :> Prim) wX wY) +commuteHunk f (Hunk line1 old1 new1 :> Hunk line2 old2 new2) | seq f $ line1 + lengthnew1 < line2 = - Just (FP f (Hunk line1 old1 new1) :< - FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2)) + Just (FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2) :> + FP f (Hunk line1 old1 new1)) | line2 + lengthold2 < line1 = - Just (FP f (Hunk (line1+ lengthnew2 - lengthold2) old1 new1) :< - FP f (Hunk line2 old2 new2)) + Just (FP f (Hunk line2 old2 new2) :> + FP f (Hunk (line1+ lengthnew2 - lengthold2) old1 new1)) | line1 + lengthnew1 == line2 && lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = - Just (FP f (Hunk line1 old1 new1) :< - FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2)) + Just (FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2) :> + FP f (Hunk line1 old1 new1)) | line2 + lengthold2 == line1 && lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = - Just (FP f (Hunk (line1 + lengthnew2 - lengthold2) old1 new1) :< - FP f (Hunk line2 old2 new2)) + Just (FP f (Hunk line2 old2 new2) :> + FP f (Hunk (line1 + lengthnew2 - lengthold2) old1 new1)) | otherwise = seq f Nothing where lengthnew1 = length new1 lengthnew2 = length new2 diff --git a/src/Darcs/Patch/Prim/V1/Core.hs b/src/Darcs/Patch/Prim/V1/Core.hs --- a/src/Darcs/Patch/Prim/V1/Core.hs +++ b/src/Darcs/Patch/Prim/V1/Core.hs @@ -26,6 +26,9 @@ ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( pi ) import qualified Data.ByteString as B (ByteString) diff --git a/src/Darcs/Patch/Prim/V1/Details.hs b/src/Darcs/Patch/Prim/V1/Details.hs --- a/src/Darcs/Patch/Prim/V1/Details.hs +++ b/src/Darcs/Patch/Prim/V1/Details.hs @@ -3,7 +3,9 @@ () where -import Prelude hiding ( pi ) +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Prim.Class ( PrimDetails(..) ) import Darcs.Patch.Prim.V1.Core ( Prim(..), FilePatchType(..), DirPatchType(..) ) diff --git a/src/Darcs/Patch/Prim/V1/Read.hs b/src/Darcs/Patch/Prim/V1/Read.hs --- a/src/Darcs/Patch/Prim/V1/Read.hs +++ b/src/Darcs/Patch/Prim/V1/Read.hs @@ -1,6 +1,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V1.Read () where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Prim.Class ( PrimRead(..), hunk, binary ) import Darcs.Patch.Prim.V1.Core ( Prim(..), diff --git a/src/Darcs/Patch/Prim/V1/Show.hs b/src/Darcs/Patch/Prim/V1/Show.hs --- a/src/Darcs/Patch/Prim/V1/Show.hs +++ b/src/Darcs/Patch/Prim/V1/Show.hs @@ -4,13 +4,16 @@ ( showHunk ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( pi ) import Darcs.Util.ByteString ( fromPS2Hex ) import qualified Data.ByteString as B (ByteString, length, take, drop) import qualified Data.ByteString.Char8 as BC (head) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..), showFileHunk ) import Darcs.Util.Path ( FileName ) @@ -42,7 +45,7 @@ showContextPatch (isHunk -> Just fh) = showContextHunk fh showContextPatch p = return $ showPatch p summary = plainSummaryPrim - summaryFL = plainSummaryPrims False + summaryFL = plainSummaryPrims False [] thing _ = "change" instance Show (Prim wX wY) where diff --git a/src/Darcs/Patch/Prim/V3.hs b/src/Darcs/Patch/Prim/V3.hs deleted file mode 100644 --- a/src/Darcs/Patch/Prim/V3.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Darcs.Patch.Prim.V3 ( Prim ) where - -import Darcs.Patch.Prim.V3.Apply () -import Darcs.Patch.Prim.V3.Coalesce () -import Darcs.Patch.Prim.V3.Commute () -import Darcs.Patch.Prim.V3.Core ( Prim ) -import Darcs.Patch.Prim.V3.Details () -import Darcs.Patch.Prim.V3.Read () -import Darcs.Patch.Prim.V3.Show () - -import Darcs.Patch.Prim.Class ( PrimPatch, PrimPatchBase(..), FromPrim(..) ) -import Darcs.Patch.Patchy ( Patchy ) - -instance PrimPatch Prim -instance Patchy Prim - -instance PrimPatchBase Prim where - type PrimOf Prim = Prim - -instance FromPrim Prim where - fromPrim = id diff --git a/src/Darcs/Patch/Prim/V3/Apply.hs b/src/Darcs/Patch/Prim/V3/Apply.hs deleted file mode 100644 --- a/src/Darcs/Patch/Prim/V3/Apply.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-methods #-} -module Darcs.Patch.Prim.V3.Apply ( ObjectMap(..) ) where - -import Darcs.Patch.Apply ( Apply(..) ) -import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTrans(..), ToTree(..) ) -import Darcs.Patch.Repair ( RepairToFL(..) ) - -import Darcs.Patch.Prim.Class ( PrimApply(..) ) -import Darcs.Patch.Prim.V3.Core ( Prim(..), hunkEdit ) -import Darcs.Patch.Prim.V3.ObjectMap - -import Control.Monad.State( StateT, runStateT, gets, lift, put ) -import qualified Data.Map as M - --- import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) - -import Darcs.Patch.Witnesses.Ordered ( FL(..) ) -import Storage.Hashed.Hash( Hash(..) ) - -#include "impossible.h" - -instance Apply Prim where - type ApplyState Prim = ObjectMap - apply (Manifest i (dirid, name)) = editDirectory dirid (M.insert name i) - apply (Demanifest _ (dirid, name)) = editDirectory dirid (M.delete name) - apply (TextHunk i hunk) = editFile i (hunkEdit hunk) - apply (BinaryHunk i hunk) = editFile i (hunkEdit hunk) - apply Identity = return () - apply (Move{}) = bug "apply for move not implemented" - -instance RepairToFL Prim where - applyAndTryToFixFL p = apply p >> return Nothing - -instance PrimApply Prim where - applyPrimFL NilFL = return () - applyPrimFL (p:>:ps) = apply p >> applyPrimFL ps - -instance ToTree ObjectMap -- TODO - -editObject :: (Monad m) => UUID -> (Maybe (Object m) -> Object m) -> (StateT (ObjectMap m) m) () -editObject i edit = do load <- gets getObject - store <- gets putObject - obj <- lift $ load i - new <- lift $ store i $ edit obj - put new - return () - -instance (Functor m, Monad m) => ApplyMonad (StateT (ObjectMap m) m) ObjectMap where - type ApplyMonadBase (StateT (ObjectMap m) m) = m - editFile i edit = editObject i edit' - where edit' (Just (Blob x _)) = Blob (edit `fmap` x) NoHash - edit' (Just (Directory x)) = Directory x -- error? - edit' Nothing = Blob (return $ edit "") NoHash - editDirectory i edit = editObject i edit' - where edit' (Just (Directory x)) = Directory $ edit x - edit' (Just (Blob x y)) = Blob x y -- error? - edit' Nothing = Directory $ edit M.empty - -instance (Functor m, Monad m) => ApplyMonadTrans m ObjectMap where - type ApplyMonadOver m ObjectMap = StateT (ObjectMap m) m - runApplyMonad = runStateT - diff --git a/src/Darcs/Patch/Prim/V3/Coalesce.hs b/src/Darcs/Patch/Prim/V3/Coalesce.hs deleted file mode 100644 --- a/src/Darcs/Patch/Prim/V3/Coalesce.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Darcs.Patch.Prim.V3.Coalesce () where - -import Darcs.Patch.Prim.Class ( PrimCanonize(..) ) -import Darcs.Patch.Witnesses.Ordered( FL(..) ) -import Darcs.Patch.Prim.V3.Core( Prim ) - --- TODO -instance PrimCanonize Prim where - tryToShrink = error "tryToShrink" - tryShrinkingInverse _ = error "tryShrinkingInverse" - sortCoalesceFL = id - canonize _ = (:>: NilFL) - canonizeFL _ = id - coalesce = const Nothing diff --git a/src/Darcs/Patch/Prim/V3/Commute.hs b/src/Darcs/Patch/Prim/V3/Commute.hs deleted file mode 100644 --- a/src/Darcs/Patch/Prim/V3/Commute.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-overlapping-patterns #-} -{-# LANGUAGE CPP #-} -module Darcs.Patch.Prim.V3.Commute - ( CommuteMonad(..) ) - where - -import Data.List ( intersect ) - -import qualified Data.ByteString as BS (length) - -import Darcs.Patch.Witnesses.Ordered ( (:>)(..) ) -import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -import Darcs.Patch.Prim.V3.Core ( Prim(..), Hunk(..), touches ) -import Darcs.Patch.Commute ( Commute(..) ) -import Darcs.Patch.Permutations () -- for Invert instance of FL - -#include "impossible.h" - -class Monad m => CommuteMonad m where - commuteFail :: m a - -- TODO we eventually have to get rid of runCommute with this signature, - -- since m might involve IO at some point, which we can't "run"; - -- alternatively, for IO it could always yield Nothing, having a separate - -- IO-specific function to "run" commutes in IO - -instance CommuteMonad Maybe where - commuteFail = Nothing - -instance Commute Prim where - commute = commute' - -class Commute' p where - commute' :: (CommuteMonad m) => (p :> p) wX wY -> m ((p :> p) wX wY) - -typematch :: Prim wX wY -> Prim wY wZ -> Bool -typematch _ _ = True -- TODO - -instance Commute' Prim where - commute' (a :> b) | null (touches a `intersect` touches b) = return (unsafeCoerceP b :> unsafeCoerceP a) - | not (a `typematch` b) = commuteFail - | otherwise = commuteOverlapping (a :> b) - --- Commute patches that have actual overlap in terms of touched objects, and their types allow -commuteOverlapping :: (CommuteMonad m) => (Prim :> Prim) wX wY -> m ((Prim :> Prim) wX wY) -commuteOverlapping (BinaryHunk a x :> BinaryHunk _ y) = - do (y' :> x') <- commuteHunk (x :> y) - return $ unsafeCoerceP (BinaryHunk a y' :> BinaryHunk a x') -commuteOverlapping (TextHunk a x :> TextHunk _ y) = - do (y' :> x') <- commuteHunk (x :> y) - return $ unsafeCoerceP (TextHunk a y' :> TextHunk a x') -commuteOverlapping _ = commuteFail - -commuteHunk :: (CommuteMonad m) => (Hunk :> Hunk) wX wY -> m ((Hunk :> Hunk) wY wX) -commuteHunk (Hunk off1 old1 new1 :> Hunk off2 old2 new2) - | off1 + lengthnew1 < off2 = - return $ Hunk (off2 - lengthnew1 + lengthold1) old2 new2 :> Hunk off1 old1 new1 - | off2 + lengthold2 < off1 = - return $ Hunk off2 old2 new2 :> Hunk (off1 + lengthnew2 - lengthold2) old1 new1 - | off1 + lengthnew1 == off2 && - lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = - return $ Hunk (off2 - lengthnew1 + lengthold1) old2 new2 :> Hunk off1 old1 new1 - | off2 + lengthold2 == off1 && - lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = - return $ Hunk off2 old2 new2 :> Hunk (off1 + lengthnew2 - lengthold2) old1 new1 - | otherwise = commuteFail - where lengthnew1 = BS.length new1 - lengthnew2 = BS.length new2 - lengthold1 = BS.length old1 - lengthold2 = BS.length old2 -commuteHunk _ = impossible diff --git a/src/Darcs/Patch/Prim/V3/Core.hs b/src/Darcs/Patch/Prim/V3/Core.hs deleted file mode 100644 --- a/src/Darcs/Patch/Prim/V3/Core.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE CPP, OverloadedStrings, StandaloneDeriving #-} - --- Copyright (C) 2011 Petr Rockai --- --- Permission is hereby granted, free of charge, to any person --- obtaining a copy of this software and associated documentation --- files (the "Software"), to deal in the Software without --- restriction, including without limitation the rights to use, copy, --- modify, merge, publish, distribute, sublicense, and/or sell copies --- of the Software, and to permit persons to whom the Software is --- furnished to do so, subject to the following conditions: --- --- The above copyright notice and this permission notice shall be --- included in all copies or substantial portions of the Software. --- --- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, --- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF --- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND --- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS --- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN --- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN --- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE --- SOFTWARE. - - -module Darcs.Patch.Prim.V3.Core - ( Prim(..), Hunk(..), UUID(..), Location, Object(..), touches, hunkEdit ) - where - -import qualified Data.ByteString as BS - -import Darcs.Patch.Witnesses.Eq ( MyEq(..) ) -import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) ) -import Darcs.Patch.FileHunk( IsHunk(..) ) -import Darcs.Patch.Invert ( Invert(..) ) -import Darcs.Patch.Inspect ( PatchInspect(..) ) -import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimClassify(..) ) -import Darcs.Patch.Prim.V3.ObjectMap - --- TODO: elaborate - -data Hunk wX wY where - Hunk :: !Int -> BS.ByteString -> BS.ByteString -> Hunk wX wY - deriving Show - -instance Show1 (Hunk wX) where - showDict1 = ShowDictClass - -instance Show2 Hunk where - showDict2 = ShowDictClass - -invertHunk :: Hunk wX wY -> Hunk wY wX -invertHunk (Hunk off old new) = Hunk off new old - -hunkEdit :: Hunk wX wY -> BS.ByteString -> BS.ByteString -hunkEdit (Hunk off old new) bs = case splice bs (off) (off + BS.length old) of - x | x == old -> BS.concat [ BS.take off bs, new, BS.drop (off + BS.length old) bs ] - | otherwise -> error $ "error applying hunk: " ++ show off ++ " " ++ show old ++ " " - ++ show new ++ " to " ++ show bs - where splice bs' x y = BS.drop x $ BS.take y bs' - -instance MyEq Hunk where - unsafeCompare (Hunk i x y) (Hunk i' x' y') = i == i' && x == x' && y == y' - -data Prim wX wY where - BinaryHunk :: !UUID -> Hunk wX wY -> Prim wX wY - TextHunk :: !UUID -> Hunk wX wY -> Prim wX wY - - -- TODO: String is not the right type here. However, what it represents is - -- a single file *name* (not a path). No slashes allowed, no "." and ".." - -- allowed either. - Manifest :: !UUID -> Location -> Prim wX wY - Demanifest :: !UUID -> Location -> Prim wX wY - Move :: !UUID -> Location -> Location -> Prim wX wY - Identity :: Prim wX wX - -deriving instance Show (Prim wX wY) - -instance Show1 (Prim wX) where - showDict1 = ShowDictClass - -instance Show2 Prim where - showDict2 = ShowDictClass - -touches :: Prim wX wY -> [UUID] -touches (BinaryHunk x _) = [x] -touches (TextHunk x _) = [x] -touches (Manifest _ (x, _)) = [x] -touches (Demanifest _ (x, _)) = [x] -touches (Move _ (x, _) (y, _)) = [x, y] -touches Identity = [] - --- TODO: PrimClassify doesn't make sense for V3 prims -instance PrimClassify Prim where - primIsAddfile _ = False - primIsRmfile _ = False - primIsAdddir _ = False - primIsRmdir _ = False - primIsHunk _ = False - primIsMove _ = False - primIsBinary _ = False - primIsTokReplace _ = False - primIsSetpref _ = False - is_filepatch _ = Nothing - --- TODO: PrimConstruct makes no sense for V3 prims -instance PrimConstruct Prim where - addfile _ = error "PrimConstruct addfile" - rmfile _ = error "PrimConstruct rmfile" - adddir _ = error "PrimConstruct adddir" - rmdir _ = error "PrimConstruct rmdir" - move _ _ = error "PrimConstruct move" - changepref _ _ _ = error "PrimConstruct changepref" - hunk _ _ _ _ = error "PrimConstruct hunk" - tokreplace _ _ _ _ = error "PrimConstruct tokreplace" - binary _ _ _ = error "PrimConstruct binary" - primFromHunk _ = error "PrimConstruct primFromHunk" - anIdentity = Identity - -instance IsHunk Prim where - isHunk _ = Nothing - -instance Invert Prim where - invert (BinaryHunk x h) = BinaryHunk x $ invertHunk h - invert (TextHunk x h) = TextHunk x $ invertHunk h - invert (Manifest x y) = Demanifest x y - invert (Demanifest x y) = Manifest x y - invert (Move x y z) = Move x z y - invert Identity = Identity - -instance PatchInspect Prim where - -- We don't need this for V3. Slashes are not allowed in Manifest and - -- Demanifest patches and nothing else uses working-copy paths. - listTouchedFiles _ = [] - - -- TODO (used for --match 'hunk ...', presumably) - hunkMatches _ _ = False - -instance MyEq Prim where - unsafeCompare (BinaryHunk a b) (BinaryHunk c d) = a == c && b `unsafeCompare` d - unsafeCompare (TextHunk a b) (TextHunk c d) = a == c && b `unsafeCompare` d - unsafeCompare (Manifest a b) (Manifest c d) = a == c && b == d - unsafeCompare (Demanifest a b) (Demanifest c d) = a == c && b == d - unsafeCompare Identity Identity = True - unsafeCompare _ _ = False - -instance Eq (Prim wX wY) where - (==) = unsafeCompare diff --git a/src/Darcs/Patch/Prim/V3/Details.hs b/src/Darcs/Patch/Prim/V3/Details.hs deleted file mode 100644 --- a/src/Darcs/Patch/Prim/V3/Details.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Darcs.Patch.Prim.V3.Details - () - where - -import Darcs.Patch.Prim.Class ( PrimDetails(..) ) -import Darcs.Patch.Prim.V3.Core ( Prim(..) ) - - --- TODO -instance PrimDetails Prim where - summarizePrim _ = [] diff --git a/src/Darcs/Patch/Prim/V3/ObjectMap.hs b/src/Darcs/Patch/Prim/V3/ObjectMap.hs deleted file mode 100644 --- a/src/Darcs/Patch/Prim/V3/ObjectMap.hs +++ /dev/null @@ -1,40 +0,0 @@ --- Copyright (C) 2011 Petr Rockai --- --- Permission is hereby granted, free of charge, to any person --- obtaining a copy of this software and associated documentation --- files (the "Software"), to deal in the Software without --- restriction, including without limitation the rights to use, copy, --- modify, merge, publish, distribute, sublicense, and/or sell copies --- of the Software, and to permit persons to whom the Software is --- furnished to do so, subject to the following conditions: --- --- The above copyright notice and this permission notice shall be --- included in all copies or substantial portions of the Software. --- --- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, --- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF --- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND --- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS --- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN --- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN --- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE --- SOFTWARE. - -module Darcs.Patch.Prim.V3.ObjectMap( UUID(..), Location, Object(..), - ObjectMap(..), DirContent ) where - -import Storage.Hashed.Hash( Hash ) -import qualified Data.ByteString as BS (ByteString) -import qualified Data.Map as M - - -newtype UUID = UUID BS.ByteString deriving (Eq, Ord, Show) -type Location = (UUID, BS.ByteString) -type DirContent = M.Map BS.ByteString UUID -data Object (m :: * -> *) = Directory DirContent - | Blob (m BS.ByteString) !Hash - -data ObjectMap (m :: * -> *) = ObjectMap { getObject :: UUID -> m (Maybe (Object m)) - , putObject :: UUID -> Object m -> m (ObjectMap m) - , listObjects :: m [UUID] - } diff --git a/src/Darcs/Patch/Prim/V3/Read.hs b/src/Darcs/Patch/Prim/V3/Read.hs deleted file mode 100644 --- a/src/Darcs/Patch/Prim/V3/Read.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE CPP, ViewPatterns, OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Darcs.Patch.Prim.V3.Read () where -import Darcs.Patch.Read ( ReadPatch(..) ) -import Darcs.Patch.ReadMonads -import Darcs.Patch.Prim.Class( PrimRead(..) ) -import Darcs.Patch.Prim.V3.Core( Prim(..), Hunk(..) ) -import Darcs.Patch.Prim.V3.ObjectMap -import Darcs.Patch.Witnesses.Sealed( seal ) - -import Control.Applicative ( (<$>) ) -import Control.Monad ( liftM, liftM2 ) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import Data.Char ( chr ) - -#include "impossible.h" - -instance PrimRead Prim where - readPrim _ = do skipSpace - choice $ map (liftM seal) [ - identity, - hunk "hunk" TextHunk, - hunk "binhunk" BinaryHunk, - manifest "manifest" Manifest, - manifest "demanifest" Demanifest ] - - where manifest kind ctor = liftM2 ctor (patch kind) location - identity = lexString "identity" >> return Identity - patch x = string x >> uuid - uuid = UUID <$> myLex' - filename = encoded - encoded = decodeWhite <$> myLex' - hunktext = skipSpace >> choice [ string "." >> encoded, string "!" >> return B.empty ] - location = liftM2 (,) uuid filename - hunk kind ctor = do uid <- patch kind - offset <- int - old <- hunktext - new <- hunktext - return $ ctor uid (Hunk offset old new) - -instance ReadPatch Prim where - readPatch' = readPrim undefined - --- XXX a bytestring version of decodeWhite from Darcs.FileName -decodeWhite :: B.ByteString -> B.ByteString -decodeWhite (BC.uncons -> Just ('\\', cs)) = - case BC.break (=='\\') cs of - (theord, BC.uncons -> Just ('\\', rest)) -> - chr (read $ BC.unpack theord) `BC.cons` decodeWhite rest - _ -> error "malformed filename" -decodeWhite (BC.uncons -> Just (c, cs)) = c `BC.cons` decodeWhite cs -decodeWhite (BC.uncons -> Nothing) = BC.empty -decodeWhite _ = impossible - diff --git a/src/Darcs/Patch/Prim/V3/Show.hs b/src/Darcs/Patch/Prim/V3/Show.hs deleted file mode 100644 --- a/src/Darcs/Patch/Prim/V3/Show.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP, OverloadedStrings #-} -module Darcs.Patch.Prim.V3.Show - ( showHunk ) - where - -import Prelude hiding ( pi ) - -import Data.Char ( isSpace, ord ) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC - -import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) ) -import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..) ) -import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims ) -import Darcs.Patch.Prim.Class ( PrimShow(..) ) -import Darcs.Patch.Prim.V3.Core ( Prim(..), Hunk(..), UUID(..) ) -import Darcs.Patch.Prim.V3.Details () -import Darcs.Util.Printer ( text, packedString, blueText, (<+>), (<>), Doc ) - -#include "impossible.h" - --- TODO this instance shouldn't really be necessary, as Prims aren't used generically -instance PatchListFormat Prim - -instance ShowPatchBasic Prim where - showPatch = showPrim OldFormat - -instance ShowPatch Prim where - showContextPatch p = return $ showPatch p - summary = plainSummaryPrim - summaryFL = plainSummaryPrims False - thing _ = "change" - -instance PrimShow Prim where - showPrim _ (TextHunk u h) = showHunk "hunk" u h - showPrim _ (BinaryHunk u h) = showHunk "binhunk" u h - showPrim _ (Manifest f (d,p)) = showManifest "manifest" d f p - showPrim _ (Demanifest f (d,p)) = showManifest "demanifest" d f p - showPrim _ Identity = blueText "identity" - showPrim _ (Move{}) = bug "show for move not implemented" - -showManifest :: String -> UUID -> UUID -> BC.ByteString -> Doc -showManifest txt dir file path = blueText txt <+> - formatUUID file <+> - formatUUID dir <+> - packedString (encodeWhite path) - -showHunk :: String -> UUID -> Hunk wX wY -> Doc -showHunk txt uid (Hunk off old new) = blueText txt <+> - formatUUID uid <+> - text (show off) <+> - hunktext old <+> - hunktext new - where hunktext bit | B.null bit = text "!" - | otherwise = text "." <> packedString (encodeWhite bit) - -formatUUID :: UUID -> Doc -formatUUID (UUID x) = packedString x - --- XXX a bytestring version of encodeWhite from Darcs.FileName -encodeWhite :: B.ByteString -> B.ByteString -encodeWhite = BC.concatMap encode - where encode c - | isSpace c || c == '\\' = B.concat [ "\\", BC.pack $ show $ ord c, "\\" ] - | otherwise = BC.singleton c - diff --git a/src/Darcs/Patch/Progress.hs b/src/Darcs/Patch/Progress.hs --- a/src/Darcs/Patch/Progress.hs +++ b/src/Darcs/Patch/Progress.hs @@ -6,6 +6,9 @@ , progressRLShowTags ) where +import Prelude () +import Darcs.Prelude + import System.IO.Unsafe ( unsafePerformIO ) import Darcs.Patch.Info ( justName, isTag ) @@ -38,37 +41,37 @@ -- | Evaluate an 'RL' list and report progress. progressRL :: String -> RL a wX wY -> RL a wX wY progressRL _ NilRL = NilRL -progressRL k xxs@(x :<: xs) = +progressRL k xxs@(xs :<: x) = if xxsLen < minlist then xxs - else startProgress x k xxsLen :<: pl xs + else pl xs :<: startProgress x k xxsLen where xxsLen = lengthRL xxs pl :: RL a wX wY -> RL a wX wY pl NilRL = NilRL - pl (y:<:NilRL) = unsafePerformIO $ do endTedious k - return (y:<:NilRL) - pl (y:<:ys) = progress k y :<: pl ys + pl (NilRL:<:y) = unsafePerformIO $ do endTedious k + return (NilRL:<:y) + pl (ys:<:y) = pl ys :<: progress k y -- | Evaluate an 'RL' list and report progress. In addition to printing -- the number of patches we got, show the name of the last tag we got. -progressRLShowTags :: String -> RL (PatchInfoAnd p) wX wY - -> RL (PatchInfoAnd p) wX wY +progressRLShowTags :: String -> RL (PatchInfoAnd rt p) wX wY + -> RL (PatchInfoAnd rt p) wX wY progressRLShowTags _ NilRL = NilRL -progressRLShowTags k xxs@(x :<: xs) = +progressRLShowTags k xxs@(xs :<: x) = if xxsLen < minlist then xxs - else startProgress x k xxsLen :<: pl xs + else pl xs :<: startProgress x k xxsLen where xxsLen = lengthRL xxs - pl :: RL (PatchInfoAnd p) wX wY -> RL (PatchInfoAnd p) wX wY + pl :: RL (PatchInfoAnd rt p) wX wY -> RL (PatchInfoAnd rt p) wX wY pl NilRL = NilRL - pl (y :<: NilRL) = unsafePerformIO $ do endTedious k - return (y :<: NilRL) - pl (y :<: ys) = + pl (NilRL :<: y) = unsafePerformIO $ do endTedious k + return (NilRL :<: y) + pl (ys :<: y) = if isTag iy - then finishedOne k ("back to "++ justName iy) y :<: pl ys - else progressKeepLatest k y :<: pl ys + then pl ys :<: finishedOne k ("back to "++ justName iy) y + else pl ys :<: progressKeepLatest k y where iy = info y diff --git a/src/Darcs/Patch/Read.hs b/src/Darcs/Patch/Read.hs --- a/src/Darcs/Patch/Read.hs +++ b/src/Darcs/Patch/Read.hs @@ -23,7 +23,8 @@ readFileName ) where -import Prelude hiding ( pi ) +import Prelude () +import Darcs.Prelude import Darcs.Util.ByteString ( dropSpace ) import qualified Data.ByteString as B (ByteString, null) @@ -39,7 +40,7 @@ import Darcs.Patch.Witnesses.Ordered ( FL(..), RL, reverseFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal ) -import Control.Applicative ( (<$>), (<|>) ) +import Control.Applicative ( (<|>) ) import Control.Monad ( mzero ) import qualified Data.ByteString.Char8 as BC ( ByteString, unpack ) diff --git a/src/Darcs/Patch/ReadMonads.hs b/src/Darcs/Patch/ReadMonads.hs --- a/src/Darcs/Patch/ReadMonads.hs +++ b/src/Darcs/Patch/ReadMonads.hs @@ -9,13 +9,16 @@ checkConsumes, linesStartingWith, linesStartingWithEndingWith) where +import Prelude () +import Darcs.Prelude + import Darcs.Util.ByteString ( dropSpace, breakSpace, breakFirstPS, readIntPS, breakLastPS ) import qualified Data.ByteString as B (null, drop, length, tail, empty, ByteString) import qualified Data.ByteString.Char8 as BC ( uncons, dropWhile, break , splitAt, length, head ) -import Control.Applicative ( Alternative(..), Applicative(..), (<$>) ) +import Control.Applicative ( Alternative(..) ) import Data.Foldable ( asum ) import Control.Monad ( MonadPlus(..) ) diff --git a/src/Darcs/Patch/Rebase.hs b/src/Darcs/Patch/Rebase.hs --- a/src/Darcs/Patch/Rebase.hs +++ b/src/Darcs/Patch/Rebase.hs @@ -1,84 +1,38 @@ -- Copyright (C) 2009 Ganesh Sittampalam -- -- BSD3 -{-# LANGUAGE CPP, GADTs, PatternGuards, TypeOperators, NoMonomorphismRestriction, ViewPatterns, UndecidableInstances #-} module Darcs.Patch.Rebase - ( Rebasing(..), RebaseItem(..), RebaseName(..), RebaseFixup(..) - , simplifyPush, simplifyPushes - , mkSuspended - , takeHeadRebase, takeHeadRebaseFL, takeHeadRebaseRL - , takeAnyRebase, takeAnyRebaseAndTrailingPatches - , countToEdit + ( takeHeadRebase + , takeHeadRebaseFL + , takeAnyRebase + , takeAnyRebaseAndTrailingPatches ) where -import Darcs.Patch ( RepoPatch ) -import Darcs.Patch.Commute ( selfCommuter ) -import Darcs.Patch.CommuteFn ( CommuteFn ) -import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) ) -import Darcs.Patch.Debug ( PatchDebug(..) ) -import Darcs.Patch.Effect ( Effect(..) ) -import Darcs.Patch.FileHunk ( IsHunk(..) ) -import Darcs.Patch.Format ( PatchListFormat(..), ListFormat, copyListFormat ) -import Darcs.Patch.Matchable ( Matchable ) -import Darcs.Patch.MaybeInternal ( MaybeInternal(..), InternalChecker(..) ) -import Darcs.Patch.Merge ( Merge(..) ) -import Darcs.Patch.Named ( Named(..), patchcontents, namepatch - , commuterIdNamed - ) +import Prelude () +import Darcs.Prelude + +import Darcs.Patch.Named.Wrapped ( WrappedNamed(RebaseP) ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully ) -import Darcs.Patch.Patchy ( Invert(..), Commute(..), Patchy, Apply(..), - ShowPatch(..), ReadPatch(..), - PatchInspect(..) - ) -import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, FromPrim(..), FromPrim(..), canonizeFL ) -import Darcs.Patch.Read ( bracketedFL ) -import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) ) -import Darcs.Patch.Rebase.Name - ( RebaseName(..) - , commutePrimName, commuteNamePrim - ) -import Darcs.Patch.Rebase.NameHack ( NameHack(..) ) -import Darcs.Patch.Rebase.Recontext ( RecontextRebase(..), RecontextRebase1(..), RecontextRebase2(..) ) -import Darcs.Patch.Repair ( Check(..), RepairToFL(..) ) +import Darcs.Patch.Rebase.Container ( Suspended(..) ) +import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) import Darcs.Patch.Set ( PatchSet(..) ) -import Darcs.Patch.Show ( ShowPatchBasic(..) ) -import Darcs.Patch.ReadMonads ( ParserM, lexString, myLex' ) -import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Ordered import Darcs.Patch.Witnesses.Sealed -import Darcs.Patch.Witnesses.Show - ( Show1(..), Show2(..), showsPrec2 - , ShowDict(ShowDictClass), appPrec - ) -import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) ) -import Darcs.Util.IsoDate ( getIsoDateTime ) -import Darcs.Util.Text ( formatParas ) -import Darcs.Util.Printer ( vcat, text, blueText, ($$), (<+>) ) -import Prelude hiding ( pi ) -import Control.Applicative ( (<$>), (<|>) ) -import Control.Arrow ( (***), second ) -import Control.Monad ( when ) -import Data.Maybe ( catMaybes ) -import qualified Data.ByteString as B ( ByteString ) -import qualified Data.ByteString.Char8 as BC ( pack ) - -#include "impossible.h" - {- Notes Note [Rebase representation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The entire rebase state is stored in a single Suspended patch. +The entire rebase state is stored in a single Suspended patch +(see Darcs.Patch.Rebase.Container). This is both unnatural and inefficient: - Unnatural because the rebase state is not really a patch and treating it as one requires various hacks: - - It has to be given a fake name: see mkSuspended + - It has to be given a fake name: see mkRebase - Since 'Named p' actually contains 'FL p', we have to assume/assert that the FL either contains a sequence of Normals @@ -123,437 +77,56 @@ -} --- TODO: move some of the docs of types to individual constructors --- once http://trac.haskell.org/haddock/ticket/43 is fixed. - --- |A patch that lives in a repository where a rebase is in --- progress. Such a repository will consist of @Normal@ patches --- along with exactly one @Suspended@ patch. --- --- Most rebase operations will require the @Suspended@ patch --- to be at the end of the repository. --- --- @Normal@ represents a normal patch within a respository where a --- rebase is in progress. @Normal p@ is given the same on-disk --- representation as @p@, so a repository can be switched into --- and out of rebasing mode simply by adding or removing a --- @Suspended@ patch and setting the appropriate format flag. --- --- The single @Suspended@ patch contains the entire rebase --- state, in the form of 'RebaseItem's. --- --- Note that the witnesses are such that the @Suspended@ --- patch has no effect on the context of the rest of the --- repository; in a sense the patches within it are --- dangling off to one side from the main repository. --- --- See Note [Rebase representation] in the source for a discussion --- of the design choice to embed the rebase state in a single patch. -data Rebasing p wX wY where - Normal :: p wX wY -> Rebasing p wX wY - Suspended :: FL (RebaseItem p) wX wY -> Rebasing p wX wX - -instance (Show2 p, Show2 (PrimOf p)) => Show (Rebasing p wX wY) where - showsPrec d (Normal p) = - showParen (d > appPrec) $ showString "Darcs.Patch.Rebase.Normal " . showsPrec2 (appPrec + 1) p - showsPrec d (Suspended p) = - showParen (d > appPrec) $ showString "Darcs.Patch.Rebase.Suspended " . showsPrec2 (appPrec + 1) p - -instance (Show2 p, Show2 (PrimOf p)) => Show1 (Rebasing p wX) where - showDict1 = ShowDictClass - -instance (Show2 p, Show2 (PrimOf p)) => Show2 (Rebasing p) where - showDict2 = ShowDictClass - --- |A single item in the rebase state consists of either --- a patch that is being edited, or a fixup that adjusts --- the context so that a subsequent patch that is being edited --- \"makes sense\". --- --- @ToEdit@ holds a patch that is being edited. The name ('PatchInfo') of --- the patch will typically be the name the patch had before --- it was added to the rebase state; if it is moved back --- into the repository it must be given a fresh name to account --- for the fact that it will not necessarily have the same --- dependencies as the original patch. This is typically --- done by changing the @Ignore-This@ junk. --- --- @Fixup@ adjusts the context so that a subsequent @ToEdit@ patch --- is correct. Where possible, @Fixup@ changes are commuted --- as far as possible into the rebase state, so any remaining --- ones will typically cause a conflict when the @ToEdit@ patch --- is moved back into the repository. -data RebaseItem p wX wY where - ToEdit :: Named p wX wY -> RebaseItem p wX wY - Fixup :: RebaseFixup p wX wY -> RebaseItem p wX wY - -instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseItem p wX wY) where - showsPrec d (ToEdit p) = - showParen (d > appPrec) $ showString "ToEdit " . showsPrec2 (appPrec + 1) p - showsPrec d (Fixup p) = - showParen (d > appPrec) $ showString "Fixup " . showsPrec2 (appPrec + 1) p - -instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseItem p wX) where - showDict1 = ShowDictClass - -instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseItem p) where - showDict2 = ShowDictClass - -countToEdit :: FL (RebaseItem p) wX wY -> Int -countToEdit NilFL = 0 -countToEdit (ToEdit _ :>: ps) = 1 + countToEdit ps -countToEdit (_ :>: ps) = countToEdit ps - -commuterRebasing :: (PrimPatchBase p, Commute p, Invert p, FromPrim p, Effect p) - => D.DiffAlgorithm -> CommuteFn p p - -> CommuteFn (Rebasing p) (Rebasing p) -commuterRebasing _ commuter (Normal p :> Normal q) = do - q' :> p' <- commuter (p :> q) - return (Normal q' :> Normal p') - --- Two rebases in sequence must have the same starting context, --- so they should trivially commute. --- This case shouldn't actually happen since each repo only has --- a single Suspended patch. -commuterRebasing _ _ (p@(Suspended _) :> q@(Suspended _)) = - return (q :> p) - -commuterRebasing da _ (Normal p :> Suspended qs) = - return (unseal Suspended (addFixup da p qs) :> Normal p) - -commuterRebasing da _ (Suspended ps :> Normal q) = - return (Normal q :> unseal Suspended (addFixup da (invert q) ps)) - - -instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Commute p) => Commute (Rebasing p) where - commute = commuterRebasing D.MyersDiff commute - -instance (PrimPatchBase p, FromPrim p, Effect p, Commute p) => NameHack (Rebasing p) where - nameHack da = Just (pushIn . AddName, pushIn . DelName) - where - pushIn :: RebaseName p wX wX -> FL (Rebasing p) wX wY -> FL (Rebasing p) wX wY - pushIn n (Suspended ps :>: NilFL) = unseal (\qs -> Suspended qs :>: NilFL) (simplifyPush da (NameFixup n) ps) - pushIn _ ps = ps - -instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Commute p, CommuteNoConflicts p) => CommuteNoConflicts (Rebasing p) where - commuteNoConflicts = commuterRebasing D.MyersDiff commuteNoConflicts - -instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Merge p) => Merge (Rebasing p) where - merge (Normal p :\/: Normal q) = case merge (p :\/: q) of - q' :/\: p' -> Normal q' :/\: Normal p' - merge (p@(Suspended _) :\/: q@(Suspended _)) = q :/\: p - merge (Normal p :\/: Suspended qs) = unseal Suspended (addFixup D.MyersDiff (invert p) qs) :/\: Normal p - merge (Suspended ps :\/: Normal q) = Normal q :/\: unseal Suspended (addFixup D.MyersDiff (invert q) ps) - -instance (PrimPatchBase p, PatchInspect p) => PatchInspect (Rebasing p) where - listTouchedFiles (Normal p) = listTouchedFiles p - listTouchedFiles (Suspended ps) = concat $ mapFL ltfItem ps - where ltfItem :: RebaseItem p wX wY -> [FilePath] - ltfItem (ToEdit q) = listTouchedFiles q - ltfItem (Fixup (PrimFixup q)) = listTouchedFiles q - ltfItem (Fixup (NameFixup _)) = [] - hunkMatches f (Normal p) = hunkMatches f p - hunkMatches f (Suspended ps) = or $ mapFL hmItem ps - where hmItem :: RebaseItem p wA wB -> Bool - hmItem (ToEdit q) = hunkMatches f q - hmItem (Fixup (PrimFixup q)) = hunkMatches f q - hmItem (Fixup (NameFixup _)) = False - -instance Invert p => Invert (Rebasing p) where - invert (Normal p) = Normal (invert p) - invert (Suspended ps) = Suspended ps -- TODO is this sensible? - -instance Effect p => Effect (Rebasing p) where - effect (Normal p) = effect p - effect (Suspended _) = NilFL - -instance (PrimPatchBase p, PatchListFormat p, Patchy p, FromPrim p, Conflict p, Effect p, CommuteNoConflicts p, IsHunk p) - => Patchy (Rebasing p) - -instance PatchDebug p => PatchDebug (Rebasing p) - -instance ( PrimPatchBase p, PatchListFormat p, Patchy p - , FromPrim p, Conflict p, Effect p - , PatchInspect p - , CommuteNoConflicts p, IsHunk p - ) - => Matchable (Rebasing p) - -instance (Conflict p, FromPrim p, Effect p, Invert p, Commute p) => Conflict (Rebasing p) where - resolveConflicts (Normal p) = resolveConflicts p - resolveConflicts (Suspended _) = [] - -instance Apply p => Apply (Rebasing p) where - type ApplyState (Rebasing p) = ApplyState p - apply (Normal p) = apply p - apply (Suspended _) = return () - -instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Rebasing p) where - showPatch (Normal p) = showPatch p - showPatch (Suspended ps) = blueText "rebase" <+> text "0.0" <+> blueText "{" - $$ vcat (mapFL showPatch ps) - $$ blueText "}" - -instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) - => ShowPatch (Rebasing p) where - - summary (Normal p) = summary p - summary (Suspended ps) = summaryFL ps - summaryFL ps = vcat (mapFL summary ps) -- TODO sort out summaries properly, considering expected conflicts - -instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseItem p) where - showPatch (ToEdit p) = blueText "rebase-toedit" <+> blueText "(" $$ showPatch p $$ blueText ")" - showPatch (Fixup (PrimFixup p)) = blueText "rebase-fixup" <+> blueText "(" $$ showPatch p $$ blueText ")" - showPatch (Fixup (NameFixup p)) = blueText "rebase-name" <+> blueText "(" $$ showPatch p $$ blueText ")" - -instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) - => ShowPatch (RebaseItem p) where - - summary (ToEdit p) = summary p - summary (Fixup (PrimFixup p)) = summary p - summary (Fixup (NameFixup n)) = summary n - summaryFL ps = vcat (mapFL summary ps) -- TODO sort out summaries properly, considering expected conflicts - - -instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (RebaseItem p) where - readPatch' = mapSeal ToEdit <$> readWith (BC.pack "rebase-toedit") <|> - mapSeal (Fixup . PrimFixup) <$> readWith (BC.pack "rebase-fixup" ) <|> - mapSeal (Fixup . NameFixup) <$> readWith (BC.pack "rebase-name" ) - where readWith :: forall m q wX . (ParserM m, ReadPatch q) => B.ByteString -> m (Sealed (q wX)) - readWith str = do lexString str - lexString (BC.pack "(") - res <- readPatch' - lexString (BC.pack ")") - return res - -instance PrimPatchBase p => PrimPatchBase (Rebasing p) where - type PrimOf (Rebasing p) = PrimOf p - -instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (Rebasing p) where - readPatch' = - do lexString (BC.pack "rebase") - version <- myLex' - when (version /= BC.pack "0.0") $ error $ "can't handle rebase version " ++ show version - (lexString (BC.pack "{}") >> return (seal (Suspended NilFL))) - <|> - (unseal (Sealed . Suspended) <$> bracketedFL readPatch' '{' '}') - <|> mapSeal Normal <$> readPatch' - -instance IsHunk p => IsHunk (Rebasing p) where - isHunk (Normal p) = isHunk p - isHunk (Suspended _) = Nothing - -instance FromPrim p => FromPrim (Rebasing p) where - fromPrim p = Normal (fromPrim p) - -instance Check p => Check (Rebasing p) where - isInconsistent (Normal p) = isInconsistent p - isInconsistent (Suspended ps) = - case catMaybes (mapFL isInconsistent ps) of - [] -> Nothing - xs -> Just (vcat xs) - -instance Check p => Check (RebaseItem p) where - isInconsistent (Fixup _) = Nothing - isInconsistent (ToEdit p) = isInconsistent p - -instance RepairToFL p => RepairToFL (Rebasing p) where - applyAndTryToFixFL (Normal p) = fmap (second $ mapFL_FL Normal) <$> applyAndTryToFixFL p - -- TODO: ideally we would apply ps in a sandbox to check the individual patches - -- are consistent with each other. - applyAndTryToFixFL (Suspended ps) = - return . fmap (unlines *** ((:>: NilFL) . Suspended)) $ repairInternal ps - --- Just repair the internals of the patch, without applying it to anything --- or checking against an external context. --- Included for the internal implementation of applyAndTryToFixFL for Rebasing, --- consider either generalising it for use everywhere, or removing once --- the implementation works in a sandbox and thus can use the "full" Repair on the --- contained patches. -class RepairInternalFL p where - repairInternalFL :: p wX wY -> Maybe ([String], FL p wX wY) - -class RepairInternal p where - repairInternal :: p wX wY -> Maybe ([String], p wX wY) - -instance RepairInternalFL p => RepairInternal (FL p) where - repairInternal NilFL = Nothing - repairInternal (x :>: ys) = - case (repairInternalFL x, repairInternal ys) of - (Nothing , Nothing) -> Nothing - (Just (e, rxs), Nothing) -> Just (e , rxs +>+ ys ) - (Nothing , Just (e', rys)) -> Just (e' , x :>: rys) - (Just (e, rxs), Just (e', rys)) -> Just (e ++ e', rxs +>+ rys) - -instance RepairInternalFL (RebaseItem p) where - repairInternalFL (ToEdit _) = Nothing - repairInternalFL (Fixup p) = fmap (second $ mapFL_FL Fixup) $ repairInternalFL p - -instance RepairInternalFL (RebaseFixup p) where - repairInternalFL (PrimFixup _) = Nothing - repairInternalFL (NameFixup _) = Nothing - -instance PatchListFormat p => PatchListFormat (Rebasing p) where - patchListFormat = copyListFormat (patchListFormat :: ListFormat p) - -instance RepoPatch p => RepoPatch (Rebasing p) - -instance (Commute p, PrimPatchBase p, FromPrim p, Effect p) => RecontextRebase (Rebasing p) where - recontextRebase = Just (RecontextRebase1 recontext) - where - recontext :: forall wY wZ . Named (Rebasing p) wY wZ -> (EqCheck wY wZ, RecontextRebase2 (Rebasing p) wY wZ) - - recontext (patchcontents -> (Suspended ps :>: NilFL)) - = (IsEq, RecontextRebase2 (\fixups -> unseal mkSuspended(simplifyPushes D.MyersDiff (mapFL_FL translateFixup fixups) ps))) - - recontext _ = (NotEq, bug "trying to recontext rebase without rebase patch at head") - - translateFixup :: RebaseFixup (Rebasing p) wX wY -> RebaseFixup p wX wY - translateFixup (PrimFixup p) = PrimFixup p - translateFixup (NameFixup n) = NameFixup (translateName n) - - translateName :: RebaseName (Rebasing p) wX wY -> RebaseName p wX wY - translateName (AddName name) = AddName name - translateName (DelName name) = DelName name - translateName (Rename old new) = Rename old new - -instance MaybeInternal (Rebasing p) where - patchInternalChecker = Just (InternalChecker rebaseIsInternal) - where rebaseIsInternal :: FL (Rebasing p) wX wY -> EqCheck wX wY - rebaseIsInternal (Suspended _ :>: NilFL) = IsEq - rebaseIsInternal _ = NotEq - -addFixup :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) => D.DiffAlgorithm -> p wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX) -addFixup da p = simplifyPushes da (mapFL_FL PrimFixup (effect p)) - -canonizeNamePair :: (RebaseName p :> RebaseName p) wX wY -> FL (RebaseName p) wX wY -canonizeNamePair (AddName n :> Rename old new) | n == old = AddName new :>: NilFL -canonizeNamePair (Rename old new :> DelName n) | n == new = DelName old :>: NilFL -canonizeNamePair (Rename old1 new1 :> Rename old2 new2) | new1 == old2 = Rename old1 new2 :>: NilFL -canonizeNamePair (n1 :> n2) = n1 :>: n2 :>: NilFL - --- |Given a list of rebase items, try to push a new fixup as far as possible into --- the list as possible, using both commutation and coalescing. If the fixup --- commutes past all the 'ToEdit' patches then it is dropped entirely. -simplifyPush :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) - => D.DiffAlgorithm -> RebaseFixup p wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX) - -simplifyPush _ _f NilFL = Sealed NilFL - -simplifyPush da (PrimFixup f1) (Fixup (PrimFixup f2) :>: ps) - | IsEq <- isInverse = Sealed ps - | otherwise - = case commute (f1 :> f2) of - Nothing -> Sealed (mapFL_FL (Fixup . PrimFixup) (canonizeFL da (f1 :>: f2 :>: NilFL)) +>+ ps) - Just (f2' :> f1') -> mapSeal (Fixup (PrimFixup f2') :>:) (simplifyPush da (PrimFixup f1') ps) - where isInverse = invert f1 =\/= f2 - -simplifyPush da (PrimFixup f) (Fixup (NameFixup n) :>: ps) - = case commutePrimName (f :> n) of - n' :> f' -> mapSeal (Fixup (NameFixup n') :>:) (simplifyPush da (PrimFixup f') ps) - -simplifyPush da (PrimFixup f) (ToEdit e :>: ps) - = case commuterIdNamed selfCommuter (fromPrim f :> e) of - Nothing -> Sealed (Fixup (PrimFixup f) :>: ToEdit e :>: ps) - Just (e' :> f') -> mapSeal (ToEdit e' :>:) (simplifyPushes da (mapFL_FL PrimFixup (effect f')) ps) - -simplifyPush da (NameFixup n1) (Fixup (NameFixup n2) :>: ps) - | IsEq <- isInverse = Sealed ps - | otherwise - = case commute (n1 :> n2) of - Nothing -> Sealed (mapFL_FL (Fixup . NameFixup) (canonizeNamePair (n1 :> n2)) +>+ ps) - Just (n2' :> n1') -> mapSeal (Fixup (NameFixup n2') :>:) (simplifyPush da (NameFixup n1') ps) - where isInverse = invert n1 =\/= n2 - -simplifyPush da (NameFixup n) (Fixup (PrimFixup f) :>: ps) = - case commuteNamePrim (n :> f) of - f' :> n' -> mapSeal (Fixup (PrimFixup f') :>:) (simplifyPush da (NameFixup n') ps) - -simplifyPush da (NameFixup (AddName an)) (p@(ToEdit (NamedP pn deps _)) :>: ps) - | an == pn = impossible - | an `elem` deps = Sealed (Fixup (NameFixup (AddName an)) :>: p :>: ps) - | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (AddName an)) ps) -simplifyPush da (NameFixup (DelName dn)) (p@(ToEdit (NamedP pn deps _)) :>: ps) - -- this case can arise if a patch is suspended then a fresh copy is pulled from another repo - | dn == pn = Sealed (Fixup (NameFixup (DelName dn)) :>: p :>: ps) - | dn `elem` deps = impossible - | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (DelName dn)) ps) -simplifyPush da (NameFixup (Rename old new)) (p@(ToEdit (NamedP pn deps body)) :>: ps) - | old == pn = impossible - | new == pn = impossible - | old `elem` deps = impossible - | new `elem` deps = - let newdeps = map (\dep -> if new == dep then old else dep) deps - in mapSeal (ToEdit (NamedP pn newdeps (unsafeCoerceP body)) :>:) (simplifyPush da (NameFixup (Rename old new)) ps) - | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (Rename old new)) ps) - --- |Like 'simplifyPush' but for a list of fixups. -simplifyPushes :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) - => D.DiffAlgorithm -> FL (RebaseFixup p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX) -simplifyPushes _ NilFL ps = Sealed ps -simplifyPushes da (f :>: fs) ps = unseal (simplifyPush da f) (simplifyPushes da fs ps) - -mkSuspended :: FL (RebaseItem p) wX wY -> IO (Named (Rebasing p) wX wX) -mkSuspended ps = do - let name = "DO NOT TOUCH: Rebase patch" - let desc = formatParas 72 - ["This patch is an internal implementation detail of rebase, used to store suspended patches, " ++ - "and should not be visible in the user interface. Please report a bug if a darcs " ++ - "command is showing you this patch."] - date <- getIsoDateTime - let author = "Invalid " - namepatch date name author desc (Suspended ps :>: NilFL) - -- |given the repository contents, get the rebase container patch, and its contents -- The rebase patch can be anywhere in the repository and is returned without being -- commuted to the end. -takeAnyRebase :: PatchSet (Rebasing p) wA wB - -> (Sealed2 (PatchInfoAnd (Rebasing p)), - Sealed2 (FL (RebaseItem p))) -takeAnyRebase (PatchSet NilRL _) = +takeAnyRebase :: PatchSet ('RepoType 'IsRebase) p wA wB + -> (Sealed2 (PatchInfoAnd ('RepoType 'IsRebase) p), + Sealed2 (Suspended p)) +takeAnyRebase (PatchSet _ NilRL) = -- it should never be behind a tag so we can stop now error "internal error: no suspended patch found" -takeAnyRebase (PatchSet (p :<: ps) pss) - | Suspended rs :>: NilFL <- patchcontents (hopefully p) = (Sealed2 p, Sealed2 rs) - | otherwise = takeAnyRebase (PatchSet ps pss) +takeAnyRebase (PatchSet pss (ps :<: p)) + | RebaseP _ rs <- hopefully p = (Sealed2 p, Sealed2 rs) + | otherwise = takeAnyRebase (PatchSet pss ps) -- |given the repository contents, get the rebase container patch, its contents, and the -- rest of the repository contents. Commutes the patch to the end of the repository -- if necessary. The rebase patch must be at the head of the repository. takeAnyRebaseAndTrailingPatches - :: PatchSet (Rebasing p) wA wB - -> FlippedSeal (PatchInfoAnd (Rebasing p) :> RL (PatchInfoAnd (Rebasing p))) wB -takeAnyRebaseAndTrailingPatches (PatchSet NilRL _) = + :: PatchSet ('RepoType 'IsRebase) p wA wB + -> FlippedSeal (PatchInfoAnd ('RepoType 'IsRebase) p :> RL (PatchInfoAnd ('RepoType 'IsRebase) p)) wB +takeAnyRebaseAndTrailingPatches (PatchSet _ NilRL) = -- it should never be behind a tag so we can stop now error "internal error: no suspended patch found" -takeAnyRebaseAndTrailingPatches (PatchSet (p :<: ps) pss) - | Suspended _ :>: NilFL <- patchcontents (hopefully p) = FlippedSeal (p :> NilRL) - | otherwise = case takeAnyRebaseAndTrailingPatches (PatchSet ps pss) of - FlippedSeal (r :> ps') -> FlippedSeal (r :> (p :<: ps')) +takeAnyRebaseAndTrailingPatches (PatchSet pss (ps :<: p)) + | RebaseP _ _ <- hopefully p = FlippedSeal (p :> NilRL) + | otherwise = case takeAnyRebaseAndTrailingPatches (PatchSet pss ps) of + FlippedSeal (r :> ps') -> FlippedSeal (r :> (ps' :<: p)) -- |given the repository contents, get the rebase container patch, its contents, and the -- rest of the repository contents. The rebase patch must be at the head of the repository. -takeHeadRebase :: PatchSet (Rebasing p) wA wB - -> (PatchInfoAnd (Rebasing p) wB wB, - Sealed (FL (RebaseItem p) wB), - PatchSet (Rebasing p) wA wB) -takeHeadRebase (PatchSet NilRL _) = error "internal error: must have a rebase container patch at end of repository" -takeHeadRebase (PatchSet (p :<: ps) pss) - | Suspended rs :>: NilFL <- patchcontents (hopefully p) = (p, Sealed rs, PatchSet ps pss) +takeHeadRebase :: PatchSet ('RepoType 'IsRebase) p wA wB + -> (PatchInfoAnd ('RepoType 'IsRebase) p wB wB, + Suspended p wB wB, + PatchSet ('RepoType 'IsRebase) p wA wB) +takeHeadRebase (PatchSet _ NilRL) = error "internal error: must have a rebase container patch at end of repository" +takeHeadRebase (PatchSet pss (ps :<: p)) + | RebaseP _ rs <- hopefully p = (p, rs, PatchSet pss ps) | otherwise = error "internal error: must have a rebase container patch at end of repository" -takeHeadRebaseRL :: RL (PatchInfoAnd (Rebasing p)) wA wB - -> (PatchInfoAnd (Rebasing p) wB wB, - Sealed (FL (RebaseItem p) wB), - RL (PatchInfoAnd (Rebasing p)) wA wB) +takeHeadRebaseRL :: RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB + -> (PatchInfoAnd ('RepoType 'IsRebase) p wB wB, + Suspended p wB wB, + RL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB) takeHeadRebaseRL NilRL = error "internal error: must have a suspended patch at end of repository" -takeHeadRebaseRL (p :<: ps) - | Suspended rs :>: NilFL <- patchcontents (hopefully p) = (p, Sealed rs, ps) +takeHeadRebaseRL (ps :<: p) + | RebaseP _ rs <- hopefully p = (p, rs, ps) | otherwise = error "internal error: must have a suspended patch at end of repository" -takeHeadRebaseFL :: FL (PatchInfoAnd (Rebasing p)) wA wB - -> (PatchInfoAnd (Rebasing p) wB wB, - Sealed (FL (RebaseItem p) wB), - FL (PatchInfoAnd (Rebasing p)) wA wB) +takeHeadRebaseFL :: FL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB + -> (PatchInfoAnd ('RepoType 'IsRebase) p wB wB, + Suspended p wB wB, + FL (PatchInfoAnd ('RepoType 'IsRebase) p) wA wB) takeHeadRebaseFL ps = let (a, b, c) = takeHeadRebaseRL (reverseFL ps) in (a, b, reverseRL c) diff --git a/src/Darcs/Patch/Rebase/Container.hs b/src/Darcs/Patch/Rebase/Container.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Rebase/Container.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE UndecidableInstances, StandaloneDeriving #-} +module Darcs.Patch.Rebase.Container + ( Suspended(..) + , countToEdit, simplifyPush, simplifyPushes + , addFixupsToSuspended, removeFixupsFromSuspended + ) where + +import Prelude () +import Darcs.Prelude + +import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) ) +import Darcs.Patch.Effect ( Effect(..) ) +import Darcs.Patch.FileHunk ( IsHunk(..) ) +import Darcs.Patch.Format ( PatchListFormat(..) ) +import Darcs.Patch.Invert ( invert ) +import Darcs.Patch.Named ( Named ) +import Darcs.Patch.Patchy ( Commute(..), Apply(..), + ShowPatch(..), ReadPatch(..), + PatchInspect(..) + ) +import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, FromPrim(..), FromPrim(..) ) +import Darcs.Patch.Read ( bracketedFL ) +import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), namedToFixups ) +import Darcs.Patch.Rebase.Item ( RebaseItem(..) ) +import qualified Darcs.Patch.Rebase.Item as Item ( countToEdit, simplifyPush, simplifyPushes ) +import Darcs.Patch.Repair ( Check(..), Repair(..), RepairToFL(..) ) +import Darcs.Patch.Show ( ShowPatchBasic(..) ) +import Darcs.Patch.ReadMonads ( lexString, myLex' ) +import Darcs.Patch.Witnesses.Ordered +import Darcs.Patch.Witnesses.Sealed +import Darcs.Patch.Witnesses.Show + ( Show1(..), Show2(..) + , ShowDict(ShowDictClass) + ) +import Darcs.Util.Printer ( vcat, text, blueText, ($$), (<+>) ) +import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) ) + +import Control.Applicative ( (<|>) ) +import Control.Arrow ( (***), second ) +import Control.Monad ( when ) +import Data.Maybe ( catMaybes ) +import qualified Data.ByteString.Char8 as BC ( pack ) + + +-- TODO: move some of the docs of types to individual constructors +-- once http://trac.haskell.org/haddock/ticket/43 is fixed. + +-- |A patch that lives in a repository where a rebase is in +-- progress. Such a repository will consist of @Normal@ patches +-- along with exactly one @Suspended@ patch. +-- +-- Most rebase operations will require the @Suspended@ patch +-- to be at the end of the repository. +-- +-- @Normal@ represents a normal patch within a respository where a +-- rebase is in progress. @Normal p@ is given the same on-disk +-- representation as @p@, so a repository can be switched into +-- and out of rebasing mode simply by adding or removing a +-- @Suspended@ patch and setting the appropriate format flag. +-- +-- The single @Suspended@ patch contains the entire rebase +-- state, in the form of 'RebaseItem's. +-- +-- Note that the witnesses are such that the @Suspended@ +-- patch has no effect on the context of the rest of the +-- repository; in a sense the patches within it are +-- dangling off to one side from the main repository. +-- +-- See Note [Rebase representation] in the 'Darcs.Patch.Rebase' for +-- a discussion of the design choice to embed the rebase state in a +-- single patch. +data Suspended p wX wY where + Items :: FL (RebaseItem p) wX wY -> Suspended p wX wX + +deriving instance (Show2 p, Show2 (PrimOf p)) => Show (Suspended p wX wY) + +instance (Show2 p, Show2 (PrimOf p)) => Show1 (Suspended p wX) where + showDict1 = ShowDictClass + +instance (Show2 p, Show2 (PrimOf p)) => Show2 (Suspended p) where + showDict2 = ShowDictClass + +instance (PrimPatchBase p, PatchInspect p) => PatchInspect (Suspended p) where + listTouchedFiles (Items ps) = listTouchedFiles ps + hunkMatches f (Items ps) = hunkMatches f ps + +instance Effect (Suspended p) where + effect (Items _) = NilFL + +instance Conflict p => Conflict (Suspended p) where + resolveConflicts _ = [] + conflictedEffect _ = [] + +instance Apply p => Apply (Suspended p) where + type ApplyState (Suspended p) = ApplyState p + apply _ = return () + +instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Suspended p) where + showPatch (Items ps) + = blueText "rebase" <+> text "0.0" <+> blueText "{" + $$ vcat (mapFL showPatch ps) + $$ blueText "}" + +instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) => ShowPatch (Suspended p) where + + showContextPatch s = return $ showPatch s + + description s = showPatch s + + summary (Items ps) = summaryFL ps + + summaryFL ps = vcat (mapFL summary ps) + +instance PrimPatchBase p => PrimPatchBase (Suspended p) where + type PrimOf (Suspended p) = PrimOf p + +instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (Suspended p) where + readPatch' = + do lexString (BC.pack "rebase") + version <- myLex' + when (version /= BC.pack "0.0") $ error $ "can't handle rebase version " ++ show version + (lexString (BC.pack "{}") >> return (seal (Items NilFL))) + <|> + (unseal (Sealed . Items) <$> bracketedFL readPatch' '{' '}') + +instance Check p => Check (Suspended p) where + isInconsistent (Items ps) = + case catMaybes (mapFL isInconsistent ps) of + [] -> Nothing + xs -> Just (vcat xs) + +instance Apply p => Repair (Suspended p) where + applyAndTryToFix (Items ps) = + -- TODO: ideally we would apply ps in a sandbox to check the individual patches + -- are consistent with each other. + return . fmap (unlines *** Items) $ repairInternal ps + +instance Apply p => RepairToFL (Suspended p) where + applyAndTryToFixFL s = fmap (second $ (:>: NilFL)) <$> applyAndTryToFix s + +-- Just repair the internals of the patch, without applying it to anything +-- or checking against an external context. +-- Included for the internal implementation of applyAndTryToFixFL for Rebasing, +-- consider either generalising it for use everywhere, or removing once +-- the implementation works in a sandbox and thus can use the "full" Repair on the +-- contained patches. +class RepairInternalFL p where + repairInternalFL :: p wX wY -> Maybe ([String], FL p wX wY) + +class RepairInternal p where + repairInternal :: p wX wY -> Maybe ([String], p wX wY) + +instance RepairInternalFL p => RepairInternal (FL p) where + repairInternal NilFL = Nothing + repairInternal (x :>: ys) = + case (repairInternalFL x, repairInternal ys) of + (Nothing , Nothing) -> Nothing + (Just (e, rxs), Nothing) -> Just (e , rxs +>+ ys ) + (Nothing , Just (e', rys)) -> Just (e' , x :>: rys) + (Just (e, rxs), Just (e', rys)) -> Just (e ++ e', rxs +>+ rys) + +instance RepairInternalFL (RebaseItem p) where + repairInternalFL (ToEdit _) = Nothing + repairInternalFL (Fixup p) = fmap (second $ mapFL_FL Fixup) $ repairInternalFL p + +instance RepairInternalFL (RebaseFixup p) where + repairInternalFL (PrimFixup _) = Nothing + repairInternalFL (NameFixup _) = Nothing + +countToEdit :: Suspended p wX wY -> Int +countToEdit (Items ps) = Item.countToEdit ps + +onSuspended + :: (forall wZ . FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)) + -> Suspended p wY wY + -> Suspended p wX wX +onSuspended f (Items ps) = unseal Items (f ps) + +-- |add fixups for the name and effect of a patch to a 'Suspended' +addFixupsToSuspended + :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) + => Named p wX wY + -> Suspended p wY wY + -> Suspended p wX wX +addFixupsToSuspended p = simplifyPushes D.MyersDiff (namedToFixups p) + +-- |remove fixups (actually, add their inverse) for the name and effect of a patch to a 'Suspended' +removeFixupsFromSuspended + :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) + => Named p wX wY + -> Suspended p wX wX + -> Suspended p wY wY +removeFixupsFromSuspended p = simplifyPushes D.MyersDiff (invert (namedToFixups p)) + +simplifyPush + :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) + => D.DiffAlgorithm + -> RebaseFixup p wX wY + -> Suspended p wY wY + -> Suspended p wX wX +simplifyPush da fixups = onSuspended (Item.simplifyPush da fixups) + +simplifyPushes + :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) + => D.DiffAlgorithm + -> FL (RebaseFixup p) wX wY + -> Suspended p wY wY + -> Suspended p wX wX +simplifyPushes da fixups = onSuspended (Item.simplifyPushes da fixups) diff --git a/src/Darcs/Patch/Rebase/Fixup.hs b/src/Darcs/Patch/Rebase/Fixup.hs --- a/src/Darcs/Patch/Rebase/Fixup.hs +++ b/src/Darcs/Patch/Rebase/Fixup.hs @@ -6,9 +6,12 @@ module Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) , commuteNamedFixup, commuteFixupNamed, commuteNamedFixups - , flToNamesPrims + , flToNamesPrims, namedToFixups ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Commute ( Commute(..), selfCommuter ) import Darcs.Patch.CommuteFn ( totalCommuterIdFL ) @@ -19,7 +22,7 @@ import Darcs.Patch.Named ( Named(..), commuterNamedId, commuterIdNamed ) import Darcs.Patch.Prim ( PrimPatchBase, PrimOf ) import Darcs.Patch.Rebase.Name - ( RebaseName + ( RebaseName(..) , commuteNamedName, commuteNameNamed , commutePrimName, commuteNamePrim ) @@ -36,6 +39,9 @@ data RebaseFixup p wX wY where PrimFixup :: PrimOf p wX wY -> RebaseFixup p wX wY NameFixup :: RebaseName p wX wY -> RebaseFixup p wX wY + +namedToFixups :: Effect p => Named p wX wY -> FL (RebaseFixup p) wX wY +namedToFixups (NamedP p _ contents) = NameFixup (AddName p) :>: mapFL_FL PrimFixup (effect contents) instance Show2 (PrimOf p) => Show (RebaseFixup p wX wY) where showsPrec d (PrimFixup p) = diff --git a/src/Darcs/Patch/Rebase/Item.hs b/src/Darcs/Patch/Rebase/Item.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Rebase/Item.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE CPP, UndecidableInstances #-} +module Darcs.Patch.Rebase.Item + ( RebaseItem(..) + , simplifyPush, simplifyPushes + , countToEdit + ) where + +import Prelude () +import Darcs.Prelude + +import Darcs.Patch.Commute ( selfCommuter ) +import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) ) +import Darcs.Patch.Effect ( Effect(..) ) +import Darcs.Patch.FileHunk ( IsHunk(..) ) +import Darcs.Patch.Format ( PatchListFormat(..) ) +import Darcs.Patch.Named ( Named(..), commuterIdNamed ) +import Darcs.Patch.Patchy ( Invert(..), Commute(..), Apply(..) + , ShowPatch(..), ReadPatch(..) + , PatchInspect(..) + ) +import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, FromPrim(..), FromPrim(..), canonizeFL ) +import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) ) +import Darcs.Patch.Rebase.Name + ( RebaseName(..) + , commutePrimName, commuteNamePrim + , canonizeNamePair + ) +import Darcs.Patch.Repair ( Check(..) ) +import Darcs.Patch.Show ( ShowPatchBasic(..) ) +import Darcs.Patch.ReadMonads ( ParserM, lexString ) +import Darcs.Patch.Witnesses.Eq +import Darcs.Patch.Witnesses.Ordered +import Darcs.Patch.Witnesses.Sealed +import Darcs.Patch.Witnesses.Show + ( Show1(..), Show2(..), showsPrec2 + , ShowDict(ShowDictClass), appPrec + ) +import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) +import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) +import Darcs.Util.Printer ( vcat, blueText, ($$), (<+>) ) + +import Control.Applicative ( (<|>) ) +import qualified Data.ByteString as B ( ByteString ) +import qualified Data.ByteString.Char8 as BC ( pack ) + +#include "impossible.h" + +-- |A single item in the rebase state consists of either +-- a patch that is being edited, or a fixup that adjusts +-- the context so that a subsequent patch that is being edited +-- \"makes sense\". +-- +-- @ToEdit@ holds a patch that is being edited. The name ('PatchInfo') of +-- the patch will typically be the name the patch had before +-- it was added to the rebase state; if it is moved back +-- into the repository it must be given a fresh name to account +-- for the fact that it will not necessarily have the same +-- dependencies as the original patch. This is typically +-- done by changing the @Ignore-This@ junk. +-- +-- @Fixup@ adjusts the context so that a subsequent @ToEdit@ patch +-- is correct. Where possible, @Fixup@ changes are commuted +-- as far as possible into the rebase state, so any remaining +-- ones will typically cause a conflict when the @ToEdit@ patch +-- is moved back into the repository. +data RebaseItem p wX wY where + ToEdit :: Named p wX wY -> RebaseItem p wX wY + Fixup :: RebaseFixup p wX wY -> RebaseItem p wX wY + +instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseItem p wX wY) where + showsPrec d (ToEdit p) = + showParen (d > appPrec) $ showString "ToEdit " . showsPrec2 (appPrec + 1) p + showsPrec d (Fixup p) = + showParen (d > appPrec) $ showString "Fixup " . showsPrec2 (appPrec + 1) p + +instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseItem p wX) where + showDict1 = ShowDictClass + +instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseItem p) where + showDict2 = ShowDictClass + +countToEdit :: FL (RebaseItem p) wX wY -> Int +countToEdit NilFL = 0 +countToEdit (ToEdit _ :>: ps) = 1 + countToEdit ps +countToEdit (_ :>: ps) = countToEdit ps + +-- |Given a list of rebase items, try to push a new fixup as far as possible into +-- the list as possible, using both commutation and coalescing. If the fixup +-- commutes past all the 'ToEdit' patches then it is dropped entirely. +simplifyPush :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) + => D.DiffAlgorithm -> RebaseFixup p wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX) + +simplifyPush _ _f NilFL = Sealed NilFL + +simplifyPush da (PrimFixup f1) (Fixup (PrimFixup f2) :>: ps) + | IsEq <- isInverse = Sealed ps + | otherwise + = case commute (f1 :> f2) of + Nothing -> Sealed (mapFL_FL (Fixup . PrimFixup) (canonizeFL da (f1 :>: f2 :>: NilFL)) +>+ ps) + Just (f2' :> f1') -> mapSeal (Fixup (PrimFixup f2') :>:) (simplifyPush da (PrimFixup f1') ps) + where isInverse = invert f1 =\/= f2 + +simplifyPush da (PrimFixup f) (Fixup (NameFixup n) :>: ps) + = case commutePrimName (f :> n) of + n' :> f' -> mapSeal (Fixup (NameFixup n') :>:) (simplifyPush da (PrimFixup f') ps) + +simplifyPush da (PrimFixup f) (ToEdit e :>: ps) + = case commuterIdNamed selfCommuter (fromPrim f :> e) of + Nothing -> Sealed (Fixup (PrimFixup f) :>: ToEdit e :>: ps) + Just (e' :> f') -> mapSeal (ToEdit e' :>:) (simplifyPushes da (mapFL_FL PrimFixup (effect f')) ps) + +simplifyPush da (NameFixup n1) (Fixup (NameFixup n2) :>: ps) + | IsEq <- isInverse = Sealed ps + | otherwise + = case commute (n1 :> n2) of + Nothing -> Sealed (mapFL_FL (Fixup . NameFixup) (canonizeNamePair (n1 :> n2)) +>+ ps) + Just (n2' :> n1') -> mapSeal (Fixup (NameFixup n2') :>:) (simplifyPush da (NameFixup n1') ps) + where isInverse = invert n1 =\/= n2 + +simplifyPush da (NameFixup n) (Fixup (PrimFixup f) :>: ps) = + case commuteNamePrim (n :> f) of + f' :> n' -> mapSeal (Fixup (PrimFixup f') :>:) (simplifyPush da (NameFixup n') ps) + +simplifyPush da (NameFixup (AddName an)) (p@(ToEdit (NamedP pn deps _)) :>: ps) + | an == pn = impossible + | an `elem` deps = Sealed (Fixup (NameFixup (AddName an)) :>: p :>: ps) + | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (AddName an)) ps) +simplifyPush da (NameFixup (DelName dn)) (p@(ToEdit (NamedP pn deps _)) :>: ps) + -- this case can arise if a patch is suspended then a fresh copy is pulled from another repo + | dn == pn = Sealed (Fixup (NameFixup (DelName dn)) :>: p :>: ps) + | dn `elem` deps = impossible + | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (DelName dn)) ps) +simplifyPush da (NameFixup (Rename old new)) (p@(ToEdit (NamedP pn deps body)) :>: ps) + | old == pn = impossible + | new == pn = impossible + | old `elem` deps = impossible + | new `elem` deps = + let newdeps = map (\dep -> if new == dep then old else dep) deps + in mapSeal (ToEdit (NamedP pn newdeps (unsafeCoerceP body)) :>:) (simplifyPush da (NameFixup (Rename old new)) ps) + | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (Rename old new)) ps) + +-- |Like 'simplifyPush' but for a list of fixups. +simplifyPushes :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) + => D.DiffAlgorithm -> FL (RebaseFixup p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX) +simplifyPushes _ NilFL ps = Sealed ps +simplifyPushes da (f :>: fs) ps = unseal (simplifyPush da f) (simplifyPushes da fs ps) + + +instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseItem p) where + showPatch (ToEdit p) = blueText "rebase-toedit" <+> blueText "(" $$ showPatch p $$ blueText ")" + showPatch (Fixup (PrimFixup p)) = blueText "rebase-fixup" <+> blueText "(" $$ showPatch p $$ blueText ")" + showPatch (Fixup (NameFixup p)) = blueText "rebase-name" <+> blueText "(" $$ showPatch p $$ blueText ")" + +instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) + => ShowPatch (RebaseItem p) where + + summary (ToEdit p) = summary p + summary (Fixup (PrimFixup p)) = summary p + summary (Fixup (NameFixup n)) = summary n + summaryFL ps = vcat (mapFL summary ps) -- TODO sort out summaries properly, considering expected conflicts + + +instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (RebaseItem p) where + readPatch' = mapSeal ToEdit <$> readWith (BC.pack "rebase-toedit") <|> + mapSeal (Fixup . PrimFixup) <$> readWith (BC.pack "rebase-fixup" ) <|> + mapSeal (Fixup . NameFixup) <$> readWith (BC.pack "rebase-name" ) + where readWith :: forall m q wX . (ParserM m, ReadPatch q) => B.ByteString -> m (Sealed (q wX)) + readWith str = do lexString str + lexString (BC.pack "(") + res <- readPatch' + lexString (BC.pack ")") + return res + +instance Check p => Check (RebaseItem p) where + isInconsistent (Fixup _) = Nothing + isInconsistent (ToEdit p) = isInconsistent p + +instance (PrimPatchBase p, PatchInspect p) => PatchInspect (RebaseItem p) where + listTouchedFiles (ToEdit p) = listTouchedFiles p + listTouchedFiles (Fixup p) = listTouchedFiles p + + hunkMatches f (ToEdit p) = hunkMatches f p + hunkMatches f (Fixup p) = hunkMatches f p diff --git a/src/Darcs/Patch/Rebase/Name.hs b/src/Darcs/Patch/Rebase/Name.hs --- a/src/Darcs/Patch/Rebase/Name.hs +++ b/src/Darcs/Patch/Rebase/Name.hs @@ -7,8 +7,12 @@ ( RebaseName(..) , commuteNamePrim, commutePrimName , commuteNameNamed, commuteNamedName + , canonizeNamePair ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.CommuteFn ( CommuteFn ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.Info ( PatchInfo, isInverted, showPatchInfo, readPatchInfo ) @@ -203,4 +207,10 @@ | otherwise = let newdeps = map (\dep -> if old == dep then new else dep) deps in Just (Rename old new :> NamedP pn newdeps (unsafeCoerceP body)) + +canonizeNamePair :: (RebaseName p :> RebaseName p) wX wY -> FL (RebaseName p) wX wY +canonizeNamePair (AddName n :> Rename old new) | n == old = AddName new :>: NilFL +canonizeNamePair (Rename old new :> DelName n) | n == new = DelName old :>: NilFL +canonizeNamePair (Rename old1 new1 :> Rename old2 new2) | new1 == old2 = Rename old1 new2 :>: NilFL +canonizeNamePair (n1 :> n2) = n1 :>: n2 :>: NilFL diff --git a/src/Darcs/Patch/Rebase/NameHack.hs b/src/Darcs/Patch/Rebase/NameHack.hs deleted file mode 100644 --- a/src/Darcs/Patch/Rebase/NameHack.hs +++ /dev/null @@ -1,23 +0,0 @@ --- Copyright (C) 2009-2012 Ganesh Sittampalam --- --- BSD3 -module Darcs.Patch.Rebase.NameHack - ( NameHack(..) - ) where - -import Darcs.Patch.Info ( PatchInfo ) -import Darcs.Patch.Witnesses.Ordered ( FL ) -import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) - --- |When commuting a @Normal@ patch past a @Suspended@ one, we need to adjust the --- internals of the @Suspended@ one to take account of the effect of the @Normal@ patch. --- This includes the name of the @Normal@ patch - but the layering is such that we --- are actually commuting patches of type @Named (Rebasing p)@ - i.e. @Rebasing p@ --- doesn't actually contain the name. We therefore need to add a hook to the @Commute@ --- instances for @Named@ which @Rebasing@ can then implement. --- --- There is a default so that other patch types only need to declare the instance. -class NameHack p where - nameHack :: D.DiffAlgorithm -> Maybe (PatchInfo -> FL p wX wY -> FL p wX wY, PatchInfo -> FL p wW wZ -> FL p wW wZ) - nameHack = \_ -> Nothing - diff --git a/src/Darcs/Patch/Rebase/Recontext.hs b/src/Darcs/Patch/Rebase/Recontext.hs deleted file mode 100644 --- a/src/Darcs/Patch/Rebase/Recontext.hs +++ /dev/null @@ -1,45 +0,0 @@ --- Copyright (C) 2012 Ganesh Sittampalam --- --- BSD3 -module Darcs.Patch.Rebase.Recontext - ( - RecontextRebase(..) - , RecontextRebase1(..) - , RecontextRebase2(..) - ) where - -import Darcs.Patch.Named ( Named ) -import Darcs.Patch.Rebase.Fixup ( RebaseFixup ) -import Darcs.Patch.Witnesses.Eq ( EqCheck ) -import Darcs.Patch.Witnesses.Ordered ( FL ) - --- |Check whether a given patch is a suspended rebase patch, and if so provide --- evidence that the start and end contexts are the same (from the point of view --- of the containing repo), and return a function that produces a new version --- with some fixups added. --- --- Nested in a type to avoid needing an impredicative argument to 'Maybe'. -newtype RecontextRebase1 p = - RecontextRebase1 { - recontextFunc1 :: forall wY wZ . Named p wY wZ -> (EqCheck wY wZ, RecontextRebase2 p wY wZ) - } - --- |Return a suspended patch with the given fixups added. --- --- Nested in a type to avoid needing an impredicative argument to a tuple. -newtype RecontextRebase2 p wY wZ = - RecontextRebase2 { - recontextFunc2 :: forall wX . FL (RebaseFixup p) wX wY -> IO (Named p wX wX) - } - --- |Some non-rebase code needs to manipulate the rebase state if one exists. --- This class provides the hook for them to do so without needing to explicitly --- detect that there is a rebase state: 'recontextRebase' abstracts out that --- information. --- --- The hook is used in amend-record - look there for an explanation of how. --- --- There is a default so that other patch types only need to declare the instance. -class RecontextRebase p where - recontextRebase :: Maybe (RecontextRebase1 p) - recontextRebase = Nothing diff --git a/src/Darcs/Patch/Rebase/Viewing.hs b/src/Darcs/Patch/Rebase/Viewing.hs --- a/src/Darcs/Patch/Rebase/Viewing.hs +++ b/src/Darcs/Patch/Rebase/Viewing.hs @@ -11,6 +11,9 @@ , RebaseChange(..), toRebaseChanges ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Commute ( selfCommuter ) import Darcs.Patch.CommuteFn ( CommuteFn, commuterIdFL, commuterRLId, MergeFn , totalCommuterIdFL @@ -26,14 +29,19 @@ import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Invert ( invertFL, invertRL ) import Darcs.Patch.Matchable ( Matchable ) -import Darcs.Patch.MaybeInternal ( MaybeInternal(..) ) import Darcs.Patch.Merge ( Merge(..), selfMerger ) import Darcs.Patch.Named ( Named(..), namepatch, infopatch , mergerIdNamed - , adddeps, getdeps + , getdeps , patch2patchinfo, patchcontents ) +import Darcs.Patch.Named.Wrapped + ( WrappedNamed(..) + ) +import qualified Darcs.Patch.Named.Wrapped as Wrapped + ( infopatch, adddeps + ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia ) import Darcs.Patch.Patchy ( Invert(..), Commute(..), Patchy, Apply(..), @@ -43,16 +51,15 @@ import Darcs.Patch.Prim ( PrimPatch, PrimPatchBase, PrimOf, FromPrim(..), FromPrims(..) ) -import Darcs.Patch.Rebase - ( Rebasing(..), RebaseItem(..) - ) +import Darcs.Patch.Rebase.Container ( Suspended(..) ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) , commuteFixupNamed, commuteNamedFixups , flToNamesPrims ) +import Darcs.Patch.Rebase.Item ( RebaseItem(..) ) import Darcs.Patch.Rebase.Name ( RebaseName(..) ) -import Darcs.Patch.Rebase.NameHack ( NameHack(..) ) +import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..) ) import Darcs.Patch.Summary ( plainSummary ) import Darcs.Patch.Witnesses.Eq @@ -67,8 +74,6 @@ import Darcs.Util.Printer ( ($$), redText, empty, vcat ) import Darcs.Util.Show ( appPrec ) -import Prelude hiding ( pi ) -import Control.Applicative ( (<$>) ) import Data.List ( nub, (\\) ) import Data.Maybe ( fromMaybe ) @@ -130,14 +135,14 @@ showString " " . showsPrec2 (appPrec + 1) changes -- |Get hold of the 'PatchInfoAnd' patch inside a 'RebaseSelect'. -rsToPia :: RebaseSelect p wX wY -> Sealed2 (PatchInfoAnd p) -rsToPia (RSFwd _ toEdit) = Sealed2 (n2pia toEdit) -rsToPia (RSRev _ toEdit) = Sealed2 (n2pia toEdit) +rsToPia :: RebaseSelect p wX wY -> Sealed2 (PatchInfoAnd ('RepoType 'NoRebase) p) +rsToPia (RSFwd _ toEdit) = Sealed2 (n2pia (NormalP toEdit)) +rsToPia (RSRev _ toEdit) = Sealed2 (n2pia (NormalP toEdit)) instance PrimPatchBase p => PrimPatchBase (RebaseSelect p) where type PrimOf (RebaseSelect p) = PrimOf p -instance (PrimPatchBase p, PatchListFormat p, Conflict p, FromPrim p, Effect p, CommuteNoConflicts p, IsHunk p, Patchy p, ApplyState p ~ ApplyState (PrimOf p), NameHack p) +instance (PrimPatchBase p, PatchListFormat p, Conflict p, FromPrim p, Effect p, CommuteNoConflicts p, IsHunk p, Patchy p, ApplyState p ~ ApplyState (PrimOf p)) => Patchy (RebaseSelect p) instance ( PrimPatchBase p, Apply p, ApplyState p ~ ApplyState (PrimOf p) @@ -167,17 +172,15 @@ resolveConflicts (RSFwd _ toedit) = resolveConflicts toedit resolveConflicts (RSRev{}) = impossible + conflictedEffect (RSFwd _ toedit) = conflictedEffect toedit + conflictedEffect (RSRev{}) = impossible + -- newtypes to help the type-checker with the 'changeAsMerge' abstraction newtype ResolveConflictsResult p wY = ResolveConflictsResult { getResolveConflictsResult :: [[Sealed (FL (PrimOf p) wY)]] } -newtype ListConflictedFilesResult (p :: * -> * -> *) wY = - ListConflictedFilesResult { - getListConflictedFilesResult :: [FilePath] - } - newtype ConflictedEffectResult p wY = ConflictedEffectResult { getConflictedEffectResult :: [IsConflictedPrim (PrimOf p)] @@ -208,8 +211,6 @@ resolveConflicts = getResolveConflictsResult . changeAsMerge (ResolveConflictsResult . resolveConflicts) - listConflictedFiles = - getListConflictedFilesResult . changeAsMerge (ListConflictedFilesResult . listConflictedFiles) conflictedEffect = getConflictedEffectResult . changeAsMerge (ConflictedEffectResult . conflictedEffect) @@ -227,7 +228,7 @@ instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseSelect p) where showPatch (RSFwd fixups toedit) = - showPatch (Suspended (mapFL_FL Fixup fixups +>+ ToEdit toedit :>: NilFL)) + showPatch (Items (mapFL_FL Fixup fixups +>+ ToEdit toedit :>: NilFL)) showPatch (RSRev {}) = impossible instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) @@ -298,20 +299,20 @@ toRebaseChanges :: PrimPatchBase p => FL (RebaseItem p) wX wY - -> FL (PatchInfoAnd (RebaseChange p)) wX wY + -> FL (PatchInfoAnd ('RepoType 'IsRebase) (RebaseChange p)) wX wY toRebaseChanges = mapFL_FL toChange . toRebaseSelect -toChange :: RebaseSelect p wX wY -> PatchInfoAnd (RebaseChange p) wX wY +toChange :: RebaseSelect p wX wY -> PatchInfoAnd rt (RebaseChange p) wX wY toChange (RSFwd fixups named) = n2pia $ - flip adddeps (getdeps named) $ - infopatch (patch2patchinfo named) $ + flip Wrapped.adddeps (getdeps named) $ + Wrapped.infopatch (patch2patchinfo named) $ (:>: NilFL) $ RCFwd fixups (patchcontents named) toChange (RSRev fixups named) = n2pia $ - flip adddeps (getdeps named) $ - infopatch (patch2patchinfo named) $ + flip Wrapped.adddeps (getdeps named) $ + Wrapped.infopatch (patch2patchinfo named) $ (:>: NilFL) $ RCRev fixups (patchcontents named) @@ -335,7 +336,7 @@ _ =\/= _ = impossible -instance (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p, NameHack p) => Commute (RebaseSelect p) where +instance (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p) => Commute (RebaseSelect p) where commute (RSFwd {} :> RSRev {}) = impossible commute (RSRev {} :> RSFwd {}) = impossible commute (RSRev fixups1 edit1 :> RSRev fixups2 edit2) = @@ -370,12 +371,12 @@ -- |Split a list of rebase patches into those that will -- have conflicts if unsuspended and those that won't. partitionUnconflicted - :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p, NameHack p) + :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p) => FL (RebaseSelect p) wX wY -> (FL (RebaseSelect p) :> RL (RebaseSelect p)) wX wY partitionUnconflicted = partitionUnconflictedAcc NilRL -partitionUnconflictedAcc :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p, NameHack p) +partitionUnconflictedAcc :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p) => RL (RebaseSelect p) wX wY -> FL (RebaseSelect p) wY wZ -> (FL (RebaseSelect p) :> RL (RebaseSelect p)) wX wZ partitionUnconflictedAcc right NilFL = NilFL :> right @@ -384,7 +385,7 @@ Just (p'@(RSFwd NilFL _) :> right') -> case partitionUnconflictedAcc right' ps of left' :> right'' -> (p' :>: left') :> right'' - _ -> partitionUnconflictedAcc (p :<: right) ps + _ -> partitionUnconflictedAcc (right :<: p) ps -- | A patch, together with a list of patch names that it used to depend on, -- but were lost during the rebasing process. The UI can use this information @@ -552,14 +553,11 @@ instance CommuteNoConflicts (RebaseChange p) where commuteNoConflicts _ = impossible -instance MaybeInternal (RebaseChange p) - instance IsHunk p => IsHunk (RebaseChange p) where -- RebaseChange is a compound patch, so it doesn't really make sense to -- ask whether it's a hunk. TODO: get rid of the need for this. isHunk _ = Nothing -instance NameHack (RebaseChange p) instance PatchListFormat (RebaseChange p) instance ( PrimPatchBase p, Apply p, Invert p diff --git a/src/Darcs/Patch/RegChars.hs b/src/Darcs/Patch/RegChars.hs --- a/src/Darcs/Patch/RegChars.hs +++ b/src/Darcs/Patch/RegChars.hs @@ -19,6 +19,9 @@ module Darcs.Patch.RegChars ( regChars, ) where +import Prelude () +import Darcs.Prelude + (&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool (&&&) a b c = a c && b c diff --git a/src/Darcs/Patch/Repair.hs b/src/Darcs/Patch/Repair.hs --- a/src/Darcs/Patch/Repair.hs +++ b/src/Darcs/Patch/Repair.hs @@ -2,6 +2,9 @@ ( Repair(..), RepairToFL(..), mapMaybeSnd, Check(..) ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.ApplyMonad ( ApplyMonad ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), mapFL, mapRL, (+>+) ) @@ -19,13 +22,13 @@ -- 'Repair' is implemented by collections of patches (FL, Named, PatchInfoAnd) that -- might need repairing. class Repair p where - applyAndTryToFix :: ApplyMonad m (ApplyState p) => p wX wY -> m (Maybe (String, p wX wY)) + applyAndTryToFix :: ApplyMonad (ApplyState p) m => p wX wY -> m (Maybe (String, p wX wY)) --- |'RepairToFL' is implemented by single patches that can be repaired (Prim, Patch, RealPatch) +-- |'RepairToFL' is implemented by single patches that can be repaired (Prim, Patch, RepoPatchV2) -- There is a default so that patch types with no current legacy problems don't need to -- have an implementation. class Apply p => RepairToFL p where - applyAndTryToFixFL :: ApplyMonad m (ApplyState p) => p wX wY -> m (Maybe (String, FL p wX wY)) + applyAndTryToFixFL :: ApplyMonad (ApplyState p) m => p wX wY -> m (Maybe (String, FL p wX wY)) applyAndTryToFixFL p = do apply p; return Nothing mapMaybeSnd :: (a -> b) -> Maybe (c, a) -> Maybe (c, b) diff --git a/src/Darcs/Patch/RepoPatch.hs b/src/Darcs/Patch/RepoPatch.hs --- a/src/Darcs/Patch/RepoPatch.hs +++ b/src/Darcs/Patch/RepoPatch.hs @@ -7,14 +7,11 @@ import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Matchable ( Matchable ) -import Darcs.Patch.MaybeInternal ( MaybeInternal ) import Darcs.Patch.Merge ( Merge ) import Darcs.Patch.Patchy ( Patchy ) import Darcs.Patch.Patchy.Instances () import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, FromPrim ) import Darcs.Patch.Read ( ReadPatch ) -import Darcs.Patch.Rebase.NameHack ( NameHack ) -import Darcs.Patch.Rebase.Recontext ( RecontextRebase ) import Darcs.Patch.Repair ( RepairToFL, Check ) import Darcs.Patch.Show ( ShowPatch ) @@ -23,7 +20,6 @@ FromPrim p, Conflict p, CommuteNoConflicts p, Check p, RepairToFL p, PatchListFormat p, PrimPatchBase p, Patchy (PrimOf p), IsHunk (PrimOf p), - MaybeInternal p, RecontextRebase p, NameHack p, Matchable p ) => RepoPatch p diff --git a/src/Darcs/Patch/RepoType.hs b/src/Darcs/Patch/RepoType.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/RepoType.hs @@ -0,0 +1,48 @@ +module Darcs.Patch.RepoType + ( RepoType(..), IsRepoType(..), SRepoType(..) + , RebaseType(..), IsRebaseType, RebaseTypeOf, SRebaseType(..) + ) where + +-- |This type is intended to be used as a phantom type via +-- the 'DataKinds' extension, normally as part of 'RepoType'. +-- Indicates whether or not a rebase is in progress. +data RebaseType = IsRebase | NoRebase + +-- |A reflection of 'RebaseType' at the value level so that +-- code can explicitly switch on it. +data SRebaseType (rebaseType :: RebaseType) where + SIsRebase :: SRebaseType 'IsRebase + SNoRebase :: SRebaseType 'NoRebase + +class IsRebaseType (rebaseType :: RebaseType) where + -- |Reflect 'RebaseType' to the value level so that + -- code can explicitly switch on it. + singletonRebaseType :: SRebaseType rebaseType + +instance IsRebaseType 'IsRebase where + singletonRebaseType = SIsRebase + +instance IsRebaseType 'NoRebase where + singletonRebaseType = SNoRebase + +-- |This type is intended to be used as a phantom type via the 'DataKinds' +-- extension. It tracks different types of repositories, e.g. to +-- indicate when a rebase is in progress. +data RepoType = RepoType { rebaseType :: RebaseType } + +-- |Extract the 'RebaseType' from a 'RepoType' +type family RebaseTypeOf (rt :: RepoType) :: RebaseType +type instance RebaseTypeOf ('RepoType rebaseType) = rebaseType + +class IsRepoType (rt :: RepoType) where + -- |Reflect 'RepoType' to the value level so that + -- code can explicitly switch on it. + singletonRepoType :: SRepoType rt + +-- |A reflection of 'RepoType' at the value level so that +-- code can explicitly switch on it. +data SRepoType (repoType :: RepoType) where + SRepoType :: SRebaseType rebaseType -> SRepoType ('RepoType rebaseType) + +instance IsRebaseType rebaseType => IsRepoType ('RepoType rebaseType) where + singletonRepoType = SRepoType singletonRebaseType diff --git a/src/Darcs/Patch/Set.hs b/src/Darcs/Patch/Set.hs --- a/src/Darcs/Patch/Set.hs +++ b/src/Darcs/Patch/Set.hs @@ -28,8 +28,12 @@ , appendPSFL , newset2RL , newset2FL + , patchSetfMap ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info ) import Darcs.Patch.Witnesses.Sealed ( Sealed ) @@ -43,7 +47,7 @@ -- |'Origin' is a type used to represent the initial context of a repo. data Origin -type SealedPatchSet p wStart = Sealed ((PatchSet p) wStart) +type SealedPatchSet rt p wStart = Sealed ((PatchSet rt p) wStart) -- |The patches in a repository are stored in chunks broken up at \"clean\" -- tags. A tag is clean if the only patches before it in the current @@ -52,73 +56,76 @@ -- -- A 'PatchSet' represents a repo's history as the list of patches since the -- last clean tag, and then a list of patch lists each delimited by clean tags. -data PatchSet p wStart wY where - PatchSet :: RL (PatchInfoAnd p) wX wY -> RL (Tagged p) wStart wX - -> PatchSet p wStart wY +data PatchSet rt p wStart wY where + PatchSet :: RL (Tagged rt p) wStart wX -> RL (PatchInfoAnd rt p) wX wY + -> PatchSet rt p wStart wY -deriving instance Show2 p => Show (PatchSet p wStart wY) +deriving instance Show2 p => Show (PatchSet rt p wStart wY) -instance Show2 p => Show1 (PatchSet p wStart) where +instance Show2 p => Show1 (PatchSet rt p wStart) where showDict1 = ShowDictClass -instance Show2 p => Show2 (PatchSet p) where +instance Show2 p => Show2 (PatchSet rt p) where showDict2 = ShowDictClass -emptyPatchSet :: PatchSet p wX wX +emptyPatchSet :: PatchSet rt p wX wX emptyPatchSet = PatchSet NilRL NilRL -- |A 'Tagged' is a single chunk of a 'PatchSet'. -- It has a 'PatchInfo' representing a clean tag, -- the hash of the previous inventory (if it exists), -- and the list of patches since that previous inventory. -data Tagged p wX wZ where - Tagged :: PatchInfoAnd p wY wZ -> Maybe String - -> RL (PatchInfoAnd p) wX wY -> Tagged p wX wZ +data Tagged rt p wX wZ where + Tagged :: PatchInfoAnd rt p wY wZ -> Maybe String + -> RL (PatchInfoAnd rt p) wX wY -> Tagged rt p wX wZ -deriving instance Show2 p => Show (Tagged p wX wZ) +deriving instance Show2 p => Show (Tagged rt p wX wZ) -instance Show2 p => Show1 (Tagged p wX) where +instance Show2 p => Show1 (Tagged rt p wX) where showDict1 = ShowDictClass -instance Show2 p => Show2 (Tagged p) where +instance Show2 p => Show2 (Tagged rt p) where showDict2 = ShowDictClass -- |'newset2RL' takes a 'PatchSet' and returns an equivalent, linear 'RL' of -- patches. -newset2RL :: PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX -newset2RL (PatchSet ps ts) = ps +<+ concatRL (mapRL_RL ts2rl ts) +newset2RL :: PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX +newset2RL (PatchSet ts ps) = concatRL (mapRL_RL ts2rl ts) +<+ ps where - ts2rl :: Tagged p wY wZ -> RL (PatchInfoAnd p) wY wZ - ts2rl (Tagged t _ ps2) = t :<: ps2 + ts2rl :: Tagged rt p wY wZ -> RL (PatchInfoAnd rt p) wY wZ + ts2rl (Tagged t _ ps2) = ps2 :<: t -- |'newset2FL' takes a 'PatchSet' and returns an equivalent, linear 'FL' of -- patches. -newset2FL :: PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX +newset2FL :: PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX newset2FL = reverseRL . newset2RL -- |'appendPSFL' takes a 'PatchSet' and a 'FL' of patches that "follow" the -- PatchSet, and concatenates the patches into the PatchSet. -appendPSFL :: PatchSet p wStart wX -> FL (PatchInfoAnd p) wX wY - -> PatchSet p wStart wY -appendPSFL (PatchSet ps ts) newps = PatchSet (reverseFL newps +<+ ps) ts +appendPSFL :: PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wX wY + -> PatchSet rt p wStart wY +appendPSFL (PatchSet ts ps) newps = PatchSet ts (ps +<+ reverseFL newps) -- |Runs a progress action for each tag and patch in a given PatchSet, using -- the passed progress message. Does not alter the PatchSet. -progressPatchSet :: String -> PatchSet p wStart wX -> PatchSet p wStart wX -progressPatchSet k (PatchSet ps ts) = - PatchSet (mapRL_RL prog ps) $ mapRL_RL progressTagged ts +progressPatchSet :: String -> PatchSet rt p wStart wX -> PatchSet rt p wStart wX +progressPatchSet k (PatchSet ts ps) = + PatchSet (mapRL_RL progressTagged ts) (mapRL_RL prog ps) where prog = progress k - progressTagged :: Tagged p wY wZ -> Tagged p wY wZ + progressTagged :: Tagged rt p wY wZ -> Tagged rt p wY wZ progressTagged (Tagged t h tps) = Tagged (prog t) h (mapRL_RL prog tps) -- |'tags' returns the PatchInfos corresponding to the tags of a given -- 'PatchSet'. -tags :: PatchSet p wStart wX -> [PatchInfo] -tags (PatchSet _ ts) = mapRL taggedTagInfo ts +tags :: PatchSet rt p wStart wX -> [PatchInfo] +tags (PatchSet ts _) = mapRL taggedTagInfo ts where - taggedTagInfo :: Tagged p wY wZ -> PatchInfo + taggedTagInfo :: Tagged rt p wY wZ -> PatchInfo taggedTagInfo (Tagged t _ _) = info t + +patchSetfMap:: (forall wW wZ . PatchInfoAnd rt p wW wZ -> IO a) -> PatchSet rt p wW' wZ' -> IO [a] +patchSetfMap f = sequence . mapRL f . newset2RL diff --git a/src/Darcs/Patch/Show.hs b/src/Darcs/Patch/Show.hs --- a/src/Darcs/Patch/Show.hs +++ b/src/Darcs/Patch/Show.hs @@ -24,10 +24,13 @@ , formatFileName ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( pi ) import Darcs.Patch.Apply ( ApplyState ) -import Darcs.Patch.ApplyMonad ( ApplyMonadTrans, ApplyMonad ) +import Darcs.Patch.ApplyMonad ( ApplyMonad ) import Darcs.Patch.Format ( FileNameFormat(..) ) import Darcs.Patch.Info ( PatchInfo, showPatchInfo ) import Darcs.Patch.Witnesses.Ordered ( FL ) @@ -54,8 +57,8 @@ -- used for instance before putting it into a bundle. As this -- unified context is not included in patch representation, this -- requires access to the tree. - showContextPatch :: (Monad m, ApplyMonadTrans m (ApplyState p), - ApplyMonad m (ApplyState p)) + showContextPatch :: (Monad m, + ApplyMonad (ApplyState p) m) => p wX wY -> m Doc showContextPatch p = return $ showPatch p diff --git a/src/Darcs/Patch/Split.hs b/src/Darcs/Patch/Split.hs --- a/src/Darcs/Patch/Split.hs +++ b/src/Darcs/Patch/Split.hs @@ -24,6 +24,9 @@ module Darcs.Patch.Split ( Splitter(..), rawSplitter, noSplitter, primSplitter, reversePrimSplitter ) where +import Prelude () +import Darcs.Prelude + import Data.List ( intersperse ) import Darcs.Patch.Witnesses.Ordered @@ -62,7 +65,7 @@ -- splitters for Prim etc, and the generality doesn't cost anything. data Splitter p = Splitter { - applySplitter :: forall wX wY . D.DiffAlgorithm -> p wX wY + applySplitter :: forall wX wY . p wX wY -> Maybe (B.ByteString, B.ByteString -> Maybe (FL p wX wY)) -- canonization is needed to undo the effects of splitting @@ -74,7 +77,7 @@ -- we might record (or whatever) a rather strange looking patch. -- This hook allows the splitter to provide an appropriate -- function for doing this. - ,canonizeSplit :: forall wX wY . D.DiffAlgorithm -> FL p wX wY + ,canonizeSplit :: forall wX wY . FL p wX wY -> FL p wX wY } @@ -96,19 +99,19 @@ rawSplitter :: (ShowPatch p, ReadPatch p, Invert p) => Splitter p rawSplitter = Splitter { applySplitter = - \_ p -> Just (renderPS Standard . showPatch $ p, + \p -> Just (renderPS Standard . showPatch $ p, \str -> case parseStrictly readPatch' str of Just (Sealed res, _) -> Just (withEditedHead p res) _ -> Nothing ) - ,canonizeSplit = \_ b -> id b + ,canonizeSplit = id } -- |Never splits. In other code we normally pass around Maybe Splitter instead of using this -- as the default, because it saves clients that don't care about splitting from having to -- import this module just to get noSplitter. noSplitter :: Splitter p -noSplitter = Splitter { applySplitter = \_ -> const Nothing, canonizeSplit = \_ b -> id b } +noSplitter = Splitter { applySplitter = const Nothing, canonizeSplit = id } doPrimSplit :: PrimPatch prim => D.DiffAlgorithm -> prim wX wY @@ -119,7 +122,7 @@ [ "Interactive hunk edit:" , " - Edit the section marked 'AFTER'" , " - Arbitrary editing is supported" - , " - This will only affect the patch, not your working copy" + , " - This will only affect the patch, not your working tree" , " - Hints:" , " - To split added text, delete the part you want to postpone" , " - To split removed text, copy back the part you want to retain" @@ -161,9 +164,9 @@ -- |Split a primitive hunk patch up -- by allowing the user to edit both the before and after lines, then insert fixup patches -- to clean up the mess. -primSplitter :: PrimPatch p => Splitter p -primSplitter = Splitter { applySplitter = doPrimSplit - , canonizeSplit = canonizeFL } +primSplitter :: PrimPatch p => D.DiffAlgorithm -> Splitter p +primSplitter da = Splitter { applySplitter = doPrimSplit da + , canonizeSplit = canonizeFL da } doReversePrimSplit :: PrimPatch prim => D.DiffAlgorithm -> prim wX wY -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim wX wY)) @@ -178,7 +181,7 @@ map BC.pack [ "Interactive hunk edit:" , " - Edit the section marked 'AFTER' (representing the state to which you'll revert)" , " - Arbitrary editing is supported" - , " - Your working copy will be returned to the 'AFTER' state" + , " - Your working tree will be returned to the 'AFTER' state" , " - Do not touch the 'BEFORE' section" , " - Hints:" , " - To revert only a part of a text addition, delete the part you want to get rid of" @@ -186,6 +189,6 @@ , "" ] -reversePrimSplitter :: PrimPatch prim => Splitter prim -reversePrimSplitter = Splitter { applySplitter = doReversePrimSplit - , canonizeSplit = canonizeFL} +reversePrimSplitter :: PrimPatch prim => D.DiffAlgorithm -> Splitter prim +reversePrimSplitter da = Splitter { applySplitter = doReversePrimSplit da + , canonizeSplit = canonizeFL da } diff --git a/src/Darcs/Patch/Summary.hs b/src/Darcs/Patch/Summary.hs --- a/src/Darcs/Patch/Summary.hs +++ b/src/Darcs/Patch/Summary.hs @@ -3,7 +3,10 @@ xmlSummary ) where -import Darcs.Util.Path ( fn2fp ) +import Prelude () +import Darcs.Prelude + +import Darcs.Util.Path ( fn2fp, FileName ) import Darcs.Patch.Conflict ( Conflict(..), IsConflictedPrim(IsC), ConflictState(..) ) import Darcs.Patch.Effect ( Effect ) import Darcs.Patch.Prim.Class ( PrimDetails(..), PrimPatchBase ) @@ -19,8 +22,13 @@ plainSummaryPrim :: PrimDetails prim => prim wX wY -> Doc plainSummaryPrim = vcat . map (summChunkToLine False) . genSummary . (:[]) . IsC Okay -plainSummaryPrims :: PrimDetails prim => Bool -> FL prim wX wY -> Doc -plainSummaryPrims machineReadable = vcat . map (summChunkToLine machineReadable). genSummary . mapFL (IsC Okay) +plainSummaryPrims :: PrimDetails prim => Bool -> [FileName] -> FL prim wX wY -> Doc +plainSummaryPrims machineReadable conflicting = + vcat . map (summChunkToLine machineReadable . markConflict) . genSummary . mapFL (IsC Okay) + where + markConflict (SummChunk sf@(SummFile _ sfFn _ _ _) _) + | sfFn `elem` conflicting = SummChunk sf Conflicted + markConflict sc = sc plainSummary :: (Conflict e, Effect e, PrimPatchBase e) => e wX wY -> Doc plainSummary = vcat . map (summChunkToLine False) . genSummary . conflictedEffect diff --git a/src/Darcs/Patch/SummaryData.hs b/src/Darcs/Patch/SummaryData.hs --- a/src/Darcs/Patch/SummaryData.hs +++ b/src/Darcs/Patch/SummaryData.hs @@ -1,5 +1,8 @@ module Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) ) where +import Prelude () +import Darcs.Prelude + import Darcs.Util.Path ( FileName ) data SummDetail = SummAddDir FileName diff --git a/src/Darcs/Patch/TokenReplace.hs b/src/Darcs/Patch/TokenReplace.hs --- a/src/Darcs/Patch/TokenReplace.hs +++ b/src/Darcs/Patch/TokenReplace.hs @@ -3,8 +3,13 @@ tryTokInternal , forceTokReplace , breakOutToken + , breakToTokens + , defaultToks ) where +import Prelude () +import Darcs.Prelude + import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.Maybe ( isNothing ) @@ -55,3 +60,13 @@ replaceMatchingToken input | input == oldToken = newToken | otherwise = input + +-- break a single bytestring into tokens +breakToTokens :: BC.ByteString -> [BC.ByteString] +breakToTokens input | B.null input = [] +breakToTokens input = + let (_, tok, remaining) = breakOutToken defaultToks input in + tok : breakToTokens remaining + +defaultToks :: String +defaultToks = "A-Za-z_0-9" diff --git a/src/Darcs/Patch/TouchesFiles.hs b/src/Darcs/Patch/TouchesFiles.hs --- a/src/Darcs/Patch/TouchesFiles.hs +++ b/src/Darcs/Patch/TouchesFiles.hs @@ -22,7 +22,10 @@ selectTouching, deselectNotTouching, selectNotTouching, ) where -import Control.Applicative ( (<$>) ) + +import Prelude () +import Darcs.Prelude + import Data.List ( isSuffixOf, nub ) import Darcs.Patch.Choices ( PatchChoices, Label, LabelledPatch, @@ -34,7 +37,7 @@ import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) ) import Darcs.Patch.Witnesses.Sealed ( Sealed, seal ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) labelTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Bool -> [FilePath] -> FL (LabelledPatch p) wX wY -> [Label] diff --git a/src/Darcs/Patch/Type.hs b/src/Darcs/Patch/Type.hs --- a/src/Darcs/Patch/Type.hs +++ b/src/Darcs/Patch/Type.hs @@ -1,7 +1,9 @@ module Darcs.Patch.Type ( PatchType(..), patchType ) where +import Darcs.Patch.RepoType ( RepoType ) + -- |Used for indicating a patch type without having a concrete patch -data PatchType (p :: * -> * -> *) = PatchType +data PatchType (rt :: RepoType) (p :: * -> * -> *) = PatchType -patchType :: p wX wY -> PatchType p +patchType :: p wX wY -> PatchType rt p patchType _ = PatchType diff --git a/src/Darcs/Patch/V1.hs b/src/Darcs/Patch/V1.hs --- a/src/Darcs/Patch/V1.hs +++ b/src/Darcs/Patch/V1.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Darcs.Patch.V1 ( Patch ) where +module Darcs.Patch.V1 ( RepoPatchV1 ) where import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.Patchy ( Patchy ) @@ -8,11 +8,11 @@ import Darcs.Patch.V1.Apply () import Darcs.Patch.V1.Commute () -import Darcs.Patch.V1.Core ( Patch ) +import Darcs.Patch.V1.Core ( RepoPatchV1 ) import Darcs.Patch.V1.Read () import Darcs.Patch.V1.Show () import Darcs.Patch.V1.Viewing () -instance PrimPatch prim => Patchy (Patch prim) -instance PrimPatch prim => Matchable (Patch prim) -instance PrimPatch prim => RepoPatch (Patch prim) +instance PrimPatch prim => Patchy (RepoPatchV1 prim) +instance PrimPatch prim => Matchable (RepoPatchV1 prim) +instance PrimPatch prim => RepoPatch (RepoPatchV1 prim) diff --git a/src/Darcs/Patch/V1/Apply.hs b/src/Darcs/Patch/V1/Apply.hs --- a/src/Darcs/Patch/V1/Apply.hs +++ b/src/Darcs/Patch/V1/Apply.hs @@ -1,6 +1,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Apply () where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Apply ( ApplyState, Apply, apply ) import Darcs.Patch.Prim ( PrimPatch, applyPrimFL ) import Darcs.Patch.Repair ( RepairToFL, applyAndTryToFixFL, @@ -8,15 +11,15 @@ import Darcs.Patch.Effect ( effect ) import Darcs.Patch.V1.Commute () -import Darcs.Patch.V1.Core ( Patch(..) ) +import Darcs.Patch.V1.Core ( RepoPatchV1(..) ) import Darcs.Patch.Witnesses.Ordered ( mapFL_FL ) -instance PrimPatch prim => Apply (Patch prim) where - type ApplyState (Patch prim) = ApplyState prim +instance PrimPatch prim => Apply (RepoPatchV1 prim) where + type ApplyState (RepoPatchV1 prim) = ApplyState prim apply p = applyPrimFL $ effect p -instance PrimPatch prim => RepairToFL (Patch prim) where +instance PrimPatch prim => RepairToFL (RepoPatchV1 prim) where applyAndTryToFixFL (PP x) = mapMaybeSnd (mapFL_FL PP) `fmap` applyAndTryToFixFL x applyAndTryToFixFL x = do apply x; return Nothing diff --git a/src/Darcs/Patch/V1/Commute.hs b/src/Darcs/Patch/V1/Commute.hs --- a/src/Darcs/Patch/V1/Commute.hs +++ b/src/Darcs/Patch/V1/Commute.hs @@ -15,7 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} @@ -27,21 +27,26 @@ ) where +import Prelude () +import Darcs.Prelude + import Control.Monad ( MonadPlus, mplus, msum, mzero, guard ) -import Control.Applicative ( Applicative(..), Alternative(..) ) -import Data.Maybe ( isJust ) +import Control.Applicative ( Alternative(..) ) -import Darcs.Patch.Commute ( toFwdCommute, selfCommuter ) +import Darcs.Patch.Commute ( selfCommuter ) import Darcs.Patch.CommuteFn ( commuterIdFL, commuterFLId ) -import Darcs.Patch.ConflictMarking ( mangleUnravelled ) import Darcs.Util.Path ( FileName ) import Darcs.Patch.Invert ( invertRL ) import Darcs.Patch.Merge ( Merge(..) ) import Darcs.Patch.Patchy ( Commute(..), PatchInspect(..), Invert(..) ) -import Darcs.Patch.V1.Core ( Patch(..), +import Darcs.Patch.V1.Core ( RepoPatchV1(..), isMerger, mergerUndo ) -import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) ) +import Darcs.Patch.Conflict + ( Conflict(..), listConflictedFiles + , IsConflictedPrim(..), ConflictState(..), CommuteNoConflicts(..) + , mangleUnravelled + ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Prim ( FromPrim(..), PrimPatch, @@ -61,9 +66,9 @@ ( unsafeCoerceP, unsafeCoercePStart , unsafeCoercePEnd ) import Darcs.Patch.Witnesses.Ordered - ( mapFL_FL, + ( mapFL_FL, mapFL, FL(..), RL(..), - (:/\:)(..), (:<)(..), (:\/:)(..), (:>)(..), + (:/\:)(..), (:\/:)(..), (:>)(..), lengthFL, mapRL, reverseFL, reverseRL, concatFL ) @@ -117,34 +122,31 @@ -- TODO: when can the first attempt fail, but the second not? What's so clever -- in this function? cleverCommute :: Invert prim => CommuteFunction prim -> CommuteFunction prim -cleverCommute c (p1: p2) = case c (p1 :> p2) of Succeeded x -> Succeeded x Failed -> Failed - Unknown -> case c (invert p2 :< invert p1) of - Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1') - Failed -> Failed - Unknown -> Unknown + Unknown -> case c (invert p2 :> invert p1) of + Succeeded (ip1' :> ip2') -> Succeeded (invert ip2' :> invert ip1') + Failed -> Failed + Unknown -> Unknown -- | If we have two Filepatches which modify different files, we can return a -- result early, since the patches trivially commute. speedyCommute :: PrimPatch prim => CommuteFunction prim -speedyCommute (p1 :< p2) - | isJust p1_modifies && isJust p2_modifies && - p1_modifies /= p2_modifies = Succeeded (unsafeCoerceP p2 :< unsafeCoerceP p1) +speedyCommute (p1 :> p2) + | Just m1 <- isFilepatchMerger p1 + , Just m2 <- isFilepatchMerger p2 + , m1 /= m2 = Succeeded (unsafeCoerceP p2 :> unsafeCoerceP p1) | otherwise = Unknown - where p1_modifies = isFilepatchMerger p1 - p2_modifies = isFilepatchMerger p2 everythingElseCommute :: forall prim . PrimPatch prim => CommuteFunction prim -everythingElseCommute (PP px :< PP py) = toPerhaps $ do - x' :> y' <- commute (py :> px) - return (PP y' :< PP x') -everythingElseCommute _xx = - msum [ - cleverCommute commuteRecursiveMerger _xx - ,cleverCommute otherCommuteRecursiveMerger _xx - ] +everythingElseCommute (PP p1 :> PP p2) = toPerhaps $ do + p2' :> p1' <- commute (p1 :> p2) + return (PP p2' :> PP p1') +everythingElseCommute ps = + msum [ cleverCommute commuteRecursiveMerger ps + , cleverCommute otherCommuteRecursiveMerger ps + ] {- Note that it must be true that @@ -157,24 +159,23 @@ then commutex (B^-1, A^-1) == Just (A'^-1, B'^-1) -} -unsafeMerger :: PrimPatch prim => String -> Patch prim wX wY -> Patch prim wX wZ -> Patch prim wA wB +unsafeMerger :: PrimPatch prim => String -> RepoPatchV1 prim wX wY -> RepoPatchV1 prim wX wZ -> RepoPatchV1 prim wA wB unsafeMerger x p1 p2 = unsafeCoercePStart $ unsafeUnseal $ merger x p1 p2 -- | Attempt to commute two patches, the first of which is a Merger patch. -mergerCommute :: PrimPatch prim => (Patch prim :< Patch prim) wX wY -> Perhaps ((Patch prim :< Patch prim) wX wY) -mergerCommute (Merger _ _ p1 p2 :< pA) - | unsafeCompare pA p1 = Succeeded (unsafeMerger "0.0" p2 p1 :< unsafeCoercePStart p2) +mergerCommute :: PrimPatch prim + => (RepoPatchV1 prim :> RepoPatchV1 prim) wX wY -> Perhaps ((RepoPatchV1 prim :> RepoPatchV1 prim) wX wY) +mergerCommute (pA :> Merger _ _ p1 p2) + | unsafeCompare pA p1 = Succeeded (unsafeCoercePStart p2 :> unsafeMerger "0.0" p2 p1) | unsafeCompare pA (invert (unsafeMerger "0.0" p2 p1)) = Failed -mergerCommute (Merger _ _ - (Merger _ _ c b) - (Merger _ _ c' a) :< - Merger _ _ b' c'') +mergerCommute (Merger _ _ b' c'' :> Merger _ _ (Merger _ _ c b) (Merger _ _ c' a)) | unsafeCompare b' b && unsafeCompare c c' && unsafeCompare c c'' = - Succeeded (unsafeMerger "0.0" (unsafeMerger "0.0" b (unsafeCoercePStart a)) (unsafeMerger "0.0" b c) :< - unsafeMerger "0.0" b (unsafeCoercePStart a)) + Succeeded ( unsafeMerger "0.0" b (unsafeCoercePStart a) :> + unsafeMerger "0.0" (unsafeMerger "0.0" b (unsafeCoercePStart a)) (unsafeMerger "0.0" b c) + ) mergerCommute _ = Unknown -instance PrimPatch prim => Merge (Patch prim) where +instance PrimPatch prim => Merge (RepoPatchV1 prim) where merge (y :\/: z) = case actualMerge (y:\/:z) of -- actualMerge returns one "arm" of a merge result (@y'@, which applies @@ -187,14 +188,14 @@ $$ showPatch_ y' Just (_ :> z') -> unsafeCoercePStart z' :/\: y' -instance PrimPatch prim => Commute (Patch prim) where +instance PrimPatch prim => Commute (RepoPatchV1 prim) where commute x = toMaybe $ msum - [toFwdCommute speedyCommute x, - toFwdCommute (cleverCommute mergerCommute) x, - toFwdCommute everythingElseCommute x + [speedyCommute x, + (cleverCommute mergerCommute) x, + everythingElseCommute x ] -instance PrimPatch prim => PatchInspect (Patch prim) where +instance PrimPatch prim => PatchInspect (RepoPatchV1 prim) where -- Recurse on everything, these are potentially spoofed patches listTouchedFiles (Merger _ _ p1 p2) = nubSort $ listTouchedFiles p1 ++ listTouchedFiles p2 @@ -207,10 +208,11 @@ commuteNoMerger :: PrimPatch prim => MaybeCommute prim commuteNoMerger x = - toMaybe $ msum [speedyCommute x, - everythingElseCommute x] + toMaybe $ msum [ speedyCommute x + , everythingElseCommute x + ] -isFilepatchMerger :: PrimPatch prim => Patch prim wX wY -> Maybe FileName +isFilepatchMerger :: PrimPatch prim => RepoPatchV1 prim wX wY -> Maybe FileName isFilepatchMerger (PP p) = is_filepatch p isFilepatchMerger (Merger _ _ p1 p2) = do f1 <- isFilepatchMerger p1 @@ -219,8 +221,9 @@ isFilepatchMerger (Regrem und unw p1 p2) = isFilepatchMerger (Merger und unw p1 p2) -commuteRecursiveMerger :: PrimPatch prim => (Patch prim :< Patch prim) wX wY -> Perhaps ((Patch prim :< Patch prim) wX wY) -commuteRecursiveMerger (p@(Merger _ _ p1 p2) :< pA) = toPerhaps $ +commuteRecursiveMerger :: PrimPatch prim + => (RepoPatchV1 prim :> RepoPatchV1 prim) wX wY -> Perhaps ((RepoPatchV1 prim :> RepoPatchV1 prim) wX wY) +commuteRecursiveMerger (pA :> p@(Merger _ _ p1 p2)) = toPerhaps $ do (_ :> pA') <- commuterIdFL selfCommuter (pA :> undo) _ <- commuterIdFL selfCommuter (pA' :> invert undo) (_ :> pAmid) <- commute (pA :> unsafeCoercePStart (invert p1)) @@ -235,13 +238,13 @@ undo' = mergerUndo p' (pAo :> _) <- commuterFLId selfCommuter (undo' :> pA') guard (pAo `unsafeCompare` pA) - return (pA' :< p') + return (p' :> pA') where undo = mergerUndo p commuteRecursiveMerger _ = Unknown -otherCommuteRecursiveMerger :: PrimPatch prim => (Patch prim :< Patch prim) wX wY -> Perhaps ((Patch prim :< Patch prim) wX wY) -otherCommuteRecursiveMerger (pA':< p_old@(Merger _ _ p1' p2')) = - toPerhaps $ +otherCommuteRecursiveMerger :: PrimPatch prim + => (RepoPatchV1 prim :> RepoPatchV1 prim) wX wY -> Perhaps ((RepoPatchV1 prim :> RepoPatchV1 prim) wX wY) +otherCommuteRecursiveMerger (p_old@(Merger _ _ p1' p2') :> pA') = toPerhaps $ do (pA :> _) <- commuterFLId selfCommuter (mergerUndo p_old :> pA') (pAmid :> p1) <- commute (unsafeCoercePEnd p1' :> pA) (_ :> pAmido) <- commute (pA :> invert p1) @@ -256,24 +259,24 @@ guard (not $ pA `unsafeCompare` p1) -- special case here... (_ :> pAo') <- commuterIdFL selfCommuter (pA :> undo) guard (pAo' `unsafeCompare` pA') - return (p :< pA) + return (pA :> p) otherCommuteRecursiveMerger _ = Unknown -type CommuteFunction prim = forall wX wY . (Patch prim :< Patch prim) wX wY -> Perhaps ((Patch prim :< Patch prim) wX wY) -type MaybeCommute prim = forall wX wY . (Patch prim :< Patch prim) wX wY -> Maybe ((Patch prim :< Patch prim) wX wY) +type CommuteFunction prim = forall wX wY . (RepoPatchV1 prim :> RepoPatchV1 prim) wX wY -> Perhaps ((RepoPatchV1 prim :> RepoPatchV1 prim) wX wY) +type MaybeCommute prim = forall wX wY . (RepoPatchV1 prim :> RepoPatchV1 prim) wX wY -> Maybe ((RepoPatchV1 prim :> RepoPatchV1 prim) wX wY) -revCommuteFLId :: MaybeCommute prim -> (FL (Patch prim) :< Patch prim) wX wY -> Maybe ((Patch prim :< FL (Patch prim)) wX wY) -revCommuteFLId _ (NilFL :< p) = return (p :< NilFL) -revCommuteFLId commuter ((q :>: qs) :< p) = do - p' :< q' <- commuter (q :< p) - p'' :< qs' <- revCommuteFLId commuter (qs :< p') - return (p'' :< (q' :>: qs')) +commuteFLId :: MaybeCommute prim -> (RepoPatchV1 prim :> FL (RepoPatchV1 prim)) wX wY -> Maybe ((FL (RepoPatchV1 prim) :> RepoPatchV1 prim) wX wY) +commuteFLId _ (p :> NilFL) = return (NilFL :> p) +commuteFLId commuter (p :> (q :>: qs)) = do + q' :> p' <- commuter (p :> q) + qs' :> p'' <- commuteFLId commuter (p' :> qs) + return ((q' :>: qs') :> p'') -- | elegantMerge attempts to perform the "intuitive" merge of two patches, -- from a common starting context @wX@. elegantMerge :: PrimPatch prim - => (Patch prim :\/: Patch prim) wX wY - -> Maybe ((Patch prim :/\: Patch prim) wX wY) + => (RepoPatchV1 prim :\/: RepoPatchV1 prim) wX wY + -> Maybe ((RepoPatchV1 prim :/\: RepoPatchV1 prim) wX wY) elegantMerge (p1 :\/: p2) = do p1' :> ip2' <- commute (invert p2 :> p1) p1o :> _ <- commute (p2 :> p1') @@ -308,43 +311,45 @@ -- -- TODO: why does this code throw away the other branch, only for merge to -- rebuild it? -actualMerge :: PrimPatch prim => (Patch prim :\/: Patch prim) wX wY -> Sealed (Patch prim wY) +actualMerge :: PrimPatch prim + => (RepoPatchV1 prim :\/: RepoPatchV1 prim) wX wY -> Sealed (RepoPatchV1 prim wY) actualMerge (p1 :\/: p2) = case elegantMerge (p1:\/:p2) of Just (_ :/\: p1') -> Sealed p1' Nothing -> merger "0.0" p2 p1 -- Recreates a patch history in reverse. -unwind :: Patch prim wX wY -> Sealed (RL (Patch prim) wX) +unwind :: RepoPatchV1 prim wX wY -> Sealed (RL (RepoPatchV1 prim) wX) unwind (Merger _ unwindings _ _) = Sealed unwindings -unwind p = Sealed (p :<: NilRL) +unwind p = Sealed (NilRL :<: p) -- Recreates a patch history in reverse. The patch being unwound is always at -- the start of the list of patches. -trueUnwind :: PrimPatch prim => Patch prim wX wY -> Sealed (RL (Patch prim) wX) +trueUnwind :: PrimPatch prim + => RepoPatchV1 prim wX wY -> Sealed (RL (RepoPatchV1 prim) wX) trueUnwind p@(Merger _ _ p1 p2) = case (unwind p1, unwind p2) of - (Sealed (_:<:p1s),Sealed (_:<:p2s)) -> - Sealed (p :<: unsafeCoerceP p1 :<: unsafeUnsealFlipped (reconcileUnwindings p p1s (unsafeCoercePEnd p2s))) + (Sealed (p1s:<:_),Sealed (p2s:<:_)) -> + Sealed (unsafeUnsealFlipped (reconcileUnwindings p p1s (unsafeCoercePEnd p2s)) :<: unsafeCoerceP p1 :<: p) _ -> impossible trueUnwind _ = impossible reconcileUnwindings :: PrimPatch prim - => Patch prim wA wB -> RL (Patch prim) wX wZ -> RL (Patch prim) wY wZ -> FlippedSeal (RL (Patch prim)) wZ + => RepoPatchV1 prim wA wB -> RL (RepoPatchV1 prim) wX wZ -> RL (RepoPatchV1 prim) wY wZ -> FlippedSeal (RL (RepoPatchV1 prim)) wZ reconcileUnwindings _ NilRL p2s = FlippedSeal p2s reconcileUnwindings _ p1s NilRL = FlippedSeal p1s -reconcileUnwindings p (p1:<:p1s) p2s@(p2:<:tp2s) = +reconcileUnwindings p (p1s:<:p1) p2s@(tp2s:<:p2) = case [(p1s', p2s')| - p1s'@(hp1s':<:_) <- headPermutationsRL (p1:<:p1s), - p2s'@(hp2s':<:_) <- headPermutationsRL p2s, + p1s'@(_:<:hp1s') <- headPermutationsRL (p1s:<:p1), + p2s'@(_:<:hp2s') <- headPermutationsRL p2s, hp1s' `unsafeCompare` hp2s'] of - ((p1':<:p1s', _:<:p2s'):_) -> - mapFlipped (p1' :<:) $ reconcileUnwindings p p1s' (unsafeCoercePEnd p2s') + ((p1s':<:p1', p2s':<:_):_) -> + mapFlipped (:<:p1') $ reconcileUnwindings p p1s' (unsafeCoercePEnd p2s') [] -> case reverseFL `fmap` putBefore p1 (reverseRL p2s) of - Just p2s' -> mapFlipped (p1 :<:) $ reconcileUnwindings p p1s p2s' + Just p2s' -> mapFlipped (:<:p1) $ reconcileUnwindings p p1s p2s' Nothing -> case fmap reverseFL $ putBefore p2 $ - reverseRL (p1:<:p1s) of - Just p1s' -> mapFlipped (p2 :<:) $ + reverseRL (p1s:<:p1) of + Just p1s' -> mapFlipped (:<:p2) $ reconcileUnwindings p p1s' tp2s Nothing -> bugDoc $ text "in function reconcileUnwindings" @@ -356,44 +361,52 @@ -- it seems to have been this way forever: -- Fri May 23 10:27:04 BST 2003 droundy@abridgegame.org -- * fix bug in unwind and add docs on unwind algorithm. -putBefore :: PrimPatch prim => Patch prim wY wZ -> FL (Patch prim) wX wZ -> Maybe (FL (Patch prim) wY wW) +putBefore :: PrimPatch prim + => RepoPatchV1 prim wY wZ -> FL (RepoPatchV1 prim) wX wZ -> Maybe (FL (RepoPatchV1 prim) wY wW) putBefore p1 (p2:>:p2s) = do p1' :> p2' <- commute (unsafeCoerceP p2 :> invert p1) _ <- commute (p2' :> p1) (unsafeCoerceP p2' :>:) `fmap` putBefore p1' (unsafeCoerceP p2s) putBefore _ NilFL = Just (unsafeCoerceP NilFL) -instance PrimPatch prim => CommuteNoConflicts (Patch prim) where - commuteNoConflicts (x:>y) = do x' :< y' <- commuteNoMerger (y :< x) - return (y':>x') +instance PrimPatch prim => CommuteNoConflicts (RepoPatchV1 prim) where + commuteNoConflicts (x :> y) = do y' :> x' <- commuteNoMerger (x :> y) + return (y' :> x') -instance PrimPatch prim => Conflict (Patch prim) where - resolveConflicts patch = rcs NilFL (patch :<: NilRL) - where rcs :: FL (Patch prim) wY wW -> RL (Patch prim) wX wY -> [[Sealed (FL prim wW)]] +instance PrimPatch prim => Conflict (RepoPatchV1 prim) where + resolveConflicts patch = rcs NilFL (NilRL :<: patch) + where rcs :: FL (RepoPatchV1 prim) wY wW -> RL (RepoPatchV1 prim) wX wY -> [[Sealed (FL prim wW)]] rcs _ NilRL = [] - rcs passedby (p@(Merger{}):<:ps) = - case revCommuteFLId commuteNoMerger (passedby: + rcs passedby (ps:<:p@(Merger{})) = + case commuteFLId commuteNoMerger (p :> passedby) of + Just (_ :> p'@(Merger _ _ p1 p2)) -> map Sealed (nubBy unsafeCompare $ effect (unsafeCoercePStart $ unsafeUnseal (glump09 p1 p2)) : map (unsafeCoercePStart . unsafeUnseal) (unravel p')) : rcs (p :>: passedby) ps Nothing -> rcs (p :>: passedby) ps _ -> impossible - rcs passedby (p:<:ps) = seq passedby $ + rcs passedby (ps:<:p) = seq passedby $ rcs (p :>: passedby) ps + conflictedEffect x = + case listConflictedFiles x of + [] -> mapFL (IsC Okay) $ effect x + _ -> mapFL (IsC Conflicted) $ effect x + + -- This type seems wrong - the most natural type for the result would seem to be -- [Sealed (FL Prim wX)], given the type of unwind. -- However downstream code in darcs convert assumes the wY type, and I was unable -- to figure out whether this could/should reasonably be changed -- Ganesh 13/4/10 -publicUnravel :: PrimPatch prim => Patch prim wX wY -> [Sealed (FL prim wY)] +publicUnravel :: PrimPatch prim => RepoPatchV1 prim wX wY -> [Sealed (FL prim wY)] publicUnravel = map (mapSeal unsafeCoercePStart) . unravel -unravel :: PrimPatch prim => Patch prim wX wY -> [Sealed (FL prim wX)] +unravel :: PrimPatch prim => RepoPatchV1 prim wX wY -> [Sealed (FL prim wX)] unravel p = nub $ map (mapSeal (sortCoalesceFL . concatFL . mapFL_FL effect)) $ getSupers $ map (mapSeal reverseRL) $ unseal (newUr p) $ unwind p -getSupers :: PrimPatch prim => [Sealed (FL (Patch prim) wX)] -> [Sealed (FL (Patch prim) wX)] +getSupers :: PrimPatch prim + => [Sealed (FL (RepoPatchV1 prim) wX)] -> [Sealed (FL (RepoPatchV1 prim) wX)] getSupers (x:xs) = case filter (not.(x `isSuperpatchOf`)) xs of xs' -> if any (`isSuperpatchOf` x) xs' @@ -401,10 +414,11 @@ else x : getSupers xs' getSupers [] = [] -isSuperpatchOf :: PrimPatch prim => Sealed (FL (Patch prim) wX) -> Sealed (FL (Patch prim) wX) -> Bool +isSuperpatchOf :: PrimPatch prim + => Sealed (FL (RepoPatchV1 prim) wX) -> Sealed (FL (RepoPatchV1 prim) wX) -> Bool Sealed x `isSuperpatchOf` Sealed y | lengthFL y > lengthFL x = False -- should be just an optimisation Sealed x `isSuperpatchOf` Sealed y = x `iso` y - where iso :: PrimPatch prim => FL (Patch prim) wX wY -> FL (Patch prim) wX wZ -> Bool + where iso :: PrimPatch prim => FL (RepoPatchV1 prim) wX wY -> FL (RepoPatchV1 prim) wX wZ -> Bool _ `iso` NilFL = True NilFL `iso` _ = False a `iso` (b:>:bs) = @@ -414,7 +428,8 @@ -- constructs a Merger patch to represent the conflict. @p1@ is considered to -- be conflicting with @p2@ (@p1@ is the "first" patch in the repo ordering), -- the resulting Merger is therefore a representation of @p2@. -merger :: PrimPatch prim => String -> Patch prim wX wY -> Patch prim wX wZ -> Sealed (Patch prim wY) +merger :: PrimPatch prim + => String -> RepoPatchV1 prim wX wY -> RepoPatchV1 prim wX wZ -> Sealed (RepoPatchV1 prim wY) merger "0.0" p1 p2 = Sealed $ Merger undoit unwindings p1 p2 where fake_p = Merger NilFL NilRL p1 p2 unwindings = unsafeUnseal (trueUnwind fake_p) @@ -422,7 +437,7 @@ undoit = case (isMerger p1, isMerger p2) of (True ,True ) -> case unwind p of - Sealed (_:<:t) -> unsafeCoerceP $ invertRL t + Sealed (t:<:_) -> unsafeCoerceP $ invertRL t _ -> impossible (False,False) -> unsafeCoerceP $ invert p1 :>: NilFL (True ,False) -> unsafeCoerceP NilFL @@ -431,22 +446,23 @@ error $ "Cannot handle mergers other than version 0.0\n"++g ++ "\nPlease use darcs optimize --modernize with an older darcs." -glump09 :: PrimPatch prim => Patch prim wX wY -> Patch prim wX wZ -> Sealed (FL (Patch prim) wY) +glump09 :: PrimPatch prim => RepoPatchV1 prim wX wY -> RepoPatchV1 prim wX wZ -> Sealed (FL (RepoPatchV1 prim) wY) glump09 p1 p2 = mapSeal (mapFL_FL fromPrim) $ mangleUnravelled $ unseal unravel $ merger "0.0" p1 p2 -instance PrimPatch prim => Effect (Patch prim) where +instance PrimPatch prim => Effect (RepoPatchV1 prim) where effect p@(Merger{}) = sortCoalesceFL $ effect $ mergerUndo p effect p@(Regrem{}) = invert $ effect $ invert p effect (PP p) = p :>: NilFL -instance IsHunk prim => IsHunk (Patch prim) where +instance IsHunk prim => IsHunk (RepoPatchV1 prim) where isHunk p = do PP p' <- return p isHunk p' -newUr :: PrimPatch prim => Patch prim wA wB -> RL (Patch prim) wX wY -> [Sealed (RL (Patch prim) wX)] -newUr p (Merger _ _ p1 p2 :<: ps) = - case filter (\(pp:<:_) -> pp `unsafeCompare` p1) $ headPermutationsRL ps of - ((_:<:ps'):_) -> newUr p (unsafeCoercePStart p1:<:ps') ++ newUr p (unsafeCoercePStart p2:<:ps') +newUr :: PrimPatch prim + => RepoPatchV1 prim wA wB -> RL (RepoPatchV1 prim) wX wY -> [Sealed (RL (RepoPatchV1 prim) wX)] +newUr p (ps :<: Merger _ _ p1 p2) = + case filter (\(_:<:pp) -> pp `unsafeCompare` p1) $ headPermutationsRL ps of + ((ps':<:_):_) -> newUr p (ps':<:unsafeCoercePStart p1) ++ newUr p (ps':<:unsafeCoercePStart p2) _ -> bugDoc $ text "in function newUr" $$ text "Original patch:" $$ showPatch_ p @@ -454,24 +470,24 @@ $$ vcat (unseal (mapRL showPatch_) $ unwind p) newUr op ps = - case filter (\(p:<:_) -> isMerger p) $ headPermutationsRL ps of + case filter (\(_:<:p) -> isMerger p) $ headPermutationsRL ps of [] -> [Sealed ps] (ps':_) -> newUr op ps' -instance Invert prim => Invert (Patch prim) where +instance Invert prim => Invert (RepoPatchV1 prim) where invert (Merger undo unwindings p1 p2) = Regrem undo unwindings p1 p2 invert (Regrem undo unwindings p1 p2) = Merger undo unwindings p1 p2 invert (PP p) = PP (invert p) -instance MyEq prim => MyEq (Patch prim) where +instance MyEq prim => MyEq (RepoPatchV1 prim) where unsafeCompare = eqPatches -instance MyEq prim => Eq (Patch prim wX wY) where +instance MyEq prim => Eq (RepoPatchV1 prim wX wY) where (==) = unsafeCompare -eqPatches :: MyEq prim => Patch prim wX wY -> Patch prim wW wZ -> Bool +eqPatches :: MyEq prim => RepoPatchV1 prim wX wY -> RepoPatchV1 prim wW wZ -> Bool eqPatches (PP p1) (PP p2) = unsafeCompare p1 p2 eqPatches (Merger _ _ p1a p1b) (Merger _ _ p2a p2b) = eqPatches p1a p2a && diff --git a/src/Darcs/Patch/V1/Core.hs b/src/Darcs/Patch/V1/Core.hs --- a/src/Darcs/Patch/V1/Core.hs +++ b/src/Darcs/Patch/V1/Core.hs @@ -1,15 +1,15 @@ {-# LANGUAGE CPP #-} module Darcs.Patch.V1.Core - ( Patch(..), + ( RepoPatchV1(..), isMerger, mergerUndo ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(ListFormatV1) ) import Darcs.Patch.Debug ( PatchDebug(..) ) -import Darcs.Patch.MaybeInternal ( MaybeInternal ) import Darcs.Patch.Prim ( FromPrim(..), PrimOf, PrimPatchBase, PrimPatch ) -import Darcs.Patch.Rebase.NameHack ( NameHack ) -import Darcs.Patch.Rebase.Recontext ( RecontextRebase ) import Darcs.Patch.Repair ( Check ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL ) @@ -34,20 +34,20 @@ @original@ = the patch we really are -} -data Patch prim wX wY where - PP :: prim wX wY -> Patch prim wX wY - Merger :: FL (Patch prim) wX wY - -> RL (Patch prim) wX wB - -> Patch prim wC wB - -> Patch prim wC wD - -> Patch prim wX wY - Regrem :: FL (Patch prim) wX wY - -> RL (Patch prim) wX wB - -> Patch prim wC wB - -> Patch prim wC wA - -> Patch prim wY wX +data RepoPatchV1 prim wX wY where + PP :: prim wX wY -> RepoPatchV1 prim wX wY + Merger :: FL (RepoPatchV1 prim) wX wY + -> RL (RepoPatchV1 prim) wX wB + -> RepoPatchV1 prim wC wB + -> RepoPatchV1 prim wC wD + -> RepoPatchV1 prim wX wY + Regrem :: FL (RepoPatchV1 prim) wX wY + -> RL (RepoPatchV1 prim) wX wB + -> RepoPatchV1 prim wC wB + -> RepoPatchV1 prim wC wA + -> RepoPatchV1 prim wY wX -instance Show2 prim => Show (Patch prim wX wY) where +instance Show2 prim => Show (RepoPatchV1 prim wX wY) where showsPrec d (PP p) = showParen (d > appPrec) $ showString "PP " . showsPrec2 (appPrec + 1) p showsPrec d (Merger undos unwindings conflicting original) = @@ -63,39 +63,35 @@ showString " " . showsPrec2 (appPrec + 1) conflicting . showString " " . showsPrec2 (appPrec + 1) original -instance Show2 prim => Show1 (Patch prim wX) where +instance Show2 prim => Show1 (RepoPatchV1 prim wX) where showDict1 = ShowDictClass -instance Show2 prim => Show2 (Patch prim) where +instance Show2 prim => Show2 (RepoPatchV1 prim) where showDict2 = ShowDictClass -instance MaybeInternal (Patch prim) -instance NameHack (Patch prim) -instance RecontextRebase (Patch prim) - -instance PrimPatch prim => PrimPatchBase (Patch prim) where - type PrimOf (Patch prim) = prim +instance PrimPatch prim => PrimPatchBase (RepoPatchV1 prim) where + type PrimOf (RepoPatchV1 prim) = prim -instance FromPrim (Patch prim) where +instance FromPrim (RepoPatchV1 prim) where fromPrim = PP -isMerger :: Patch prim wA wB -> Bool +isMerger :: RepoPatchV1 prim wA wB -> Bool isMerger (Merger{}) = True isMerger (Regrem{}) = True isMerger _ = False -mergerUndo :: Patch prim wX wY -> FL (Patch prim) wX wY +mergerUndo :: RepoPatchV1 prim wX wY -> FL (RepoPatchV1 prim) wX wY mergerUndo (Merger undo _ _ _) = undo mergerUndo _ = impossible -instance PatchListFormat (Patch prim) where +instance PatchListFormat (RepoPatchV1 prim) where -- In principle we could use ListFormatDefault when prim /= V1 Prim patches, -- as those are the only case where we need to support a legacy on-disk -- format. In practice we don't expect Patch to be used with any other argument -- anyway, so it doesn't matter. patchListFormat = ListFormatV1 -instance Check (Patch prim) +instance Check (RepoPatchV1 prim) -- no checks -instance PatchDebug prim => PatchDebug (Patch prim) +instance PatchDebug prim => PatchDebug (RepoPatchV1 prim) diff --git a/src/Darcs/Patch/V1/Read.hs b/src/Darcs/Patch/V1/Read.hs --- a/src/Darcs/Patch/V1/Read.hs +++ b/src/Darcs/Patch/V1/Read.hs @@ -1,13 +1,16 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Read () where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Invert ( invert ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Read ( ReadPatch(..) ) import Darcs.Patch.ReadMonads ( ParserM, choice, string, lexChar, myLex', skipSpace ) -import Darcs.Patch.V1.Core ( Patch(..) ) +import Darcs.Patch.V1.Core ( RepoPatchV1(..) ) import Darcs.Patch.V1.Commute ( merger ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, mapSeal ) @@ -18,13 +21,13 @@ import qualified Data.ByteString as B (ByteString ) -instance PrimPatch prim => ReadPatch (Patch prim) where +instance PrimPatch prim => ReadPatch (RepoPatchV1 prim) where readPatch' = choice [ liftM seal $ skipSpace >> readMerger True , liftM seal $ skipSpace >> readMerger False , liftM (mapSeal PP) readPatch' ] -readMerger :: (ParserM m, PrimPatch prim) => Bool -> m (Patch prim wX wY) +readMerger :: (ParserM m, PrimPatch prim) => Bool -> m (RepoPatchV1 prim wX wY) readMerger b = do string s g <- myLex' lexChar '(' diff --git a/src/Darcs/Patch/V1/Show.hs b/src/Darcs/Patch/V1/Show.hs --- a/src/Darcs/Patch/V1/Show.hs +++ b/src/Darcs/Patch/V1/Show.hs @@ -1,21 +1,24 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Show ( showPatch_ ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Format ( FileNameFormat(..) ) import Darcs.Patch.Prim ( showPrim, PrimPatch ) -import Darcs.Patch.V1.Core ( Patch(..) ) +import Darcs.Patch.V1.Core ( RepoPatchV1(..) ) import Darcs.Util.Printer ( Doc, text, blueText, ($$), (<+>) ) -showPatch_ :: PrimPatch prim => Patch prim wA wB -> Doc +showPatch_ :: PrimPatch prim => RepoPatchV1 prim wA wB -> Doc showPatch_ (PP p) = showPrim OldFormat p showPatch_ (Merger _ _ p1 p2) = showMerger "merger" p1 p2 showPatch_ (Regrem _ _ p1 p2) = showMerger "regrem" p1 p2 -showMerger :: PrimPatch prim => String -> Patch prim wA wB -> Patch prim wD wE -> Doc +showMerger :: PrimPatch prim => String -> RepoPatchV1 prim wA wB -> RepoPatchV1 prim wD wE -> Doc showMerger merger_name p1 p2 = blueText merger_name <+> text "0.0" <+> blueText "(" $$ showPatch_ p1 diff --git a/src/Darcs/Patch/V1/Viewing.hs b/src/Darcs/Patch/V1/Viewing.hs --- a/src/Darcs/Patch/V1/Viewing.hs +++ b/src/Darcs/Patch/V1/Viewing.hs @@ -1,19 +1,22 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Viewing () where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..) ) import Darcs.Patch.Summary ( plainSummary ) import Darcs.Patch.V1.Apply () -import Darcs.Patch.V1.Core ( Patch(..) ) +import Darcs.Patch.V1.Core ( RepoPatchV1(..) ) import Darcs.Patch.V1.Show ( showPatch_ ) -instance PrimPatch prim => ShowPatchBasic (Patch prim) where +instance PrimPatch prim => ShowPatchBasic (RepoPatchV1 prim) where showPatch = showPatch_ -instance PrimPatch prim => ShowPatch (Patch prim) where +instance PrimPatch prim => ShowPatch (RepoPatchV1 prim) where showContextPatch (PP p) = showContextPatch p showContextPatch p = return $ showPatch p summary = plainSummary diff --git a/src/Darcs/Patch/V2.hs b/src/Darcs/Patch/V2.hs --- a/src/Darcs/Patch/V2.hs +++ b/src/Darcs/Patch/V2.hs @@ -1,11 +1,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Darcs.Patch.V2 ( RealPatch, prim2real ) where +module Darcs.Patch.V2 ( RepoPatchV2, prim2repopatchV2 ) where import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.RepoPatch ( RepoPatch ) -import Darcs.Patch.V2.Real ( RealPatch, prim2real ) +import Darcs.Patch.V2.RepoPatch ( RepoPatchV2, prim2repopatchV2 ) -instance PrimPatch prim => Matchable (RealPatch prim) -instance PrimPatch prim => RepoPatch (RealPatch prim) +instance PrimPatch prim => Matchable (RepoPatchV2 prim) +instance PrimPatch prim => RepoPatch (RepoPatchV2 prim) diff --git a/src/Darcs/Patch/V2/Non.hs b/src/Darcs/Patch/V2/Non.hs --- a/src/Darcs/Patch/V2/Non.hs +++ b/src/Darcs/Patch/V2/Non.hs @@ -39,11 +39,9 @@ , (>>*) ) where -#if MIN_VERSION_base(4,8,0) -import Prelude hiding ( rem, (*>) ) -#else -import Prelude hiding ( rem ) -#endif +import Prelude () +import Darcs.Prelude hiding ( (*>) ) + import Data.List ( delete ) import Control.Monad ( liftM, mzero ) import Darcs.Patch.Commute ( commuteFL ) @@ -160,7 +158,7 @@ commuteOrAddToCtxRL :: (Patchy p, ToFromPrim p) => RL p wX wY -> Non p wY -> Non p wX commuteOrAddToCtxRL NilRL n = n -commuteOrAddToCtxRL (p:<:ps) n = commuteOrAddToCtxRL ps $ commuteOrAddToCtx p n +commuteOrAddToCtxRL (ps:<:p) n = commuteOrAddToCtxRL ps $ commuteOrAddToCtx p n -- |abstract over 'FL'/'RL' class WL l where @@ -268,4 +266,4 @@ commuteRLPastNon :: (Patchy p, ToFromPrim p) => RL (PrimOf p) wX wY -> Non p wY -> Maybe (Non p wX) commuteRLPastNon NilRL n = Just n - commuteRLPastNon (x:<:xs) n = fromPrim x >* n >>= commuteRLPastNon xs + commuteRLPastNon (xs:<:x) n = fromPrim x >* n >>= commuteRLPastNon xs diff --git a/src/Darcs/Patch/V2/Real.hs b/src/Darcs/Patch/V2/Real.hs deleted file mode 100644 --- a/src/Darcs/Patch/V2/Real.hs +++ /dev/null @@ -1,952 +0,0 @@ --- Copyright (C) 2007 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. - -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} -{-# LANGUAGE CPP #-} - - -module Darcs.Patch.V2.Real - ( RealPatch(..) - , prim2real - , isConsistent - , isForward - , isDuplicate - , mergeUnravelled - ) where - -#if MIN_VERSION_base(4,8,0) -import Prelude hiding ( (*>) ) -#endif - -import Control.Monad ( mplus, liftM ) -import qualified Data.ByteString.Char8 as BC ( ByteString, pack ) -import Data.Maybe ( fromMaybe ) -import Data.List ( partition, nub ) - -import Darcs.Patch.Commute ( commuteFL, commuteFLorComplain, commuteRL - , commuteRLFL ) -import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) - , IsConflictedPrim(..), ConflictState(..) ) -import Darcs.Patch.ConflictMarking ( mangleUnravelled ) -import Darcs.Patch.Debug -import Darcs.Patch.Effect ( Effect(..) ) -import Darcs.Patch.FileHunk ( IsHunk(..) ) -import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..) - , FileNameFormat(NewFormat) ) -import Darcs.Patch.Invert ( invertFL, invertRL ) -import Darcs.Patch.MaybeInternal ( MaybeInternal ) -import Darcs.Patch.Merge ( Merge(..) ) -import Darcs.Patch.Prim ( FromPrim(..), ToFromPrim(..), showPrim, showPrimFL - , readPrim, PrimOf, PrimPatchBase, PrimPatch ) -import Darcs.Patch.Read ( bracketedFL ) -import Darcs.Patch.ReadMonads ( skipSpace, string, choice ) -import Darcs.Patch.Rebase.NameHack ( NameHack ) -import Darcs.Patch.Rebase.Recontext ( RecontextRebase ) -import Darcs.Patch.Repair ( mapMaybeSnd, RepairToFL(..), Check(..) ) -import Darcs.Patch.Patchy ( Patchy, Apply(..), Commute(..), PatchInspect(..) - , ReadPatch(..), ShowPatch(..), Invert(..) ) -import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL - , genCommuteWhatWeCanRL, removeRL, removeFL - , removeSubsequenceFL ) -import Darcs.Patch.Show ( ShowPatchBasic(..) ) -import Darcs.Patch.Summary ( plainSummary ) -import Darcs.Patch.V2.Non ( Non(..), Nonable(..), unNon, showNons, showNon - , readNons, readNon, commutePrimsOrAddToCtx - , commuteOrAddToCtx, commuteOrAddToCtxRL - , commuteOrRemFromCtx, commuteOrRemFromCtxFL - , remNons, (*>), (>*), (*>>), (>>*) ) -import Data.List.Ordered ( nubSort ) -import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) -import Darcs.Patch.Witnesses.Ordered - ( FL(..), RL(..), (:>)(..), (+>+), (+<+) - , mapFL_FL, reverseFL, (:\/:)(..), (:/\:)(..) - , reverseRL, lengthFL, lengthRL, nullFL ) -import Darcs.Patch.Witnesses.Sealed - ( FlippedSeal(..), Sealed(Sealed), mapSeal - , unseal ) -import Darcs.Patch.Witnesses.Show - ( Show1(..), Show2(..), ShowDict(..) - , showsPrec2, appPrec - ) -import Darcs.Util.Printer.Color ( errorDoc, assertDoc ) - -import Darcs.Util.Printer ( Doc, blueText, redText, (<+>), ($$) ) - -#include "impossible.h" - --- |'RealPatch' is used to represents prim patches that are duplicates of, or --- conflict with, another prim patch in the repository. --- --- @Normal prim@: A primitive patch --- --- @Duplicate x@: This patch has no effect since @x@ is already present in the --- repository. --- --- @Etacilpud x: invert (Duplicate x)@ --- --- @Conflictor ix xx x@: --- @ix@ is the set of patches: --- * that conflict with @x@ and also conflict with another patch in the --- repository. --- * that conflict with a patch that conflict with @x@ --- --- @xx@ is the sequence of patches that conflict *only* with @x@ --- --- @x@ is the original, conflicting patch. --- --- @ix@ and @x@ are stored as @Non@ objects, which include any necessary --- context to uniquely define the patch that is referred to. --- --- The intuition is that a Conflictor should have the effect of inverting any --- patches that 'x' conflicts with, that haven't already been undone by another --- Conflictor in the repository. --- Therefore, the effect of a Conflictor is @invert xx@. --- --- @InvConflictor ix xx x@: like @invert (Conflictor ix xx x)@ -data RealPatch prim wX wY where - Duplicate :: Non (RealPatch prim) wX -> RealPatch prim wX wX - Etacilpud :: Non (RealPatch prim) wX -> RealPatch prim wX wX - Normal :: prim wX wY -> RealPatch prim wX wY - Conflictor :: [Non (RealPatch prim) wX] -> FL prim wX wY - -> Non (RealPatch prim) wX -> RealPatch prim wY wX - InvConflictor :: [Non (RealPatch prim) wX] -> FL prim wX wY - -> Non (RealPatch prim) wX -> RealPatch prim wX wY - -instance PrimPatch prim => PrimPatchBase (RealPatch prim) where - type PrimOf (RealPatch prim) = prim - --- | 'isDuplicate' @p@ is @True@ if @p@ is either a 'Duplicate' or 'Etacilpud' --- patch. -isDuplicate :: RealPatch prim wS wY -> Bool -isDuplicate (Duplicate _) = True -isDuplicate (Etacilpud _) = True -isDuplicate _ = False - --- | 'isForward' @p@ is @True@ if @p@ is either an 'InvConflictor' or --- 'Etacilpud'. -isForward :: PrimPatch prim => RealPatch prim wS wY -> Maybe Doc -isForward p = case p of - p@(InvConflictor{}) -> justRedP "An inverse conflictor" p - p@(Etacilpud _) -> justRedP "An inverse duplicate" p - _ -> Nothing - where - justRedP msg p = Just $ redText msg $$ showPatch p - --- |'mergeUnravelled' is used when converting from Darcs V1 patches (Mergers) --- to Darcs V2 patches (Conflictors). -mergeUnravelled :: PrimPatch prim => [Sealed ((FL prim) wX)] - -> Maybe (FlippedSeal (RealPatch prim) wX) -mergeUnravelled [] = Nothing -mergeUnravelled [_] = Nothing -mergeUnravelled ws = - case mergeUnravelled_private ws of - Nothing -> Nothing - Just NilRL -> bug "found no patches in mergeUnravelled" - Just (z :<: _) -> Just $ FlippedSeal z - where - notNullS :: PrimPatch prim => Sealed ((FL prim) wX) -> Bool - notNullS (Sealed NilFL) = False - notNullS _ = True - - mergeUnravelled_private :: PrimPatch prim => [Sealed (FL prim wX)] - -> Maybe (RL (RealPatch prim) wX wX) - mergeUnravelled_private xs = let nonNullXs = filter notNullS xs in - reverseFL `fmap` mergeConflictingNons (map sealed2non nonNullXs) - - -- | 'sealed2non' @(Sealed xs)@ converts @xs@ to a 'Non'. - -- @xs@ must be non-empty since we split this list at the last patch, - -- taking @init xs@ as the context of @last xs@. - sealed2non :: Sealed ((FL prim) wX) -> Non (RealPatch prim) wX - sealed2non (Sealed xs) = - case reverseFL xs of - y :<: ys -> Non (mapFL_FL fromPrim $ reverseRL ys) y - NilRL -> bug "NilFL encountered in sealed2non" - -mergeConflictingNons :: PrimPatch prim => [Non (RealPatch prim) wX] - -> Maybe (FL (RealPatch prim) wX wX) -mergeConflictingNons ns = mcn $ map unNon ns - where mcn :: PrimPatch prim => [Sealed (FL (RealPatch prim) wX)] - -> Maybe (FL (RealPatch prim) wX wX) - mcn [] = Just NilFL - -- Apparently, the joinEffects call is a safety check "and could be - -- removed when we're sure of the code"! - mcn [Sealed p] = case joinEffects p of - NilFL -> Just p - _ -> Nothing - mcn (Sealed p1:Sealed p2:zs) = - case pullCommon p1 p2 of - Common c ps qs -> - case merge (ps :\/: qs) of - qs' :/\: _ -> mcn (Sealed (c +>+ ps +>+ qs'):zs) - -joinEffects :: forall p wX wY . (Effect p, Invert (PrimOf p), - Commute (PrimOf p), MyEq (PrimOf p)) => p wX wY - -> FL (PrimOf p) wX wY -joinEffects = joinInverses . effect - where joinInverses :: FL (PrimOf p) wA wB -> FL (PrimOf p) wA wB - joinInverses NilFL = NilFL - joinInverses (p :>: ps) = - let ps' = joinInverses ps in - fromMaybe (p :>: ps') $ removeFL (invert p) ps' - -assertConsistent :: PrimPatch prim => RealPatch prim wX wY - -> RealPatch prim wX wY -assertConsistent x = flip assertDoc x $ do - e <- isConsistent x - Just (redText "Inconsistent patch:" $$ showPatch x $$ e) - --- | @mergeAfterConflicting@ takes as input a sequence of conflicting patches --- @xxx@ (which therefore have no effect) and a sequence of primitive patches --- @yyy@ that follow said sequence of conflicting patches, and may depend upon --- some of the conflicting patches (as a resolution). - --- The output is two sequences of patches the first consisting of a set of --- mutually-conflicting patches, and the second having the same effect as the --- original primitive patch sequence in the input. - --- So far as I can tell, the second output is always identical to @mapFL Normal --- yyy@ - --- The first output is the set of patches from @xxx@ that are depended upon by --- @yyy@. -mergeAfterConflicting :: PrimPatch prim => FL (RealPatch prim) wX wX - -> FL prim wX wY -> Maybe ( FL (RealPatch prim) wX wX - , FL (RealPatch prim) wX wY) -mergeAfterConflicting xxx yyy = mac (reverseFL xxx) yyy NilFL - where - mac :: PrimPatch prim - => RL (RealPatch prim) wX wY -> FL prim wY wZ - -> FL (RealPatch prim) wZ wA - -> Maybe (FL (RealPatch prim) wX wX, FL (RealPatch prim) wX wA) - mac NilRL xs goneby = case joinEffects goneby of - NilFL -> Just (NilFL, mapFL_FL Normal xs) - _ -> Nothing - mac (p :<: ps) xs goneby = - case commuteFLorComplain (p :> mapFL_FL Normal xs) of - Left _ -> - case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of - a :> p' :> b -> - do (b', xs') <- mac b xs goneby - let pa = joinEffects $ p' :<: a - NilFL <- return pa - return (reverseRL (p' :<: a) +>+ b', xs') - `mplus` - do NilFL <- return goneby - NilFL <- return $ joinEffects (p :<: ps) - return (reverseRL (p :<: ps), mapFL_FL Normal xs) - Right (l :> p'') -> - case allNormal l of - Just xs'' -> mac ps xs'' (p'' :>: goneby) - Nothing -> - case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of - a :> p' :> b -> - do (b', xs') <- mac b xs goneby - let pa = joinEffects $ p' :<: a - NilFL <- return pa - return (reverseRL (p' :<: a) +>+ b', xs') - -geteff :: PrimPatch prim => [Non (RealPatch prim) wX] -> FL prim wX wY - -> ([Non (RealPatch prim) wX], FL (RealPatch prim) wX wY) -geteff _ NilFL = ([], NilFL) -geteff ix (x :>: xs) | Just ix' <- mapM (commuteOrRemFromCtx (Normal x)) ix = - case geteff ix' xs of - (ns, xs') -> ( non (Normal x) : map (commuteOrAddToCtx (Normal x)) ns - , Normal x :>: xs') -geteff ix xx = - case mergeConflictingNons ix of - Nothing -> errorDoc $ - redText "mergeConflictingNons failed in geteff: ix" $$ - showNons ix $$ redText "xx" $$ showPatch xx - Just rix -> - case mergeAfterConflicting rix xx of - Just (a, x) -> - ( map (commuteOrAddToCtxRL (reverseFL a)) $ toNons x - , a +>+ x) - Nothing -> - errorDoc $ - redText "mergeAfterConflicting failed in geteff" $$ - redText "where ix" $$ showNons ix $$ - redText "and xx" $$ showPatch xx $$ - redText "and rix" $$ showPatch rix - -xx2nons :: PrimPatch prim => [Non (RealPatch prim) wX] -> FL prim wX wY - -> [Non (RealPatch prim) wX] -xx2nons ix xx = fst $ geteff ix xx - -xx2patches :: PrimPatch prim => [Non (RealPatch prim) wX] -> FL prim wX wY - -> FL (RealPatch prim) wX wY -xx2patches ix xx = snd $ geteff ix xx - --- | If @xs@ consists only of 'Normal' patches, 'allNormal' @xs@ returns --- @Just pxs@ those patches (so @lengthFL pxs == lengthFL xs@). --- Otherwise, it returns 'Nothing'. -allNormal :: FL (RealPatch prim) wX wY -> Maybe (FL prim wX wY) -allNormal (Normal x :>: xs) = (x :>: ) `fmap` allNormal xs -allNormal NilFL = Just NilFL -allNormal _ = Nothing - --- | This is used for unit-testing and for internal sanity checks -isConsistent :: PrimPatch prim => RealPatch prim wX wY -> Maybe Doc -isConsistent (Normal _) = Nothing -isConsistent (Duplicate _) = Nothing -isConsistent (Etacilpud _) = Nothing -isConsistent c@(InvConflictor{}) = isConsistent (invert c) -isConsistent (Conflictor im mm m@(Non deps _)) - | not $ everyoneConflicts im = - Just $ redText "Someone doesn't conflict in im in isConsistent" - | Just _ <- commuteOrRemFromCtxFL rmm m, _ :>: _ <- mm = - Just $ redText "m doesn't conflict with mm in isConsistent" - | any (\x -> any (x `conflictsWith`) nmm) im = - Just $ redText "mm conflicts with im in isConsistent where nmm is" $$ - showNons nmm - | Nothing <- (nmm ++ im) `minus` toNons deps = - Just $ redText "dependencies not in conflict:" $$ - showNons (toNons deps) $$ - redText "compared with deps itself:" $$ - showPatch deps - | otherwise = - case allConflictsWith m im of - (im1, []) | im1 `eqSet` im -> Nothing - (_, imnc) -> Just $ redText ("m doesn't conflict with im in " - ++ "isConsistent. unconflicting:") $$ - showNons imnc - where (nmm, rmm) = geteff im mm - -everyoneConflicts :: PrimPatch prim => [Non (RealPatch prim) wX] -> Bool -everyoneConflicts [] = True -everyoneConflicts (x : xs) = case allConflictsWith x xs of - ([], _) -> False - (_, xs') -> everyoneConflicts xs' - -prim2real :: prim wX wY -> RealPatch prim wX wY -prim2real = Normal - -instance MaybeInternal (RealPatch prim) -instance NameHack (RealPatch prim) -instance RecontextRebase (RealPatch prim) -instance PrimPatch prim => Patchy (RealPatch prim) -instance PatchDebug prim => PatchDebug (RealPatch prim) - -mergeWith :: PrimPatch prim => Non (RealPatch prim) wX - -> [Non (RealPatch prim) wX] -> Sealed (FL prim wX) -mergeWith p [] = effect `mapSeal` unNon p -mergeWith p xs = - mergeall . map unNon . (p :) . unconflicting_of $ nonDependsOrConflictsP xs - where - nonDependsOrConflictsP = - filter (\x -> not ((p `dependsUpon` x) || (p `conflictsWith` x))) - mergeall :: PrimPatch prim => [Sealed (FL (RealPatch prim) wX)] - -> Sealed (FL prim wX) - mergeall [Sealed x] = Sealed $ effect x - mergeall [] = Sealed NilFL - mergeall (Sealed x : Sealed y : rest) = - case merge (x :\/: y) of - y' :/\: _ -> mergeall (Sealed (x +>+ y') : rest) - unconflicting_of [] = [] - unconflicting_of (q : qs) = case allConflictsWith q qs of - ([], _) -> q : qs - (_, nc) -> unconflicting_of nc - -instance PrimPatch prim => Conflict (RealPatch prim) where - conflictedEffect (Duplicate (Non _ x)) = [IsC Duplicated x] - conflictedEffect (Etacilpud _) = impossible - conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x] - conflictedEffect (InvConflictor{}) = impossible - conflictedEffect (Normal x) = [IsC Okay x] - resolveConflicts (Conflictor ix xx x) = [mangledUnravelled : unravelled] - where - mangledUnravelled = mangleUnravelled unravelled - unravelled = nub $ filter isCons $ map (`mergeWith` xIxNonXX) xIxNonXX - xIxNonXX = x : ix ++ nonxx - nonxx = nonxx_ (reverseFL $ xx2patches ix xx) - -- |nonxx_ takes an RL of patches, and returns a singleton list - -- containing a Non, in the case where we have a Normal patch at the - -- end of the list (using the rest of the RL as context), and an empty - -- list otherwise. - nonxx_ :: RL (RealPatch prim) wX wY -> [Non (RealPatch prim) wX] - nonxx_ (Normal q :<: qs) = [Non (reverseRL qs) q] - nonxx_ _ = [] - isCons = unseal (not . nullFL) - resolveConflicts _ = [] - -instance PrimPatch prim => CommuteNoConflicts (RealPatch prim) where - commuteNoConflicts (d1@(Duplicate _) :> d2@(Duplicate _)) = Just (d2 :> d1) - commuteNoConflicts (e@(Etacilpud _) :> d@(Duplicate _)) = Just (d :> e) - commuteNoConflicts (d@(Duplicate _) :> e@(Etacilpud _)) = Just (e :> d) - commuteNoConflicts (e1@(Etacilpud _) :> e2@(Etacilpud _)) = Just (e2 :> e1) - - -- If the duplicate is @x@, as a 'Non', with @invert x@ as the context, - -- then it is the patch the duplicate @d@ represents, so commuting results - -- in the same two patches (since we'd make one a duplicate, and the other - -- would become @x@ as it would no longer be duplicated). - -- Otherwise, we commute past, or remove @invert x@ from the context of @d@ - -- to obtain a new Duplicate. - commuteNoConflicts orig@(x :> Duplicate d) = - if d == commuteOrAddToCtx (invert x) (non x) - then Just orig - else do d' <- commuteOrRemFromCtx (invert x) d - return (Duplicate d' :> x) - - -- Commuting a Duplicate and any other patch simply places @invert x@ into - -- the context of the non @d@, by commuting past, or adding to the context. - commuteNoConflicts (Duplicate d :> x) = - Just (x :> Duplicate (commuteOrAddToCtx (invert x) d)) - - -- handle Etacilpud cases by first inverting, then using the previous - -- definitions. - commuteNoConflicts c@(Etacilpud _ :> _) = invertCommuteNC c - commuteNoConflicts c@(_ :> Etacilpud _) = invertCommuteNC c - - -- Two normal patches should be simply commuted (assuming the can). - commuteNoConflicts (Normal x :> Normal y) = do - y' :> x' <- commute (x :> y) - return (Normal y' :> Normal x') - - -- Commuting a Normal patch past a Conflictor first commutes @x@ past the - -- effect of the Conflictor, then commutes the resulting @x'@ past the - -- conflicting patch and the already-undone patches. The commuting must be - -- done in this order to make the contexts match up (@iy@ and @y@ are made - -- in the context before @yy@ have their effect, so we need to commute past - -- the effect of @yy@ first). - commuteNoConflicts (Normal x :> Conflictor iy yy y) = do - iyy' :> x' <- commuteFL (x :> invert yy) - y' : iy' <- mapM (Normal x' >*) (y : iy) - return (Conflictor iy' (invert iyy') y' :> Normal x') - - -- Handle via the previous case, using the inverting commuter. - commuteNoConflicts c@(InvConflictor{} :> Normal _) = invertCommuteNC c - - -- Commuting a Conflictor past a Normal patch is the dual operation to - -- commuting a Normal patch past a Conflictor. - commuteNoConflicts (Conflictor iy yy y :> Normal x) = do - y' : iy' <- mapM (*> Normal x) (y : iy) - x' :> iyy' <- commuteRL (invertFL yy :> x) - return (Normal x' :> Conflictor iy' (invertRL iyy') y') - - -- Handle via the previous case, using the inverting commuter. - commuteNoConflicts c@(Normal _ :> InvConflictor{}) = invertCommuteNC c - - -- Commuting two Conflictors, c1 and c2, first commutes the Conflictors' - -- effects, then commutes the effect of c1 and c2 and the other's - -- already-undone, and conflicting patch, to bring the already-undone and - -- conflicting patch into the context of the commuted effects. - commuteNoConflicts (Conflictor ix xx x :> Conflictor iy yy y) = do - xx' :> yy' <- commute (yy :> xx) - x':ix' <- mapM (yy >>*) (x:ix) - y':iy' <- mapM (*>> xx') (y:iy) - False <- return $ any (conflictsWith y) (x':ix') - False <- return $ any (conflictsWith x') iy - return (Conflictor iy' yy' y' :> Conflictor ix' xx' x') - - -- Handle via the previous case, using the inverting commuter. - commuteNoConflicts c@(InvConflictor{} :> InvConflictor{}) = - invertCommuteNC c - - commuteNoConflicts (InvConflictor ix xx x :> Conflictor iy yy y) = do - iyy' :> xx' <- commute (xx :> invert yy) - y':iy' <- mapM (xx' >>*) (y:iy) - x':ix' <- mapM (invertFL iyy' >>*) (x:ix) - False <- return $ any (conflictsWith y') (x':ix') - False <- return $ any (conflictsWith x') iy' - return (Conflictor iy' (invert iyy') y' :> InvConflictor ix' xx' x') - - commuteNoConflicts (Conflictor iy' yy' y' :> InvConflictor ix' xx' x') = do - xx :> iyy <- commute (invert yy' :> xx') - y:iy <- mapM (*>> xx') (y':iy') - x:ix <- mapM (*>> yy') (x':ix') - False <- return $ any (conflictsWith y') (x':ix') - False <- return $ any (conflictsWith x') iy' - return (InvConflictor ix xx x :> Conflictor iy (invert iyy) y) - -instance PrimPatch prim => Check (RealPatch prim) where - isInconsistent = isConsistent - -instance FromPrim (RealPatch prim) where - fromPrim = prim2real - -instance ToFromPrim (RealPatch prim) where - toPrim (Normal p) = Just p - toPrim _ = Nothing - -instance PrimPatch prim => MyEq (RealPatch prim) where - (Duplicate x) =\/= (Duplicate y) | x == y = IsEq - (Etacilpud x) =\/= (Etacilpud y) | x == y = IsEq - (Normal x) =\/= (Normal y) = x =\/= y - (Conflictor cx xx x) =\/= (Conflictor cy yy y) - | map commuteOrAddIXX cx `eqSet` map commuteOrAddIYY cy - && commuteOrAddIXX x == commuteOrAddIYY y = xx =/\= yy - where - commuteOrAddIXX = commutePrimsOrAddToCtx (invertFL xx) - commuteOrAddIYY = commutePrimsOrAddToCtx (invertFL yy) - (InvConflictor cx xx x) =\/= (InvConflictor cy yy y) - | cx `eqSet` cy && x == y = xx =\/= yy - _ =\/= _ = NotEq - -eqSet :: Eq a => [a] -> [a] -> Bool -eqSet [] [] = True -eqSet (x:xs) xys | Just ys <- remove1 x xys = eqSet xs ys -eqSet _ _ = False - -remove1 :: Eq a => a -> [a] -> Maybe [a] -remove1 x (y : ys) = if x == y then Just ys else (y :) `fmap` remove1 x ys -remove1 _ [] = Nothing - -minus :: Eq a => [a] -> [a] -> Maybe [a] -minus xs [] = Just xs -minus xs (y:ys) = do xs' <- remove1 y xs - xs' `minus` ys - -invertNon :: PrimPatch prim => Non (RealPatch prim) wX - -> Non (RealPatch prim) wX -invertNon (Non c x) - | Just rc' <- removeRL nix (reverseFL c) = Non (reverseRL rc') (invert x) - | otherwise = commuteOrAddToCtxRL (Normal x :<: reverseFL c) $ non nix - where - nix = Normal $ invert x - -nonTouches :: PatchInspect prim => Non (RealPatch prim) wX -> [FilePath] -nonTouches (Non c x) = listTouchedFiles (c +>+ fromPrim x :>: NilFL) - -nonHunkMatches :: PatchInspect prim => (BC.ByteString -> Bool) - -> Non (RealPatch prim) wX -> Bool -nonHunkMatches f (Non c x) = hunkMatches f c || hunkMatches f x - -toNons :: forall p wX wY . (Conflict p, Patchy p, PatchListFormat p, - ToFromPrim p, Nonable p, ShowPatchBasic (PrimOf p), ShowPatchBasic p) - => FL p wX wY -> [Non p wX] -toNons xs = map lastNon $ initsFL xs - where lastNon :: Sealed ((p :> FL p) wX) -> Non p wX - lastNon (Sealed xxx) = - case lastNon_aux xxx of - deps :> p :> _ -> - case non p of - Non NilFL pp -> Non (reverseRL deps) pp - Non ds pp -> - errorDoc $ redText "Weird case in toNons" $$ - redText "please report this bug!" $$ - (case xxx of - z :> zs -> showPatch (z :>: zs)) $$ - redText "ds are" $$ showPatch ds $$ - redText "pp is" $$ showPatch pp - - reverseFoo :: (p :> FL p) wX wZ -> (RL p :> p) wX wZ - reverseFoo (p :> ps) = rf NilRL p ps - where - rf :: RL p wA wB -> p wB wC -> FL p wC wD - -> (RL p :> p) wA wD - rf rs l NilFL = rs :> l - rf rs x (y :>: ys) = rf (x :<: rs) y ys - - lastNon_aux :: (p :> FL p) wX wZ -> (RL p :> p :> RL p) wX wZ - lastNon_aux = commuteWhatWeCanRL . reverseFoo - -initsFL :: Patchy p => FL p wX wY -> [Sealed ((p :> FL p) wX)] -initsFL NilFL = [] -initsFL (x :>: xs) = - Sealed (x :> NilFL) : - map (\(Sealed (y :> xs')) -> Sealed (x :> y :>: xs')) (initsFL xs) - -filterConflictsFL :: PrimPatch prim => Non (RealPatch prim) wX - -> FL prim wX wY -> (FL prim :> FL prim) wX wY -filterConflictsFL _ NilFL = NilFL :> NilFL -filterConflictsFL n (p :>: ps) - | Just n' <- commuteOrRemFromCtx (fromPrim p) n = - case filterConflictsFL n' ps of - p1 :> p2 -> p :>: p1 :> p2 - | otherwise = case commuteWhatWeCanFL (p :> ps) of - p1 :> p' :> p2 -> - case filterConflictsFL n p1 of - p1a :> p1b -> p1a :> p1b +>+ p' :>: p2 - -instance Invert prim => Invert (RealPatch prim) where - invert (Duplicate d) = Etacilpud d - invert (Etacilpud d) = Duplicate d - invert (Normal p) = Normal (invert p) - invert (Conflictor x c p) = InvConflictor x c p - invert (InvConflictor x c p) = Conflictor x c p - -instance PrimPatch prim => Commute (RealPatch prim) where - commute (x :> y) | Just (y' :> x') <- - commuteNoConflicts (assertConsistent x :> assertConsistent y) = - Just (y' :> x') - - -- These patches conflicted, since we failed to commuteNoConflicts in the - -- case above. - commute (Normal x :> Conflictor a1'nop2 n1'x p1') - | Just rn1' <- removeRL x (reverseFL n1'x) = do - let p2 : n1nons = reverse $ xx2nons a1'nop2 $ reverseRL (x :<: rn1') - a2 = p1' : a1'nop2 ++ n1nons - case (a1'nop2, reverseRL rn1', p1') of - ([], NilFL, Non c y) | NilFL <- joinEffects c -> - Just (Normal y :> Conflictor a1'nop2 (y :>: NilFL) p2) - (a1, n1, _) -> - Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2) - - -- Handle using the inverting commuter, and the previous case. N.b. this - -- is innefficient, since we'll have to also try commuteNoConflicts again - -- (which we know will fail, since we got here). - commute c@(InvConflictor{} :> Normal _) = invertCommute c - - commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2) - | Just a2_minus_p1 <- remove1 p1' a2 - , not (p2 `dependsUpon` p1') = do - let n1nons = map (commutePrimsOrAddToCtx n2) $ xx2nons a1 n1 - n2nons = xx2nons a2 n2 - Just a2_minus_p1n1 = a2_minus_p1 `minus` n1nons - n2n1 = n2 +>+ n1 - a1' = map (commutePrimsOrAddToCtx n2) a1 - p2ooo = remNons a1' p2 - n1' :> n2' <- return $ filterConflictsFL p2ooo n2n1 - let n1'n2'nons = xx2nons a2_minus_p1n1 (n1' +>+ n2') - n1'nons = take (lengthFL n1') n1'n2'nons - n2'nons = drop (lengthFL n1') n1'n2'nons - Just a1'nop2 = (a2 ++ n2nons) `minus` (p1' : n1'nons) - Just a2'o = - fst (allConflictsWith p2 $ a2_minus_p1 ++ n2nons) - `minus` n2'nons - Just a2' = - mapM (commuteOrRemFromCtxFL (xx2patches a1'nop2 n1')) a2'o - Just p2' = commuteOrRemFromCtxFL (xx2patches a1'nop2 n1') p2 - case (a2', n2', p2') of - ([], NilFL, Non c x) -> - case joinEffects c of - NilFL -> let n1'x = n1' +>+ x :>: NilFL in - Just (Normal x :> Conflictor a1'nop2 n1'x p1') - _ -> impossible - _ -> Just (c1 :> c2) - where - c1 = Conflictor a2' n2' p2' - c2 = Conflictor (p2 : a1'nop2) n1' p1' - - where (_, rpn2) = geteff a2 n2 - p1' = commuteOrAddToCtxRL (reverseFL rpn2) p1 - - -- Handle using the inverting commuter, and the previous case. This is also - -- innefficient, since we'll have to also try commuteNoConflicts again - -- (which we know will fail, since we got here). - commute c@(InvConflictor{} :> InvConflictor{}) = invertCommute c - - commute _ = Nothing - -instance PrimPatch prim => Merge (RealPatch prim) where - merge (InvConflictor{} :\/: _) = impossible - merge (_ :\/: InvConflictor{}) = impossible - merge (Etacilpud _ :\/: _) = impossible - merge (_ :\/: Etacilpud _) = impossible - - - merge (Duplicate a :\/: Duplicate b) = Duplicate b :/\: Duplicate a - -- We had a FIXME comment on this case, why? - merge (Duplicate a :\/: b) = - b :/\: Duplicate (commuteOrAddToCtx (invert b) a) - - -- Handle using the swap merge and the previous case. - merge m@(_ :\/: Duplicate _) = swapMerge m - - -- When merging x and y, we do a bunch of what look like "consistency" - -- check merges. If the resulting y'' and y are equal, then we succeed. - -- If the first case fails, we check for equal patches (which wouldn't - -- commute) and return a Duplicate on both sides of the merge, in that - -- case. - merge (x :\/: y) - | Just (y' :> ix') <- - commute (invert (assertConsistent x) :> assertConsistent y) - , Just (y'' :> _) <- commute (x :> y') - , IsEq <- y'' =\/= y = - assertConsistent y' :/\: invert (assertConsistent ix') - -- If we detect equal patches, we have a duplicate. - | IsEq <- x =\/= y - , n <- commuteOrAddToCtx (invert x) $ non x = - Duplicate n :/\: Duplicate n - - -- We know that these two patches conflict, and aren't Duplicates, since we - -- failed the previous case. We therefore create basic Conflictors, which - -- undo the other patch. - merge (nx@(Normal x) :\/: ny@(Normal y)) = cy :/\: cx - where - cy = Conflictor [] (x :>: NilFL) (non ny) - cx = Conflictor [] (y :>: NilFL) (non nx) - - -- If a Normal patch @x@ and a Conflictor @cy@ conflict, we add @x@ to the - -- effect of @cy@ on one side, and create a Conflictor that has no effect, - -- but has the already-undone and conflicted patch of @cy@ and some foos as - -- the already-undone on the other side. - -- - -- TODO: what is foo? - -- Why do we need nyy? I think @x'@ is @x@ in the context of @yy@. - merge (Normal x :\/: Conflictor iy yy y) = - Conflictor iy yyx y :/\: Conflictor (y : iy ++ nyy) NilFL x' - where yyx = yy +>+ x :>: NilFL - (x' : nyy) = reverse $ xx2nons iy yyx - - -- Handle using the swap merge and the previous case. - merge m@(Conflictor{} :\/: Normal _) = swapMerge m - - -- mH see also cH - merge (Conflictor ix xx x :\/: Conflictor iy yy y) = - case pullCommonRL (reverseFL xx) (reverseFL yy) of - CommonRL rxx1 ryy1 c -> - case commuteRLFL (ryy1 :> invertRL rxx1) of - Just (ixx' :> ryy') -> - let xx' = invert ixx' - yy' = reverseRL ryy' - y' : iy' = - map (commutePrimsOrAddToCtx xx') (y : iy) - x' : ix' = - map (commutePrimsOrAddToCtx ryy') (x : ix) - nyy' = xx2nons iy' yy' - nxx' = xx2nons ix' xx' - icx = drop (lengthRL rxx1) $ - xx2nons ix (reverseRL $ c +<+ rxx1) - ic' = map (commutePrimsOrAddToCtx ryy') icx - -- +++ is a more efficient version of nub (iy' ++ - -- ix') given that we know each element shows up - -- only once in either list. - ixy' = ic' ++ (iy' +++ ix') - c1 = Conflictor (x' : ixy' ++ nxx') yy' y' - c2 = Conflictor (y' : ixy' ++ nyy') xx' x' in - c1 :/\: c2 - Nothing -> impossible - -instance PatchInspect prim => PatchInspect (RealPatch prim) where - listTouchedFiles (Duplicate p) = nonTouches p - listTouchedFiles (Etacilpud p) = nonTouches p - listTouchedFiles (Normal p) = listTouchedFiles p - listTouchedFiles (Conflictor x c p) = - nubSort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p - listTouchedFiles (InvConflictor x c p) = - nubSort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p - - hunkMatches f (Duplicate p) = nonHunkMatches f p - hunkMatches f (Etacilpud p) = nonHunkMatches f p - hunkMatches f (Normal p) = hunkMatches f p - hunkMatches f (Conflictor x c p) = - any (nonHunkMatches f) x || hunkMatches f c || nonHunkMatches f p - hunkMatches f (InvConflictor x c p) = - any (nonHunkMatches f) x || hunkMatches f c || nonHunkMatches f p - -allConflictsWith :: PrimPatch prim => Non (RealPatch prim) wX - -> [Non (RealPatch prim) wX] - -> ([Non (RealPatch prim) wX], [Non (RealPatch prim) wX]) -allConflictsWith x ys = acw $ partition (conflictsWith x) ys - where - acw ([], nc) = ([], nc) - acw (c:cs, nc) = case allConflictsWith c nc of - (c1, nc1) -> case acw (cs, nc1) of - (xs', nc') -> (c : c1 ++ xs', nc') - -conflictsWith :: PrimPatch prim => Non (RealPatch prim) wX - -> Non (RealPatch prim) wX -> Bool -conflictsWith x y | x `dependsUpon` y || y `dependsUpon` x = False -conflictsWith x (Non cy y) = - case commuteOrRemFromCtxFL cy x of - Just (Non cx' x') -> - let iy = fromPrim $ invert y in - case commuteFLorComplain (iy :> cx' +>+ fromPrim x' :>: NilFL) of - Right _ -> False - Left _ -> True - Nothing -> True - -dependsUpon :: PrimPatch prim => Non (RealPatch prim) wX - -> Non (RealPatch prim) wX -> Bool -dependsUpon (Non xs _) (Non ys y) = - case removeSubsequenceFL (ys +>+ fromPrim y :>: NilFL) xs of - Just _ -> True - Nothing -> False - -(+++) :: Eq a => [a] -> [a] -> [a] -[] +++ x = x -x +++ [] = x -(x:xs) +++ xys | Just ys <- remove1 x xys = x : (xs +++ ys) - | otherwise = x : (xs +++ xys) - -swapMerge :: PrimPatch prim => (RealPatch prim :\/: RealPatch prim) wX wY - -> (RealPatch prim :/\: RealPatch prim) wX wY -swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x' - -invertCommute :: PrimPatch prim => (RealPatch prim :> RealPatch prim) wX wY - -> Maybe ((RealPatch prim :> RealPatch prim) wX wY) -invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x) - return (invert iy' :> invert ix') - -invertCommuteNC :: PrimPatch prim => (RealPatch prim :> RealPatch prim) wX wY - -> Maybe ((RealPatch prim :> RealPatch prim) wX wY) -invertCommuteNC (x :> y) = do - ix' :> iy' <- commuteNoConflicts (invert y :> invert x) - return (invert iy' :> invert ix') - --- | 'pullCommon' @xs ys@ returns the set of patches that can be commuted out --- of both @xs@ and @ys@ along with the remnants of both lists -pullCommon :: (Patchy p, MyEq p) => FL p wO wX -> FL p wO wY -> Common p wO wX wY -pullCommon NilFL ys = Common NilFL NilFL ys -pullCommon xs NilFL = Common NilFL xs NilFL -pullCommon (x :>: xs) xys | Just ys <- removeFL x xys = - case pullCommon xs ys of - Common c xs' ys' -> Common (x :>: c) xs' ys' -pullCommon (x :>: xs) ys = - case commuteWhatWeCanFL (x :> xs) of - xs1 :> x' :> xs2 -> case pullCommon xs1 ys of - Common c xs1' ys' -> Common c (xs1' +>+ x' :>: xs2) ys' - --- | 'Common' @cs xs ys@ represents two sequences of patches that have @cs@ in --- common, in other words @cs +>+ xs@ and @cs +>+ ys@ -data Common p wO wX wY where - Common :: FL p wO wI -> FL p wI wX -> FL p wI wY -> Common p wO wX wY - --- | 'pullCommonRL' @xs ys@ returns the set of patches that can be commuted --- out of both @xs@ and @ys@ along with the remnants of both lists -pullCommonRL :: (Patchy p, MyEq p) => RL p wX wO -> RL p wY wO -> CommonRL p wX wY wO -pullCommonRL NilRL ys = CommonRL NilRL ys NilRL -pullCommonRL xs NilRL = CommonRL xs NilRL NilRL -pullCommonRL (x :<: xs) xys | Just ys <- removeRL x xys = - case pullCommonRL xs ys of - CommonRL xs' ys' c -> CommonRL xs' ys' (x :<: c) -pullCommonRL (x :<: xs) ys = - case commuteWhatWeCanRL (xs :> x) of - xs1 :> x' :> xs2 -> - case pullCommonRL xs2 ys of - CommonRL xs2' ys' c -> CommonRL (xs2' +<+ x' :<: xs1) ys' c - --- | 'CommonRL' @xs ys cs@' represents two sequences of patches that have @cs@ --- in common, in other words @xs +<+ cs@ and @ys +<+ cs@ -data CommonRL p wX wY wF where - CommonRL :: RL p wX wI -> RL p wY wI -> RL p wI wF -> CommonRL p wX wY wF - -instance PrimPatch prim => Apply (RealPatch prim) where - type ApplyState (RealPatch prim) = ApplyState prim - apply p = apply (effect p) - -instance PrimPatch prim => RepairToFL (RealPatch prim) where - applyAndTryToFixFL (Normal p) = - mapMaybeSnd (mapFL_FL Normal) `liftM` applyAndTryToFixFL p - applyAndTryToFixFL x = do apply x; return Nothing - -instance PatchListFormat (RealPatch prim) where - -- In principle we could use ListFormatDefault when prim /= V1 Prim patches, - -- as those are the only case where we need to support a legacy on-disk - -- format. In practice we don't expect RealPatch to be used with any other - -- argument anyway, so it doesn't matter. - patchListFormat = ListFormatV2 - -duplicate, etacilpud, conflictor, rotcilfnoc :: String -duplicate = "duplicate" -etacilpud = "etacilpud" -conflictor = "conflictor" -rotcilfnoc = "rotcilfnoc" - -instance PrimPatch prim => ShowPatchBasic (RealPatch prim) where - showPatch (Duplicate d) = blueText duplicate $$ showNon d - showPatch (Etacilpud d) = blueText etacilpud $$ showNon d - showPatch (Normal p) = showPrim NewFormat p - showPatch (Conflictor i NilFL p) = - blueText conflictor <+> showNons i <+> blueText "[]" $$ showNon p - showPatch (Conflictor i cs p) = - blueText conflictor <+> showNons i <+> blueText "[" $$ - showPrimFL NewFormat cs $$ - blueText "]" $$ - showNon p - showPatch (InvConflictor i NilFL p) = - blueText rotcilfnoc <+> showNons i <+> blueText "[]" $$ showNon p - showPatch (InvConflictor i cs p) = - blueText rotcilfnoc <+> showNons i <+> blueText "[" $$ - showPrimFL NewFormat cs $$ - blueText "]" $$ - showNon p - -instance PrimPatch prim => ShowPatch (RealPatch prim) where - showContextPatch (Normal p) = showContextPatch p - showContextPatch c = return $ showPatch c - summary = plainSummary - summaryFL = plainSummary - thing _ = "change" - -instance PrimPatch prim => ReadPatch (RealPatch prim) where - readPatch' = do - skipSpace - let str = string . BC.pack - readConflictorPs = do - i <- readNons - ps <- bracketedFL (readPrim NewFormat) '[' ']' - p <- readNon - return (i, ps, p) - choice [ do str duplicate - p <- readNon - return $ Sealed $ Duplicate p - , do str etacilpud - p <- readNon - return $ Sealed $ Etacilpud p - , do str conflictor - (i, Sealed ps, p) <- readConflictorPs - return $ Sealed $ Conflictor i (unsafeCoerceP ps) p - , do str rotcilfnoc - (i, Sealed ps, p) <- readConflictorPs - return $ Sealed $ InvConflictor i ps p - , do Sealed p <- readPrim NewFormat - return $ Sealed $ Normal p - ] - -instance Show2 prim => Show (RealPatch prim wX wY) where - showsPrec d (Normal prim) = - showParen (d > appPrec) $ showString "Darcs.Patch.V2.Real.Normal " . showsPrec2 (appPrec + 1) prim - - showsPrec d (Duplicate x) = - showParen (d > appPrec) $ showString "Darcs.Patch.V2.Real.Duplicate " . showsPrec (appPrec + 1) x - - showsPrec d (Etacilpud x) = - showParen (d > appPrec) $ showString "Darcs.Patch.V2.Etacilpud " . showsPrec (appPrec + 1) x - - showsPrec d (Conflictor ix xx x) = - showParen (d > appPrec) $ - showString "Darcs.Patch.V2.Real.Conflictor " . showsPrec (appPrec + 1) ix . - showString " " . showsPrec (appPrec + 1) xx . - showString " " . showsPrec (appPrec + 1) x - - showsPrec d (InvConflictor ix xx x) = - showParen (d > appPrec) $ - showString "Darcs.Patch.V2.Real.InvConflictor " . showsPrec (appPrec + 1) ix . - showString " " . showsPrec (appPrec + 1) xx . - showString " " . showsPrec (appPrec + 1) x - -instance Show2 prim => Show1 (RealPatch prim wX) where - showDict1 = ShowDictClass - -instance Show2 prim => Show2 (RealPatch prim) where - showDict2 = ShowDictClass - -instance PrimPatch prim => Nonable (RealPatch prim) where - non (Duplicate d) = d - non (Etacilpud d) = invertNon d -- FIXME !!! ??? - non (Normal p) = Non NilFL p - non (Conflictor _ xx x) = commutePrimsOrAddToCtx (invertFL xx) x - non (InvConflictor _ _ n) = invertNon n - -instance PrimPatch prim => Effect (RealPatch prim) where - effect (Duplicate _) = NilFL - effect (Etacilpud _) = NilFL - effect (Normal p) = p :>: NilFL - effect (Conflictor _ e _) = invert e - effect (InvConflictor _ e _) = e - effectRL (Duplicate _) = NilRL - effectRL (Etacilpud _) = NilRL - effectRL (Normal p) = p :<: NilRL - effectRL (Conflictor _ e _) = invertFL e - effectRL (InvConflictor _ e _) = reverseFL e - -instance IsHunk prim => IsHunk (RealPatch prim) where - isHunk rp = do Normal p <- return rp - isHunk p diff --git a/src/Darcs/Patch/V2/RepoPatch.hs b/src/Darcs/Patch/V2/RepoPatch.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/V2/RepoPatch.hs @@ -0,0 +1,945 @@ +-- Copyright (C) 2007 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. + +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} +{-# LANGUAGE CPP #-} + + +module Darcs.Patch.V2.RepoPatch + ( RepoPatchV2(..) + , prim2repopatchV2 + , isConsistent + , isForward + , isDuplicate + , mergeUnravelled + ) where + +import Prelude () +import Darcs.Prelude hiding ( (*>) ) + +import Control.Monad ( mplus, liftM ) +import qualified Data.ByteString.Char8 as BC ( ByteString, pack ) +import Data.Maybe ( fromMaybe ) +import Data.List ( partition, nub ) + +import Darcs.Patch.Commute ( commuteFL, commuteFLorComplain, commuteRL + , commuteRLFL ) +import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) + , IsConflictedPrim(..), ConflictState(..) + , mangleUnravelled ) +import Darcs.Patch.Debug +import Darcs.Patch.Effect ( Effect(..) ) +import Darcs.Patch.FileHunk ( IsHunk(..) ) +import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..) + , FileNameFormat(NewFormat) ) +import Darcs.Patch.Invert ( invertFL, invertRL ) +import Darcs.Patch.Merge ( Merge(..) ) +import Darcs.Patch.Prim ( FromPrim(..), ToFromPrim(..), showPrim, showPrimFL + , readPrim, PrimOf, PrimPatchBase, PrimPatch ) +import Darcs.Patch.Read ( bracketedFL ) +import Darcs.Patch.ReadMonads ( skipSpace, string, choice ) +import Darcs.Patch.Repair ( mapMaybeSnd, RepairToFL(..), Check(..) ) +import Darcs.Patch.Patchy ( Patchy, Apply(..), Commute(..), PatchInspect(..) + , ReadPatch(..), ShowPatch(..), Invert(..) ) +import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL + , genCommuteWhatWeCanRL, removeRL, removeFL + , removeSubsequenceFL ) +import Darcs.Patch.Show ( ShowPatchBasic(..) ) +import Darcs.Patch.Summary ( plainSummary ) +import Darcs.Patch.V2.Non ( Non(..), Nonable(..), unNon, showNons, showNon + , readNons, readNon, commutePrimsOrAddToCtx + , commuteOrAddToCtx, commuteOrAddToCtxRL + , commuteOrRemFromCtx, commuteOrRemFromCtxFL + , remNons, (*>), (>*), (*>>), (>>*) ) +import Data.List.Ordered ( nubSort ) +import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) +import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) ) +import Darcs.Patch.Witnesses.Ordered + ( FL(..), RL(..), (:>)(..), (+>+), (+<+) + , mapFL_FL, reverseFL, (:\/:)(..), (:/\:)(..) + , reverseRL, lengthFL, lengthRL, nullFL ) +import Darcs.Patch.Witnesses.Sealed + ( FlippedSeal(..), Sealed(Sealed), mapSeal + , unseal ) +import Darcs.Patch.Witnesses.Show + ( Show1(..), Show2(..), ShowDict(..) + , showsPrec2, appPrec + ) +import Darcs.Util.Printer.Color ( errorDoc, assertDoc ) + +import Darcs.Util.Printer ( Doc, blueText, redText, (<+>), ($$) ) + +#include "impossible.h" + +-- |'RepoPatchV2' is used to represents prim patches that are duplicates of, or +-- conflict with, another prim patch in the repository. +-- +-- @Normal prim@: A primitive patch +-- +-- @Duplicate x@: This patch has no effect since @x@ is already present in the +-- repository. +-- +-- @Etacilpud x: invert (Duplicate x)@ +-- +-- @Conflictor ix xx x@: +-- @ix@ is the set of patches: +-- * that conflict with @x@ and also conflict with another patch in the +-- repository. +-- * that conflict with a patch that conflict with @x@ +-- +-- @xx@ is the sequence of patches that conflict *only* with @x@ +-- +-- @x@ is the original, conflicting patch. +-- +-- @ix@ and @x@ are stored as @Non@ objects, which include any necessary +-- context to uniquely define the patch that is referred to. +-- +-- The intuition is that a Conflictor should have the effect of inverting any +-- patches that 'x' conflicts with, that haven't already been undone by another +-- Conflictor in the repository. +-- Therefore, the effect of a Conflictor is @invert xx@. +-- +-- @InvConflictor ix xx x@: like @invert (Conflictor ix xx x)@ +data RepoPatchV2 prim wX wY where + Duplicate :: Non (RepoPatchV2 prim) wX -> RepoPatchV2 prim wX wX + Etacilpud :: Non (RepoPatchV2 prim) wX -> RepoPatchV2 prim wX wX + Normal :: prim wX wY -> RepoPatchV2 prim wX wY + Conflictor :: [Non (RepoPatchV2 prim) wX] -> FL prim wX wY + -> Non (RepoPatchV2 prim) wX -> RepoPatchV2 prim wY wX + InvConflictor :: [Non (RepoPatchV2 prim) wX] -> FL prim wX wY + -> Non (RepoPatchV2 prim) wX -> RepoPatchV2 prim wX wY + +instance PrimPatch prim => PrimPatchBase (RepoPatchV2 prim) where + type PrimOf (RepoPatchV2 prim) = prim + +-- | 'isDuplicate' @p@ is @True@ if @p@ is either a 'Duplicate' or 'Etacilpud' +-- patch. +isDuplicate :: RepoPatchV2 prim wS wY -> Bool +isDuplicate (Duplicate _) = True +isDuplicate (Etacilpud _) = True +isDuplicate _ = False + +-- | 'isForward' @p@ is @True@ if @p@ is either an 'InvConflictor' or +-- 'Etacilpud'. +isForward :: PrimPatch prim => RepoPatchV2 prim wS wY -> Maybe Doc +isForward p = case p of + p@(InvConflictor{}) -> justRedP "An inverse conflictor" p + p@(Etacilpud _) -> justRedP "An inverse duplicate" p + _ -> Nothing + where + justRedP msg p = Just $ redText msg $$ showPatch p + +-- |'mergeUnravelled' is used when converting from Darcs V1 patches (Mergers) +-- to Darcs V2 patches (Conflictors). +mergeUnravelled :: PrimPatch prim => [Sealed ((FL prim) wX)] + -> Maybe (FlippedSeal (RepoPatchV2 prim) wX) +mergeUnravelled [] = Nothing +mergeUnravelled [_] = Nothing +mergeUnravelled ws = + case mergeUnravelled_private ws of + Nothing -> Nothing + Just NilRL -> bug "found no patches in mergeUnravelled" + Just (_ :<: z) -> Just $ FlippedSeal z + where + notNullS :: PrimPatch prim => Sealed ((FL prim) wX) -> Bool + notNullS (Sealed NilFL) = False + notNullS _ = True + + mergeUnravelled_private :: PrimPatch prim => [Sealed (FL prim wX)] + -> Maybe (RL (RepoPatchV2 prim) wX wX) + mergeUnravelled_private xs = let nonNullXs = filter notNullS xs in + reverseFL `fmap` mergeConflictingNons (map sealed2non nonNullXs) + + -- | 'sealed2non' @(Sealed xs)@ converts @xs@ to a 'Non'. + -- @xs@ must be non-empty since we split this list at the last patch, + -- taking @init xs@ as the context of @last xs@. + sealed2non :: Sealed ((FL prim) wX) -> Non (RepoPatchV2 prim) wX + sealed2non (Sealed xs) = + case reverseFL xs of + ys :<: y -> Non (mapFL_FL fromPrim $ reverseRL ys) y + NilRL -> bug "NilFL encountered in sealed2non" + +mergeConflictingNons :: PrimPatch prim => [Non (RepoPatchV2 prim) wX] + -> Maybe (FL (RepoPatchV2 prim) wX wX) +mergeConflictingNons ns = mcn $ map unNon ns + where mcn :: PrimPatch prim => [Sealed (FL (RepoPatchV2 prim) wX)] + -> Maybe (FL (RepoPatchV2 prim) wX wX) + mcn [] = Just NilFL + -- Apparently, the joinEffects call is a safety check "and could be + -- removed when we're sure of the code"! + mcn [Sealed p] = case joinEffects p of + NilFL -> Just p + _ -> Nothing + mcn (Sealed p1:Sealed p2:zs) = + case pullCommon p1 p2 of + Common c ps qs -> + case merge (ps :\/: qs) of + qs' :/\: _ -> mcn (Sealed (c +>+ ps +>+ qs'):zs) + +joinEffects :: forall p wX wY . (Effect p, Invert (PrimOf p), + Commute (PrimOf p), MyEq (PrimOf p)) => p wX wY + -> FL (PrimOf p) wX wY +joinEffects = joinInverses . effect + where joinInverses :: FL (PrimOf p) wA wB -> FL (PrimOf p) wA wB + joinInverses NilFL = NilFL + joinInverses (p :>: ps) = + let ps' = joinInverses ps in + fromMaybe (p :>: ps') $ removeFL (invert p) ps' + +assertConsistent :: PrimPatch prim => RepoPatchV2 prim wX wY + -> RepoPatchV2 prim wX wY +assertConsistent x = flip assertDoc x $ do + e <- isConsistent x + Just (redText "Inconsistent patch:" $$ showPatch x $$ e) + +-- | @mergeAfterConflicting@ takes as input a sequence of conflicting patches +-- @xxx@ (which therefore have no effect) and a sequence of primitive patches +-- @yyy@ that follow said sequence of conflicting patches, and may depend upon +-- some of the conflicting patches (as a resolution). + +-- The output is two sequences of patches the first consisting of a set of +-- mutually-conflicting patches, and the second having the same effect as the +-- original primitive patch sequence in the input. + +-- So far as I can tell, the second output is always identical to @mapFL Normal +-- yyy@ + +-- The first output is the set of patches from @xxx@ that are depended upon by +-- @yyy@. +mergeAfterConflicting :: PrimPatch prim => FL (RepoPatchV2 prim) wX wX + -> FL prim wX wY -> Maybe ( FL (RepoPatchV2 prim) wX wX + , FL (RepoPatchV2 prim) wX wY) +mergeAfterConflicting xxx yyy = mac (reverseFL xxx) yyy NilFL + where + mac :: PrimPatch prim + => RL (RepoPatchV2 prim) wX wY -> FL prim wY wZ + -> FL (RepoPatchV2 prim) wZ wA + -> Maybe (FL (RepoPatchV2 prim) wX wX, FL (RepoPatchV2 prim) wX wA) + mac NilRL xs goneby = case joinEffects goneby of + NilFL -> Just (NilFL, mapFL_FL Normal xs) + _ -> Nothing + mac (ps :<: p) xs goneby = + case commuteFLorComplain (p :> mapFL_FL Normal xs) of + Left _ -> + case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of + a :> p' :> b -> + do (b', xs') <- mac b xs goneby + let pa = joinEffects $ a :<: p' + NilFL <- return pa + return (reverseRL (a :<: p') +>+ b', xs') + `mplus` + do NilFL <- return goneby + NilFL <- return $ joinEffects (ps :<: p) + return (reverseRL (ps :<: p), mapFL_FL Normal xs) + Right (l :> p'') -> + case allNormal l of + Just xs'' -> mac ps xs'' (p'' :>: goneby) + Nothing -> + case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of + a :> p' :> b -> + do (b', xs') <- mac b xs goneby + let pa = joinEffects $ a :<: p' + NilFL <- return pa + return (reverseRL (a :<: p') +>+ b', xs') + +geteff :: PrimPatch prim => [Non (RepoPatchV2 prim) wX] -> FL prim wX wY + -> ([Non (RepoPatchV2 prim) wX], FL (RepoPatchV2 prim) wX wY) +geteff _ NilFL = ([], NilFL) +geteff ix (x :>: xs) | Just ix' <- mapM (commuteOrRemFromCtx (Normal x)) ix = + case geteff ix' xs of + (ns, xs') -> ( non (Normal x) : map (commuteOrAddToCtx (Normal x)) ns + , Normal x :>: xs') +geteff ix xx = + case mergeConflictingNons ix of + Nothing -> errorDoc $ + redText "mergeConflictingNons failed in geteff: ix" $$ + showNons ix $$ redText "xx" $$ showPatch xx + Just rix -> + case mergeAfterConflicting rix xx of + Just (a, x) -> + ( map (commuteOrAddToCtxRL (reverseFL a)) $ toNons x + , a +>+ x) + Nothing -> + errorDoc $ + redText "mergeAfterConflicting failed in geteff" $$ + redText "where ix" $$ showNons ix $$ + redText "and xx" $$ showPatch xx $$ + redText "and rix" $$ showPatch rix + +xx2nons :: PrimPatch prim => [Non (RepoPatchV2 prim) wX] -> FL prim wX wY + -> [Non (RepoPatchV2 prim) wX] +xx2nons ix xx = fst $ geteff ix xx + +xx2patches :: PrimPatch prim => [Non (RepoPatchV2 prim) wX] -> FL prim wX wY + -> FL (RepoPatchV2 prim) wX wY +xx2patches ix xx = snd $ geteff ix xx + +-- | If @xs@ consists only of 'Normal' patches, 'allNormal' @xs@ returns +-- @Just pxs@ those patches (so @lengthFL pxs == lengthFL xs@). +-- Otherwise, it returns 'Nothing'. +allNormal :: FL (RepoPatchV2 prim) wX wY -> Maybe (FL prim wX wY) +allNormal (Normal x :>: xs) = (x :>: ) `fmap` allNormal xs +allNormal NilFL = Just NilFL +allNormal _ = Nothing + +-- | This is used for unit-testing and for internal sanity checks +isConsistent :: PrimPatch prim => RepoPatchV2 prim wX wY -> Maybe Doc +isConsistent (Normal _) = Nothing +isConsistent (Duplicate _) = Nothing +isConsistent (Etacilpud _) = Nothing +isConsistent c@(InvConflictor{}) = isConsistent (invert c) +isConsistent (Conflictor im mm m@(Non deps _)) + | not $ everyoneConflicts im = + Just $ redText "Someone doesn't conflict in im in isConsistent" + | Just _ <- commuteOrRemFromCtxFL rmm m, _ :>: _ <- mm = + Just $ redText "m doesn't conflict with mm in isConsistent" + | any (\x -> any (x `conflictsWith`) nmm) im = + Just $ redText "mm conflicts with im in isConsistent where nmm is" $$ + showNons nmm + | Nothing <- (nmm ++ im) `minus` toNons deps = + Just $ redText "dependencies not in conflict:" $$ + showNons (toNons deps) $$ + redText "compared with deps itself:" $$ + showPatch deps + | otherwise = + case allConflictsWith m im of + (im1, []) | im1 `eqSet` im -> Nothing + (_, imnc) -> Just $ redText ("m doesn't conflict with im in " + ++ "isConsistent. unconflicting:") $$ + showNons imnc + where (nmm, rmm) = geteff im mm + +everyoneConflicts :: PrimPatch prim => [Non (RepoPatchV2 prim) wX] -> Bool +everyoneConflicts [] = True +everyoneConflicts (x : xs) = case allConflictsWith x xs of + ([], _) -> False + (_, xs') -> everyoneConflicts xs' + +prim2repopatchV2 :: prim wX wY -> RepoPatchV2 prim wX wY +prim2repopatchV2 = Normal + +instance PrimPatch prim => Patchy (RepoPatchV2 prim) +instance PatchDebug prim => PatchDebug (RepoPatchV2 prim) + +mergeWith :: PrimPatch prim => Non (RepoPatchV2 prim) wX + -> [Non (RepoPatchV2 prim) wX] -> Sealed (FL prim wX) +mergeWith p [] = effect `mapSeal` unNon p +mergeWith p xs = + mergeall . map unNon . (p :) . unconflicting_of $ nonDependsOrConflictsP xs + where + nonDependsOrConflictsP = + filter (\x -> not ((p `dependsUpon` x) || (p `conflictsWith` x))) + mergeall :: PrimPatch prim => [Sealed (FL (RepoPatchV2 prim) wX)] + -> Sealed (FL prim wX) + mergeall [Sealed x] = Sealed $ effect x + mergeall [] = Sealed NilFL + mergeall (Sealed x : Sealed y : rest) = + case merge (x :\/: y) of + y' :/\: _ -> mergeall (Sealed (x +>+ y') : rest) + unconflicting_of [] = [] + unconflicting_of (q : qs) = case allConflictsWith q qs of + ([], _) -> q : qs + (_, nc) -> unconflicting_of nc + +instance PrimPatch prim => Conflict (RepoPatchV2 prim) where + conflictedEffect (Duplicate (Non _ x)) = [IsC Duplicated x] + conflictedEffect (Etacilpud _) = impossible + conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x] + conflictedEffect (InvConflictor{}) = impossible + conflictedEffect (Normal x) = [IsC Okay x] + resolveConflicts (Conflictor ix xx x) = [mangledUnravelled : unravelled] + where + mangledUnravelled = mangleUnravelled unravelled + unravelled = nub $ filter isCons $ map (`mergeWith` xIxNonXX) xIxNonXX + xIxNonXX = x : ix ++ nonxx + nonxx = nonxx_ (reverseFL $ xx2patches ix xx) + -- |nonxx_ takes an RL of patches, and returns a singleton list + -- containing a Non, in the case where we have a Normal patch at the + -- end of the list (using the rest of the RL as context), and an empty + -- list otherwise. + nonxx_ :: RL (RepoPatchV2 prim) wX wY -> [Non (RepoPatchV2 prim) wX] + nonxx_ (qs :<: Normal q) = [Non (reverseRL qs) q] + nonxx_ _ = [] + isCons = unseal (not . nullFL) + resolveConflicts _ = [] + +instance PrimPatch prim => CommuteNoConflicts (RepoPatchV2 prim) where + commuteNoConflicts (d1@(Duplicate _) :> d2@(Duplicate _)) = Just (d2 :> d1) + commuteNoConflicts (e@(Etacilpud _) :> d@(Duplicate _)) = Just (d :> e) + commuteNoConflicts (d@(Duplicate _) :> e@(Etacilpud _)) = Just (e :> d) + commuteNoConflicts (e1@(Etacilpud _) :> e2@(Etacilpud _)) = Just (e2 :> e1) + + -- If the duplicate is @x@, as a 'Non', with @invert x@ as the context, + -- then it is the patch the duplicate @d@ represents, so commuting results + -- in the same two patches (since we'd make one a duplicate, and the other + -- would become @x@ as it would no longer be duplicated). + -- Otherwise, we commute past, or remove @invert x@ from the context of @d@ + -- to obtain a new Duplicate. + commuteNoConflicts orig@(x :> Duplicate d) = + if d == commuteOrAddToCtx (invert x) (non x) + then Just orig + else do d' <- commuteOrRemFromCtx (invert x) d + return (Duplicate d' :> x) + + -- Commuting a Duplicate and any other patch simply places @invert x@ into + -- the context of the non @d@, by commuting past, or adding to the context. + commuteNoConflicts (Duplicate d :> x) = + Just (x :> Duplicate (commuteOrAddToCtx (invert x) d)) + + -- handle Etacilpud cases by first inverting, then using the previous + -- definitions. + commuteNoConflicts c@(Etacilpud _ :> _) = invertCommuteNC c + commuteNoConflicts c@(_ :> Etacilpud _) = invertCommuteNC c + + -- Two normal patches should be simply commuted (assuming the can). + commuteNoConflicts (Normal x :> Normal y) = do + y' :> x' <- commute (x :> y) + return (Normal y' :> Normal x') + + -- Commuting a Normal patch past a Conflictor first commutes @x@ past the + -- effect of the Conflictor, then commutes the resulting @x'@ past the + -- conflicting patch and the already-undone patches. The commuting must be + -- done in this order to make the contexts match up (@iy@ and @y@ are made + -- in the context before @yy@ have their effect, so we need to commute past + -- the effect of @yy@ first). + commuteNoConflicts (Normal x :> Conflictor iy yy y) = do + iyy' :> x' <- commuteFL (x :> invert yy) + y' : iy' <- mapM (Normal x' >*) (y : iy) + return (Conflictor iy' (invert iyy') y' :> Normal x') + + -- Handle via the previous case, using the inverting commuter. + commuteNoConflicts c@(InvConflictor{} :> Normal _) = invertCommuteNC c + + -- Commuting a Conflictor past a Normal patch is the dual operation to + -- commuting a Normal patch past a Conflictor. + commuteNoConflicts (Conflictor iy yy y :> Normal x) = do + y' : iy' <- mapM (*> Normal x) (y : iy) + x' :> iyy' <- commuteRL (invertFL yy :> x) + return (Normal x' :> Conflictor iy' (invertRL iyy') y') + + -- Handle via the previous case, using the inverting commuter. + commuteNoConflicts c@(Normal _ :> InvConflictor{}) = invertCommuteNC c + + -- Commuting two Conflictors, c1 and c2, first commutes the Conflictors' + -- effects, then commutes the effect of c1 and c2 and the other's + -- already-undone, and conflicting patch, to bring the already-undone and + -- conflicting patch into the context of the commuted effects. + commuteNoConflicts (Conflictor ix xx x :> Conflictor iy yy y) = do + xx' :> yy' <- commute (yy :> xx) + x':ix' <- mapM (yy >>*) (x:ix) + y':iy' <- mapM (*>> xx') (y:iy) + False <- return $ any (conflictsWith y) (x':ix') + False <- return $ any (conflictsWith x') iy + return (Conflictor iy' yy' y' :> Conflictor ix' xx' x') + + -- Handle via the previous case, using the inverting commuter. + commuteNoConflicts c@(InvConflictor{} :> InvConflictor{}) = + invertCommuteNC c + + commuteNoConflicts (InvConflictor ix xx x :> Conflictor iy yy y) = do + iyy' :> xx' <- commute (xx :> invert yy) + y':iy' <- mapM (xx' >>*) (y:iy) + x':ix' <- mapM (invertFL iyy' >>*) (x:ix) + False <- return $ any (conflictsWith y') (x':ix') + False <- return $ any (conflictsWith x') iy' + return (Conflictor iy' (invert iyy') y' :> InvConflictor ix' xx' x') + + commuteNoConflicts (Conflictor iy' yy' y' :> InvConflictor ix' xx' x') = do + xx :> iyy <- commute (invert yy' :> xx') + y:iy <- mapM (*>> xx') (y':iy') + x:ix <- mapM (*>> yy') (x':ix') + False <- return $ any (conflictsWith y') (x':ix') + False <- return $ any (conflictsWith x') iy' + return (InvConflictor ix xx x :> Conflictor iy (invert iyy) y) + +instance PrimPatch prim => Check (RepoPatchV2 prim) where + isInconsistent = isConsistent + +instance FromPrim (RepoPatchV2 prim) where + fromPrim = prim2repopatchV2 + +instance ToFromPrim (RepoPatchV2 prim) where + toPrim (Normal p) = Just p + toPrim _ = Nothing + +instance PrimPatch prim => MyEq (RepoPatchV2 prim) where + (Duplicate x) =\/= (Duplicate y) | x == y = IsEq + (Etacilpud x) =\/= (Etacilpud y) | x == y = IsEq + (Normal x) =\/= (Normal y) = x =\/= y + (Conflictor cx xx x) =\/= (Conflictor cy yy y) + | map commuteOrAddIXX cx `eqSet` map commuteOrAddIYY cy + && commuteOrAddIXX x == commuteOrAddIYY y = xx =/\= yy + where + commuteOrAddIXX = commutePrimsOrAddToCtx (invertFL xx) + commuteOrAddIYY = commutePrimsOrAddToCtx (invertFL yy) + (InvConflictor cx xx x) =\/= (InvConflictor cy yy y) + | cx `eqSet` cy && x == y = xx =\/= yy + _ =\/= _ = NotEq + +eqSet :: Eq a => [a] -> [a] -> Bool +eqSet [] [] = True +eqSet (x:xs) xys | Just ys <- remove1 x xys = eqSet xs ys +eqSet _ _ = False + +remove1 :: Eq a => a -> [a] -> Maybe [a] +remove1 x (y : ys) = if x == y then Just ys else (y :) `fmap` remove1 x ys +remove1 _ [] = Nothing + +minus :: Eq a => [a] -> [a] -> Maybe [a] +minus xs [] = Just xs +minus xs (y:ys) = do xs' <- remove1 y xs + xs' `minus` ys + +invertNon :: PrimPatch prim => Non (RepoPatchV2 prim) wX + -> Non (RepoPatchV2 prim) wX +invertNon (Non c x) + | Just rc' <- removeRL nix (reverseFL c) = Non (reverseRL rc') (invert x) + | otherwise = commuteOrAddToCtxRL (reverseFL c :<: Normal x) $ non nix + where + nix = Normal $ invert x + +nonTouches :: PatchInspect prim => Non (RepoPatchV2 prim) wX -> [FilePath] +nonTouches (Non c x) = listTouchedFiles (c +>+ fromPrim x :>: NilFL) + +nonHunkMatches :: PatchInspect prim => (BC.ByteString -> Bool) + -> Non (RepoPatchV2 prim) wX -> Bool +nonHunkMatches f (Non c x) = hunkMatches f c || hunkMatches f x + +toNons :: forall p wX wY . (Conflict p, Patchy p, PatchListFormat p, + ToFromPrim p, Nonable p, ShowPatchBasic (PrimOf p), ShowPatchBasic p) + => FL p wX wY -> [Non p wX] +toNons xs = map lastNon $ initsFL xs + where lastNon :: Sealed ((p :> FL p) wX) -> Non p wX + lastNon (Sealed xxx) = + case lastNon_aux xxx of + deps :> p :> _ -> + case non p of + Non NilFL pp -> Non (reverseRL deps) pp + Non ds pp -> + errorDoc $ redText "Weird case in toNons" $$ + redText "please report this bug!" $$ + (case xxx of + z :> zs -> showPatch (z :>: zs)) $$ + redText "ds are" $$ showPatch ds $$ + redText "pp is" $$ showPatch pp + + reverseFoo :: (p :> FL p) wX wZ -> (RL p :> p) wX wZ + reverseFoo (p :> ps) = rf NilRL p ps + where + rf :: RL p wA wB -> p wB wC -> FL p wC wD + -> (RL p :> p) wA wD + rf rs l NilFL = rs :> l + rf rs x (y :>: ys) = rf (rs :<: x) y ys + + lastNon_aux :: (p :> FL p) wX wZ -> (RL p :> p :> RL p) wX wZ + lastNon_aux = commuteWhatWeCanRL . reverseFoo + +initsFL :: Patchy p => FL p wX wY -> [Sealed ((p :> FL p) wX)] +initsFL NilFL = [] +initsFL (x :>: xs) = + Sealed (x :> NilFL) : + map (\(Sealed (y :> xs')) -> Sealed (x :> y :>: xs')) (initsFL xs) + +filterConflictsFL :: PrimPatch prim => Non (RepoPatchV2 prim) wX + -> FL prim wX wY -> (FL prim :> FL prim) wX wY +filterConflictsFL _ NilFL = NilFL :> NilFL +filterConflictsFL n (p :>: ps) + | Just n' <- commuteOrRemFromCtx (fromPrim p) n = + case filterConflictsFL n' ps of + p1 :> p2 -> p :>: p1 :> p2 + | otherwise = case commuteWhatWeCanFL (p :> ps) of + p1 :> p' :> p2 -> + case filterConflictsFL n p1 of + p1a :> p1b -> p1a :> p1b +>+ p' :>: p2 + +instance Invert prim => Invert (RepoPatchV2 prim) where + invert (Duplicate d) = Etacilpud d + invert (Etacilpud d) = Duplicate d + invert (Normal p) = Normal (invert p) + invert (Conflictor x c p) = InvConflictor x c p + invert (InvConflictor x c p) = Conflictor x c p + +instance PrimPatch prim => Commute (RepoPatchV2 prim) where + commute (x :> y) | Just (y' :> x') <- + commuteNoConflicts (assertConsistent x :> assertConsistent y) = + Just (y' :> x') + + -- These patches conflicted, since we failed to commuteNoConflicts in the + -- case above. + commute (Normal x :> Conflictor a1'nop2 n1'x p1') + | Just rn1' <- removeRL x (reverseFL n1'x) = do + let p2 : n1nons = reverse $ xx2nons a1'nop2 $ reverseRL (rn1' :<: x) + a2 = p1' : a1'nop2 ++ n1nons + case (a1'nop2, reverseRL rn1', p1') of + ([], NilFL, Non c y) | NilFL <- joinEffects c -> + Just (Normal y :> Conflictor a1'nop2 (y :>: NilFL) p2) + (a1, n1, _) -> + Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2) + + -- Handle using the inverting commuter, and the previous case. N.b. this + -- is innefficient, since we'll have to also try commuteNoConflicts again + -- (which we know will fail, since we got here). + commute c@(InvConflictor{} :> Normal _) = invertCommute c + + commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2) + | Just a2_minus_p1 <- remove1 p1' a2 + , not (p2 `dependsUpon` p1') = do + let n1nons = map (commutePrimsOrAddToCtx n2) $ xx2nons a1 n1 + n2nons = xx2nons a2 n2 + Just a2_minus_p1n1 = a2_minus_p1 `minus` n1nons + n2n1 = n2 +>+ n1 + a1' = map (commutePrimsOrAddToCtx n2) a1 + p2ooo = remNons a1' p2 + n1' :> n2' <- return $ filterConflictsFL p2ooo n2n1 + let n1'n2'nons = xx2nons a2_minus_p1n1 (n1' +>+ n2') + n1'nons = take (lengthFL n1') n1'n2'nons + n2'nons = drop (lengthFL n1') n1'n2'nons + Just a1'nop2 = (a2 ++ n2nons) `minus` (p1' : n1'nons) + Just a2'o = + fst (allConflictsWith p2 $ a2_minus_p1 ++ n2nons) + `minus` n2'nons + Just a2' = + mapM (commuteOrRemFromCtxFL (xx2patches a1'nop2 n1')) a2'o + Just p2' = commuteOrRemFromCtxFL (xx2patches a1'nop2 n1') p2 + case (a2', n2', p2') of + ([], NilFL, Non c x) -> + case joinEffects c of + NilFL -> let n1'x = n1' +>+ x :>: NilFL in + Just (Normal x :> Conflictor a1'nop2 n1'x p1') + _ -> impossible + _ -> Just (c1 :> c2) + where + c1 = Conflictor a2' n2' p2' + c2 = Conflictor (p2 : a1'nop2) n1' p1' + + where (_, rpn2) = geteff a2 n2 + p1' = commuteOrAddToCtxRL (reverseFL rpn2) p1 + + -- Handle using the inverting commuter, and the previous case. This is also + -- innefficient, since we'll have to also try commuteNoConflicts again + -- (which we know will fail, since we got here). + commute c@(InvConflictor{} :> InvConflictor{}) = invertCommute c + + commute _ = Nothing + +instance PrimPatch prim => Merge (RepoPatchV2 prim) where + merge (InvConflictor{} :\/: _) = impossible + merge (_ :\/: InvConflictor{}) = impossible + merge (Etacilpud _ :\/: _) = impossible + merge (_ :\/: Etacilpud _) = impossible + + + merge (Duplicate a :\/: Duplicate b) = Duplicate b :/\: Duplicate a + -- We had a FIXME comment on this case, why? + merge (Duplicate a :\/: b) = + b :/\: Duplicate (commuteOrAddToCtx (invert b) a) + + -- Handle using the swap merge and the previous case. + merge m@(_ :\/: Duplicate _) = swapMerge m + + -- When merging x and y, we do a bunch of what look like "consistency" + -- check merges. If the resulting y'' and y are equal, then we succeed. + -- If the first case fails, we check for equal patches (which wouldn't + -- commute) and return a Duplicate on both sides of the merge, in that + -- case. + merge (x :\/: y) + | Just (y' :> ix') <- + commute (invert (assertConsistent x) :> assertConsistent y) + , Just (y'' :> _) <- commute (x :> y') + , IsEq <- y'' =\/= y = + assertConsistent y' :/\: invert (assertConsistent ix') + -- If we detect equal patches, we have a duplicate. + | IsEq <- x =\/= y + , n <- commuteOrAddToCtx (invert x) $ non x = + Duplicate n :/\: Duplicate n + + -- We know that these two patches conflict, and aren't Duplicates, since we + -- failed the previous case. We therefore create basic Conflictors, which + -- undo the other patch. + merge (nx@(Normal x) :\/: ny@(Normal y)) = cy :/\: cx + where + cy = Conflictor [] (x :>: NilFL) (non ny) + cx = Conflictor [] (y :>: NilFL) (non nx) + + -- If a Normal patch @x@ and a Conflictor @cy@ conflict, we add @x@ to the + -- effect of @cy@ on one side, and create a Conflictor that has no effect, + -- but has the already-undone and conflicted patch of @cy@ and some foos as + -- the already-undone on the other side. + -- + -- TODO: what is foo? + -- Why do we need nyy? I think @x'@ is @x@ in the context of @yy@. + merge (Normal x :\/: Conflictor iy yy y) = + Conflictor iy yyx y :/\: Conflictor (y : iy ++ nyy) NilFL x' + where yyx = yy +>+ x :>: NilFL + (x' : nyy) = reverse $ xx2nons iy yyx + + -- Handle using the swap merge and the previous case. + merge m@(Conflictor{} :\/: Normal _) = swapMerge m + + -- mH see also cH + merge (Conflictor ix xx x :\/: Conflictor iy yy y) = + case pullCommonRL (reverseFL xx) (reverseFL yy) of + CommonRL rxx1 ryy1 c -> + case commuteRLFL (ryy1 :> invertRL rxx1) of + Just (ixx' :> ryy') -> + let xx' = invert ixx' + yy' = reverseRL ryy' + y' : iy' = + map (commutePrimsOrAddToCtx xx') (y : iy) + x' : ix' = + map (commutePrimsOrAddToCtx ryy') (x : ix) + nyy' = xx2nons iy' yy' + nxx' = xx2nons ix' xx' + icx = drop (lengthRL rxx1) $ + xx2nons ix (reverseRL $ rxx1 +<+ c) + ic' = map (commutePrimsOrAddToCtx ryy') icx + -- +++ is a more efficient version of nub (iy' ++ + -- ix') given that we know each element shows up + -- only once in either list. + ixy' = ic' ++ (iy' +++ ix') + c1 = Conflictor (x' : ixy' ++ nxx') yy' y' + c2 = Conflictor (y' : ixy' ++ nyy') xx' x' in + c1 :/\: c2 + Nothing -> impossible + +instance PatchInspect prim => PatchInspect (RepoPatchV2 prim) where + listTouchedFiles (Duplicate p) = nonTouches p + listTouchedFiles (Etacilpud p) = nonTouches p + listTouchedFiles (Normal p) = listTouchedFiles p + listTouchedFiles (Conflictor x c p) = + nubSort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p + listTouchedFiles (InvConflictor x c p) = + nubSort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p + + hunkMatches f (Duplicate p) = nonHunkMatches f p + hunkMatches f (Etacilpud p) = nonHunkMatches f p + hunkMatches f (Normal p) = hunkMatches f p + hunkMatches f (Conflictor x c p) = + any (nonHunkMatches f) x || hunkMatches f c || nonHunkMatches f p + hunkMatches f (InvConflictor x c p) = + any (nonHunkMatches f) x || hunkMatches f c || nonHunkMatches f p + +allConflictsWith :: PrimPatch prim => Non (RepoPatchV2 prim) wX + -> [Non (RepoPatchV2 prim) wX] + -> ([Non (RepoPatchV2 prim) wX], [Non (RepoPatchV2 prim) wX]) +allConflictsWith x ys = acw $ partition (conflictsWith x) ys + where + acw ([], nc) = ([], nc) + acw (c:cs, nc) = case allConflictsWith c nc of + (c1, nc1) -> case acw (cs, nc1) of + (xs', nc') -> (c : c1 ++ xs', nc') + +conflictsWith :: PrimPatch prim => Non (RepoPatchV2 prim) wX + -> Non (RepoPatchV2 prim) wX -> Bool +conflictsWith x y | x `dependsUpon` y || y `dependsUpon` x = False +conflictsWith x (Non cy y) = + case commuteOrRemFromCtxFL cy x of + Just (Non cx' x') -> + let iy = fromPrim $ invert y in + case commuteFLorComplain (iy :> cx' +>+ fromPrim x' :>: NilFL) of + Right _ -> False + Left _ -> True + Nothing -> True + +dependsUpon :: PrimPatch prim => Non (RepoPatchV2 prim) wX + -> Non (RepoPatchV2 prim) wX -> Bool +dependsUpon (Non xs _) (Non ys y) = + case removeSubsequenceFL (ys +>+ fromPrim y :>: NilFL) xs of + Just _ -> True + Nothing -> False + +(+++) :: Eq a => [a] -> [a] -> [a] +[] +++ x = x +x +++ [] = x +(x:xs) +++ xys | Just ys <- remove1 x xys = x : (xs +++ ys) + | otherwise = x : (xs +++ xys) + +swapMerge :: PrimPatch prim => (RepoPatchV2 prim :\/: RepoPatchV2 prim) wX wY + -> (RepoPatchV2 prim :/\: RepoPatchV2 prim) wX wY +swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x' + +invertCommute :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim) wX wY + -> Maybe ((RepoPatchV2 prim :> RepoPatchV2 prim) wX wY) +invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x) + return (invert iy' :> invert ix') + +invertCommuteNC :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim) wX wY + -> Maybe ((RepoPatchV2 prim :> RepoPatchV2 prim) wX wY) +invertCommuteNC (x :> y) = do + ix' :> iy' <- commuteNoConflicts (invert y :> invert x) + return (invert iy' :> invert ix') + +-- | 'pullCommon' @xs ys@ returns the set of patches that can be commuted out +-- of both @xs@ and @ys@ along with the remnants of both lists +pullCommon :: (Patchy p, MyEq p) => FL p wO wX -> FL p wO wY -> Common p wO wX wY +pullCommon NilFL ys = Common NilFL NilFL ys +pullCommon xs NilFL = Common NilFL xs NilFL +pullCommon (x :>: xs) xys | Just ys <- removeFL x xys = + case pullCommon xs ys of + Common c xs' ys' -> Common (x :>: c) xs' ys' +pullCommon (x :>: xs) ys = + case commuteWhatWeCanFL (x :> xs) of + xs1 :> x' :> xs2 -> case pullCommon xs1 ys of + Common c xs1' ys' -> Common c (xs1' +>+ x' :>: xs2) ys' + +-- | 'Common' @cs xs ys@ represents two sequences of patches that have @cs@ in +-- common, in other words @cs +>+ xs@ and @cs +>+ ys@ +data Common p wO wX wY where + Common :: FL p wO wI -> FL p wI wX -> FL p wI wY -> Common p wO wX wY + +-- | 'pullCommonRL' @xs ys@ returns the set of patches that can be commuted +-- out of both @xs@ and @ys@ along with the remnants of both lists +pullCommonRL :: (Patchy p, MyEq p) => RL p wX wO -> RL p wY wO -> CommonRL p wX wY wO +pullCommonRL NilRL ys = CommonRL NilRL ys NilRL +pullCommonRL xs NilRL = CommonRL xs NilRL NilRL +pullCommonRL (xs :<: x) xys | Just ys <- removeRL x xys = + case pullCommonRL xs ys of + CommonRL xs' ys' c -> CommonRL xs' ys' (c :<: x) +pullCommonRL (xs :<: x) ys = + case commuteWhatWeCanRL (xs :> x) of + xs1 :> x' :> xs2 -> + case pullCommonRL xs2 ys of + CommonRL xs2' ys' c -> CommonRL (xs1 :<: x' +<+ xs2') ys' c + +-- | 'CommonRL' @xs ys cs@' represents two sequences of patches that have @cs@ +-- in common, in other words @xs +<+ cs@ and @ys +<+ cs@ +data CommonRL p wX wY wF where + CommonRL :: RL p wX wI -> RL p wY wI -> RL p wI wF -> CommonRL p wX wY wF + +instance PrimPatch prim => Apply (RepoPatchV2 prim) where + type ApplyState (RepoPatchV2 prim) = ApplyState prim + apply p = apply (effect p) + +instance PrimPatch prim => RepairToFL (RepoPatchV2 prim) where + applyAndTryToFixFL (Normal p) = + mapMaybeSnd (mapFL_FL Normal) `liftM` applyAndTryToFixFL p + applyAndTryToFixFL x = do apply x; return Nothing + +instance PatchListFormat (RepoPatchV2 prim) where + -- In principle we could use ListFormatDefault when prim /= V1 Prim patches, + -- as those are the only case where we need to support a legacy on-disk + -- format. In practice we don't expect RepoPatchV2 to be used with any other + -- argument anyway, so it doesn't matter. + patchListFormat = ListFormatV2 + +duplicate, etacilpud, conflictor, rotcilfnoc :: String +duplicate = "duplicate" +etacilpud = "etacilpud" +conflictor = "conflictor" +rotcilfnoc = "rotcilfnoc" + +instance PrimPatch prim => ShowPatchBasic (RepoPatchV2 prim) where + showPatch (Duplicate d) = blueText duplicate $$ showNon d + showPatch (Etacilpud d) = blueText etacilpud $$ showNon d + showPatch (Normal p) = showPrim NewFormat p + showPatch (Conflictor i NilFL p) = + blueText conflictor <+> showNons i <+> blueText "[]" $$ showNon p + showPatch (Conflictor i cs p) = + blueText conflictor <+> showNons i <+> blueText "[" $$ + showPrimFL NewFormat cs $$ + blueText "]" $$ + showNon p + showPatch (InvConflictor i NilFL p) = + blueText rotcilfnoc <+> showNons i <+> blueText "[]" $$ showNon p + showPatch (InvConflictor i cs p) = + blueText rotcilfnoc <+> showNons i <+> blueText "[" $$ + showPrimFL NewFormat cs $$ + blueText "]" $$ + showNon p + +instance PrimPatch prim => ShowPatch (RepoPatchV2 prim) where + showContextPatch (Normal p) = showContextPatch p + showContextPatch c = return $ showPatch c + summary = plainSummary + summaryFL = plainSummary + thing _ = "change" + +instance PrimPatch prim => ReadPatch (RepoPatchV2 prim) where + readPatch' = do + skipSpace + let str = string . BC.pack + readConflictorPs = do + i <- readNons + ps <- bracketedFL (readPrim NewFormat) '[' ']' + p <- readNon + return (i, ps, p) + choice [ do str duplicate + p <- readNon + return $ Sealed $ Duplicate p + , do str etacilpud + p <- readNon + return $ Sealed $ Etacilpud p + , do str conflictor + (i, Sealed ps, p) <- readConflictorPs + return $ Sealed $ Conflictor i (unsafeCoerceP ps) p + , do str rotcilfnoc + (i, Sealed ps, p) <- readConflictorPs + return $ Sealed $ InvConflictor i ps p + , do Sealed p <- readPrim NewFormat + return $ Sealed $ Normal p + ] + +instance Show2 prim => Show (RepoPatchV2 prim wX wY) where + showsPrec d (Normal prim) = + showParen (d > appPrec) $ showString "Darcs.Patch.V2.RepoPatch.Normal " . showsPrec2 (appPrec + 1) prim + + showsPrec d (Duplicate x) = + showParen (d > appPrec) $ showString "Darcs.Patch.V2.RepoPatch.Duplicate " . showsPrec (appPrec + 1) x + + showsPrec d (Etacilpud x) = + showParen (d > appPrec) $ showString "Darcs.Patch.V2.Etacilpud " . showsPrec (appPrec + 1) x + + showsPrec d (Conflictor ix xx x) = + showParen (d > appPrec) $ + showString "Darcs.Patch.V2.RepoPatch.Conflictor " . showsPrec (appPrec + 1) ix . + showString " " . showsPrec (appPrec + 1) xx . + showString " " . showsPrec (appPrec + 1) x + + showsPrec d (InvConflictor ix xx x) = + showParen (d > appPrec) $ + showString "Darcs.Patch.V2.RepoPatch.InvConflictor " . showsPrec (appPrec + 1) ix . + showString " " . showsPrec (appPrec + 1) xx . + showString " " . showsPrec (appPrec + 1) x + +instance Show2 prim => Show1 (RepoPatchV2 prim wX) where + showDict1 = ShowDictClass + +instance Show2 prim => Show2 (RepoPatchV2 prim) where + showDict2 = ShowDictClass + +instance PrimPatch prim => Nonable (RepoPatchV2 prim) where + non (Duplicate d) = d + non (Etacilpud d) = invertNon d -- FIXME !!! ??? + non (Normal p) = Non NilFL p + non (Conflictor _ xx x) = commutePrimsOrAddToCtx (invertFL xx) x + non (InvConflictor _ _ n) = invertNon n + +instance PrimPatch prim => Effect (RepoPatchV2 prim) where + effect (Duplicate _) = NilFL + effect (Etacilpud _) = NilFL + effect (Normal p) = p :>: NilFL + effect (Conflictor _ e _) = invert e + effect (InvConflictor _ e _) = e + effectRL (Duplicate _) = NilRL + effectRL (Etacilpud _) = NilRL + effectRL (Normal p) = NilRL :<: p + effectRL (Conflictor _ e _) = invertFL e + effectRL (InvConflictor _ e _) = reverseFL e + +instance IsHunk prim => IsHunk (RepoPatchV2 prim) where + isHunk rp = do Normal p <- return rp + isHunk p diff --git a/src/Darcs/Patch/Viewing.hs b/src/Darcs/Patch/Viewing.hs --- a/src/Darcs/Patch/Viewing.hs +++ b/src/Darcs/Patch/Viewing.hs @@ -23,15 +23,18 @@ , showContextSeries ) where +import Prelude () +import Darcs.Prelude + import Control.Applicative( (<$>) ) import qualified Data.ByteString as BS ( null ) import Prelude hiding ( pi, readFile ) -import Storage.Hashed.Monad ( virtualTreeMonad ) -import Storage.Hashed.Tree ( Tree ) +import Darcs.Util.Tree ( Tree ) +import Darcs.Util.Tree.Monad ( virtualTreeMonad ) import Darcs.Patch.Apply ( Apply(..) ) -import Darcs.Patch.ApplyMonad ( ApplyMonadTrans, getApplyState, - ApplyMonad(..), toTree ) +import Darcs.Patch.ApplyMonad ( getApplyState, + ApplyMonad(..), ApplyMonadTree(..), toTree ) import Darcs.Patch.FileHunk ( IsHunk(..), FileHunk(..), showFileHunk ) import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..), FileNameFormat(..) ) @@ -43,15 +46,11 @@ lineColor, ($$), (<+>), prefix, userchunkPS ) showContextSeries :: forall p m wX wY . (Apply p, ShowPatch p, IsHunk p, - ApplyMonadTrans m (ApplyState p), - ApplyMonad m (ApplyState p)) + ApplyMonad (ApplyState p) m) => FL p wX wY -> m Doc showContextSeries = scs Nothing where - scs :: forall m' wWw wXx wYy . (ApplyMonadTrans m' (ApplyState p), - ApplyMonad m' (ApplyState p), - ApplyMonadBase m ~ ApplyMonadBase m') - => Maybe (FileHunk wWw wXx) -> FL p wXx wYy -> m' Doc + scs :: forall wWw wXx wYy . Maybe (FileHunk wWw wXx) -> FL p wXx wYy -> m Doc scs pold (p :>: ps) = do (_, s') <- nestedApply (apply p) =<< getApplyState case isHunk p of @@ -72,10 +71,10 @@ cool pold fh ps s = fst <$> virtualTreeMonad (coolContextHunk pold fh ps) (toTree s) -showContextHunk :: (ApplyMonad m Tree) => FileHunk wX wY -> m Doc +showContextHunk :: (ApplyMonad Tree m) => FileHunk wX wY -> m Doc showContextHunk h = coolContextHunk Nothing h Nothing -coolContextHunk :: (ApplyMonad m Tree, ApplyMonadTrans m Tree) +coolContextHunk :: (ApplyMonad Tree m) => Maybe (FileHunk wA wB) -> FileHunk wB wC -> Maybe (FileHunk wC wD) -> m Doc coolContextHunk prev fh@(FileHunk f l o n) next = do @@ -127,8 +126,7 @@ => ShowPatch (FL p) where showContextPatch = showContextPatchInternal patchListFormat where - showContextPatchInternal :: (ApplyMonadTrans m (ApplyState p), - ApplyMonad m (ApplyState (FL p))) + showContextPatchInternal :: (ApplyMonad (ApplyState (FL p)) m) => ListFormat p -> FL p wX wY -> m Doc showContextPatchInternal ListFormatV1 (p :>: NilFL) = showContextPatch p diff --git a/src/Darcs/Patch/Witnesses/Eq.hs b/src/Darcs/Patch/Witnesses/Eq.hs --- a/src/Darcs/Patch/Witnesses/Eq.hs +++ b/src/Darcs/Patch/Witnesses/Eq.hs @@ -4,6 +4,9 @@ , isIsEq ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -- |'EqCheck' is used to pass around evidence (or lack thereof) of diff --git a/src/Darcs/Patch/Witnesses/Ordered.hs b/src/Darcs/Patch/Witnesses/Ordered.hs --- a/src/Darcs/Patch/Witnesses/Ordered.hs +++ b/src/Darcs/Patch/Witnesses/Ordered.hs @@ -22,7 +22,6 @@ -- * Directed Types -- $DirectedTypes (:>)(..) - , (:<)(..) , FL(..) , RL(..) -- * Merge Types @@ -59,7 +58,7 @@ , nullFL , concatFL , concatRL - , consRLSealed + , snocRLSealed , nullRL , toFL , dropWhileFL @@ -71,6 +70,9 @@ , eqFLUnsafe ) where +import Prelude () +import Darcs.Prelude + #include "impossible.h" import Darcs.Patch.Witnesses.Show import Darcs.Patch.Witnesses.Sealed @@ -104,10 +106,6 @@ data (a1 :> a2) wX wY = forall wZ . (a1 wX wZ) :> (a2 wZ wY) infixr 1 :> --- | Directed Reverse Pairs -data (a1 :< a2) wX wY = forall wZ . (a1 wZ wY) :< (a2 wX wZ) -infix 1 :< - -- | Forward lists data FL a wX wZ where (:>:) :: a wX wY -> FL a wY wZ -> FL a wX wZ @@ -115,7 +113,7 @@ -- | Reverse lists data RL a wX wZ where - (:<:) :: a wY wZ -> RL a wX wY -> RL a wX wZ + (:<:) :: RL a wX wY -> a wY wZ -> RL a wX wZ NilRL :: RL a wX wX instance Show2 a => Show (FL a wX wZ) where @@ -132,8 +130,8 @@ instance Show2 a => Show (RL a wX wZ) where showsPrec _ NilRL = showString "NilRL" - showsPrec d (x :<: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x . - showString " :<: " . showsPrec (prec + 1) xs + showsPrec d (xs :<: x) = showParen (d > prec) $ showsPrec (prec + 1) xs . + showString " :<: " . showsPrec2 (prec + 1) x where prec = 5 instance Show2 a => Show1 (RL a wX) where @@ -230,13 +228,6 @@ instance (MyEq a, MyEq b) => Eq ((a :> b) wX wY) where (==) = unsafeCompare -instance (MyEq a, MyEq b) => MyEq (a :< b) where - (a1 :< b1) =\/= (a2 :< b2) | IsEq <- b1 =\/= b2 = a1 =\/= a2 - | otherwise = NotEq - -instance (MyEq a, MyEq b) => Eq ((a :< b) wX wY) where - (==) = unsafeCompare - instance (Show2 a, Show2 b) => Show2 (a :> b) where showDict2 = ShowDictClass @@ -254,7 +245,8 @@ -- * Functions -infixr 5 :>:, :<:, +>+, +<+ +infixr 5 :>:, +>+ +infixl 5 :<:, +<+ nullFL :: FL a wX wZ -> Bool nullFL NilFL = True @@ -274,33 +266,33 @@ filterOutRLRL :: (forall wX wY . p wX wY -> EqCheck wX wY) -> RL p wW wZ -> RL p wW wZ filterOutRLRL _ NilRL = NilRL -filterOutRLRL f (x:<:xs) | IsEq <- f x = filterOutRLRL f xs - | otherwise = x :<: filterOutRLRL f xs +filterOutRLRL f (xs:<:x) | IsEq <- f x = filterOutRLRL f xs + | otherwise = filterOutRLRL f xs :<: x filterRL :: (forall wX wY . p wX wY -> Bool) -> RL p wA wB -> [Sealed2 p] filterRL _ NilRL = [] -filterRL f (x :<: xs) | f x = Sealed2 x : (filterRL f xs) +filterRL f (xs :<: x) | f x = Sealed2 x : (filterRL f xs) | otherwise = filterRL f xs (+>+) :: FL a wX wY -> FL a wY wZ -> FL a wX wZ NilFL +>+ ys = ys (x:>:xs) +>+ ys = x :>: xs +>+ ys -(+<+) :: RL a wY wZ -> RL a wX wY -> RL a wX wZ -NilRL +<+ ys = ys -(x:<:xs) +<+ ys = x :<: xs +<+ ys +(+<+) :: RL a wX wY -> RL a wY wZ -> RL a wX wZ +xs +<+ NilRL = xs +xs +<+ (ys:<:y) = xs +<+ ys :<: y reverseFL :: FL a wX wZ -> RL a wX wZ reverseFL xs = r NilRL xs where r :: RL a wL wM -> FL a wM wO -> RL a wL wO r ls NilFL = ls - r ls (a:>:as) = r (a:<:ls) as + r ls (a:>:as) = r (ls:<:a) as reverseRL :: RL a wX wZ -> FL a wX wZ -reverseRL xs = r NilFL xs -- r (xs :> NilFL) +reverseRL xs = r NilFL xs where r :: FL a wM wO -> RL a wL wM -> FL a wL wO r ls NilRL = ls - r ls (a:<:as) = r (a:>:ls) as + r ls (as:<:a) = r (a:>:ls) as concatFL :: FL (FL a) wX wZ -> FL a wX wZ concatFL NilFL = NilFL @@ -308,7 +300,7 @@ concatRL :: RL (RL a) wX wZ -> RL a wX wZ concatRL NilRL = NilRL -concatRL (a:<:as) = a +<+ concatRL as +concatRL (as:<:a) = concatRL as +<+ a spanFL :: (forall wW wY . a wW wY -> Bool) -> FL a wX wZ -> (FL a :> FL a) wX wZ spanFL f (x:>:xs) | f x = case spanFL f xs of @@ -334,11 +326,11 @@ splitAtFL n (x:>:xs) = case splitAtFL (n-1) xs of (xs':>xs'') -> (x:>:xs' :> xs'') -splitAtRL :: Int -> RL a wX wZ -> (RL a :< RL a) wX wZ -splitAtRL 0 xs = NilRL :< xs -splitAtRL _ NilRL = NilRL :< NilRL -splitAtRL n (x:<:xs) = case splitAtRL (n-1) xs of - (xs': (x:<:xs' :< xs'') +splitAtRL :: Int -> RL a wX wZ -> (RL a :> RL a) wX wZ +splitAtRL 0 xs = xs :> NilRL +splitAtRL _ NilRL = NilRL :> NilRL +splitAtRL n (xs:<:x) = case splitAtRL (n-1) xs of + (xs'':>xs') -> (xs'':> xs':<:x) -- 'bunchFL n' groups patches into batches of n, except that it always puts -- the first patch in its own group, this being a recognition that the @@ -365,7 +357,7 @@ foldlRL :: (forall wW wY . a -> b wW wY -> a) -> a -> RL b wX wZ -> a foldlRL _ x NilRL = x -foldlRL f x (y:<:ys) = foldlRL f (f x y) ys +foldlRL f x (ys:<:y) = foldlRL f (f x y) ys mapFL_FL :: (forall wW wY . a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ mapFL_FL _ NilFL = NilFL @@ -385,7 +377,7 @@ mapRL_RL :: (forall wW wY . a wW wY -> b wW wY) -> RL a wX wZ -> RL b wX wZ mapRL_RL _ NilRL = NilRL -mapRL_RL f (a:<:as) = f a :<: mapRL_RL f as +mapRL_RL f (as:<:a) = mapRL_RL f as :<: f a mapFL :: (forall wW wZ . a wW wZ -> b) -> FL a wX wY -> [b] mapFL _ NilFL = [] @@ -399,7 +391,7 @@ mapRL :: (forall wW wZ . a wW wZ -> b) -> RL a wX wY -> [b] mapRL _ NilRL = [] -mapRL f (a :<: b) = f a : mapRL f b +mapRL f (as :<: a) = f a : mapRL f as lengthFL :: FL a wX wZ -> Int lengthFL xs = l xs 0 @@ -411,15 +403,15 @@ lengthRL xs = l xs 0 where l :: RL a wX wZ -> Int -> Int l NilRL n = n - l (_:<:as) n = l as $! n+1 + l (as:<:_) n = l as $! n+1 isShorterThanRL :: RL a wX wY -> Int -> Bool isShorterThanRL _ n | n <= 0 = False isShorterThanRL NilRL _ = True -isShorterThanRL (_:<:xs) n = isShorterThanRL xs (n-1) +isShorterThanRL (xs:<:_) n = isShorterThanRL xs (n-1) -consRLSealed :: a wY wZ -> FlippedSeal (RL a) wY -> FlippedSeal (RL a) wZ -consRLSealed a (FlippedSeal as) = flipSeal $ a :<: as +snocRLSealed :: FlippedSeal (RL a) wY -> a wY wZ -> FlippedSeal (RL a) wZ +snocRLSealed (FlippedSeal as) a = flipSeal $ as :<: a toFL :: [FreeLeft a] -> Sealed (FL a wX) toFL [] = Sealed NilFL @@ -433,7 +425,7 @@ dropWhileRL :: (forall wX wY . a wX wY -> Bool) -> RL a wR wV -> Sealed (RL a wR) dropWhileRL _ NilRL = seal NilRL -dropWhileRL p xs@(x:<:xs') +dropWhileRL p xs@(xs':<:x) | p x = dropWhileRL p xs' | otherwise = seal xs diff --git a/src/Darcs/Patch/Witnesses/Sealed.hs b/src/Darcs/Patch/Witnesses/Sealed.hs --- a/src/Darcs/Patch/Witnesses/Sealed.hs +++ b/src/Darcs/Patch/Witnesses/Sealed.hs @@ -43,6 +43,9 @@ , unFreeRight ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Witnesses.Eq ( MyEq, EqCheck(..) ) import Darcs.Patch.Witnesses.Show import Darcs.Patch.Witnesses.Eq ( (=\/=) ) diff --git a/src/Darcs/Patch/Witnesses/Show.hs b/src/Darcs/Patch/Witnesses/Show.hs --- a/src/Darcs/Patch/Witnesses/Show.hs +++ b/src/Darcs/Patch/Witnesses/Show.hs @@ -15,6 +15,9 @@ , appPrec ) where +import Prelude () +import Darcs.Prelude + import Darcs.Util.Show ( appPrec ) data ShowDict a where diff --git a/src/Darcs/Patch/Witnesses/WZipper.hs b/src/Darcs/Patch/Witnesses/WZipper.hs --- a/src/Darcs/Patch/Witnesses/WZipper.hs +++ b/src/Darcs/Patch/Witnesses/WZipper.hs @@ -33,6 +33,10 @@ , toStart ) where + +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Witnesses.Ordered ( FL(..) , RL(..) @@ -81,7 +85,7 @@ rightmost _ = False right :: FZipper p wX wY -> FZipper p wX wY -right (FZipper l (b:>:r)) = FZipper (b :<: l) r +right (FZipper l (m:>:r)) = FZipper (l :<: m) r right x@(FZipper _ NilFL) = x leftmost :: FZipper p wX wY -> Bool @@ -89,11 +93,11 @@ leftmost _ = False left :: FZipper p wX wY -> FZipper p wX wY -left (FZipper (b :<: l) r) = FZipper l (b :>: r) +left (FZipper (l :<: m) r) = FZipper l (m :>: r) left x@(FZipper NilRL _) = x toEnd :: FZipper p wX wY -> FZipper p wX wY -toEnd (FZipper l r) = FZipper (reverseFL r +<+ l) NilFL +toEnd (FZipper l r) = FZipper (l +<+ reverseFL r) NilFL toStart :: FZipper p wX wY -> FZipper p wX wY toStart (FZipper l r) = FZipper NilRL $ reverseRL l +>+ r diff --git a/src/Darcs/Prelude.hs b/src/Darcs/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Prelude.hs @@ -0,0 +1,54 @@ +-- Copyright (C) 2015 Ganesh Sittampalam +-- BSD3 + +{- +This module abstracts over the differences in the Haskell Prelude over multiple GHC versions, +and also hides some symbols that are exported by the Prelude but clash with common names in +the Darcs code. + +Broadly it exports everything that the latest Prelude supports, minus the things we explicitly exclude +By default it should be imported with + import Prelude () + import Darcs.Prelude + +If necessary more things can be hidden in the 'Darcs.Prelude' import if they clash with something local, +but consider whether to either hide them globally instead or to choose a different name for the local thing. + +If something is needed from the Prelude that's hidden by default, then add it to the Prelude import. + +-} + +module Darcs.Prelude + ( module Prelude + , module Control.Applicative + , module Data.Monoid + , module Data.Traversable + ) where + +import Prelude hiding + ( + -- because it's a good name for a PatchInfo + pi + , + -- because they're in the new Prelude but only in Control.Applicative in older GHCs + Applicative(..), (<$>), (<*>) + , + -- because it's in the new Prelude but only in Data.Monoid in older GHCs + Monoid(..) + , + -- because it's in the new Prelude but only in Data.Traversable in older GHCs + traverse + , + -- because it's a good name for a patch log + log + , + -- used by the options system + (^) + , + -- used by various code for no particularly good reason + lookup, pred + ) + +import Control.Applicative ( Applicative(..), (<$>), (<*>) ) +import Data.Monoid ( Monoid(..) ) +import Data.Traversable ( traverse ) diff --git a/src/Darcs/Repository.hs b/src/Darcs/Repository.hs --- a/src/Darcs/Repository.hs +++ b/src/Darcs/Repository.hs @@ -17,8 +17,6 @@ -- Boston, MA 02110-1301, USA. {-# LANGUAGE CPP, ScopedTypeVariables #-} - - module Darcs.Repository ( Repository , HashedDir(..) @@ -48,8 +46,8 @@ , tentativelyAddPatch , tentativelyRemovePatches , tentativelyAddToPending - , tentativelyReplacePatches , readTentativeRepo + , RebaseJobFlags(..) , withManualRebaseUpdate , tentativelyMergePatches , considerMergeToWorking @@ -60,7 +58,6 @@ , patchSetToRepository , unrevertUrl , applyToWorking - , patchSetToPatches , createPristineDirectoryTree , createPartialsPristineDirectoryTree , reorderInventory @@ -91,16 +88,16 @@ , listUnregisteredFiles ) where -import Prelude hiding ( catch, pi ) +import Prelude () +import Darcs.Prelude +import Control.Monad ( unless, when ) +import Data.List ( (\\) ) import System.Exit ( exitSuccess ) -import Data.List ( (\\), isPrefixOf ) -import Data.Maybe( catMaybes, isJust, listToMaybe ) import Darcs.Repository.State ( readRecorded , readUnrecorded - , readWorking , unrecordedChanges , unrecordedChangesWithPatches , readPendingAndWorking @@ -115,11 +112,9 @@ ) import Darcs.Repository.Internal - (Repository(..) + ( Repository(..) , maybeIdentifyRepository , identifyRepositoryFor - , identifyRepository - , IdentifyRepo(..) , findRepository , amInRepository , amNotInRepository @@ -131,13 +126,11 @@ , withRecorded , tentativelyAddPatch , tentativelyRemovePatches - , tentativelyReplacePatches , tentativelyAddToPending , revertRepositoryChanges , finalizeRepositoryChanges , unrevertUrl , applyToWorking - , patchSetToPatches , createPristineDirectoryTree , createPartialsPristineDirectoryTree , reorderInventory @@ -145,7 +138,7 @@ , setScriptsExecutable , setScriptsExecutablePatches , makeNewPending - , seekRepo + , repoPatchType ) import Darcs.Repository.Job ( RepoJob(..) @@ -154,616 +147,63 @@ , withRepository , withRepositoryDirectory ) -import Darcs.Repository.Rebase ( withManualRebaseUpdate ) -import Darcs.Repository.Test - ( testTentative ) - +import Darcs.Repository.Rebase ( RebaseJobFlags(..), withManualRebaseUpdate ) +import Darcs.Repository.Test ( testTentative ) import Darcs.Repository.Merge( tentativelyMergePatches , considerMergeToWorking ) -import Darcs.Repository.Cache ( unionRemoteCaches - , fetchFileUsingCache - , speculateFileUsingCache - , HashedDir(..) +import Darcs.Repository.Cache ( HashedDir(..) , Cache(..) , CacheLoc(..) , WritableOrNot(..) - , hashedDir - , bucketFolder - , CacheType(Directory) , 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 - , apply - , invert - , effect , PrimOf ) -import Darcs.Patch.Set ( Origin - , PatchSet(..) +import Darcs.Patch.Set ( PatchSet(..) , SealedPatchSet - , newset2RL - , newset2FL - , progressPatchSet ) -import Darcs.Patch.Match ( MatchFlag(..), havePatchsetMatch ) import Darcs.Patch.Commute( commuteFL ) import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL ) -import Control.Exception ( catch, Exception, throwIO, finally, IOException ) -import Control.Concurrent ( forkIO ) -import Control.Concurrent.MVar ( MVar - , newMVar - , putMVar - , takeMVar - ) -import Control.Monad ( unless, when, void ) -import Control.Applicative( (<$>) ) -import System.Directory ( createDirectory - , createDirectoryIfMissing - , renameFile - , doesFileExist - , removeFile - , getDirectoryContents - , getCurrentDirectory - , setCurrentDirectory - ) -import System.IO ( stderr ) -import System.IO.Error ( isAlreadyExistsError ) -import System.Posix.Files ( createLink ) - -import qualified Darcs.Repository.HashedRepo as HashedRepo - -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash, hopefully ) -import Darcs.Repository.ApplyPatches ( applyPatches, runDefault ) -import Darcs.Repository.HashedRepo ( applyToTentativePristine - , pris2inv - , inv2pris - , revertTentativeChanges - , copySources - ) -import Darcs.Repository.InternalTypes ( modifyCache ) +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, lengthFL, mapFL_FL, FL(..), - RL(..), bunchFL, mapFL, mapRL, lengthRL, (+>+), (:\/:)(..)) -import Darcs.Repository.Format ( RepoProperty ( HashedInventory, Darcs2 ) - , RepoFormat - , createRepoFormat - , formatHas - , writeRepoFormat - , readProblem - ) -import Darcs.Repository.Prefs ( writeDefaultPrefs, addRepoSource, deleteSources ) -import Darcs.Repository.Match ( getOnePatchset ) -import Darcs.Patch.Depends ( areUnrelatedRepos, findUncommon, findCommonWithThem - , countUsThem ) -import Darcs.Patch.Type ( PatchType(..) ) + ( (:>)(..) + , reverseRL + , reverseFL + , FL(..) + , (+>+) + ) +import Darcs.Patch.Depends ( areUnrelatedRepos ) -import Darcs.Util.Exception ( catchall ) -import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Prompt ( promptYorn ) -import Darcs.Util.English ( englishNum, Noun(..) ) -import Darcs.Repository.External - ( copyFileOrUrl - , Cachable(..) - , fetchFileLazyPS - , gzFetchFilePS - ) -import Darcs.Util.Progress ( debugMessage - , tediousSize - , beginTedious - , endTedious - ) -import Darcs.Patch.Progress - ( progressRLShowTags - , progressFL - ) -import Darcs.Repository.Lock - ( writeBinFile - , writeDocBinFile - , withTemp - ) -import Darcs.Repository.Flags - ( UpdateWorking(..) - , UseCache(..) - , UseIndex(..) - , ScanKnown(..) - , RemoteDarcs (..) - , Reorder (..) - , Compression (..) - , CloneKind (..) - , Verbosity (..) - , DryRun (..) - , UMask (..) - , AllowConflicts (..) - , ExternalMerge (..) - , WantGuiPause (..) - , SetScriptsExecutable (..) - , RemoteRepos (..) - , SetDefault (..) - , DiffAlgorithm (..) - , WithWorkingDir (..) - , ForgetParent (..) - , WithPatchIndex (..) - ) - -import Darcs.Util.Download ( maxPipelineLength ) -import Darcs.Util.Global ( darcsdir ) -import Darcs.Util.URL ( isValidLocalPath ) -import Darcs.Util.SignalHandler ( catchInterrupt ) -import Darcs.Util.Printer ( Doc, text, hPutDocLn, putDocLn, errorDoc, RenderMode(..) ) - -import Storage.Hashed.Plain( readPlainTree ) -import Storage.Hashed.Tree( Tree, emptyTree, expand, list ) -import Storage.Hashed.Hash( encodeBase16 ) import Darcs.Util.Path( anchorPath ) -import Storage.Hashed.Darcs( writeDarcsHashed, darcsAddMissingHashes ) -import Darcs.Util.ByteString( gzReadFilePS ) -import System.FilePath( () - , takeFileName - , splitPath - , joinPath - , takeDirectory - ) -import qualified Codec.Archive.Tar as Tar -import Codec.Compression.GZip ( compress, decompress ) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BL -import Darcs.Repository.PatchIndex (createOrUpdatePatchIndexDisk, doesPatchIndexExist, createPIWithInterrupt) -#include "impossible.h" - - --- @createRepository useFormat1 useNoWorkingDir patchIndex@ -createRepository :: Bool -> WithWorkingDir -> WithPatchIndex -> IO () -createRepository useFormat1 withWorkingDir createPatchIndex = do - createDirectory darcsdir `catch` - (\e-> if isAlreadyExistsError e - then fail "Tree has already been initialized!" - else fail $ "Error creating directory `"++darcsdir++"'.") - cwd <- getCurrentDirectory - x <- seekRepo - when (isJust x) $ do - setCurrentDirectory cwd - putStrLn "WARNING: creating a nested repository." - createDirectory $ darcsdir ++ "/pristine.hashed" - createDirectory $ darcsdir ++ "/patches" - createDirectory $ darcsdir ++ "/inventories" - createDirectory $ darcsdir ++ "/prefs" - writeDefaultPrefs - let repoFormat = createRepoFormat useFormat1 withWorkingDir - writeRepoFormat repoFormat (darcsdir++"/format") - writeBinFile (darcsdir++"/hashed_inventory") "" - writePristine "." emptyTree - withRepository NoUseCache $ RepoJob $ \repo -> case createPatchIndex of - NoPatchIndex -> return () -- default - YesPatchIndex -> createOrUpdatePatchIndexDisk repo - -repoPatchType :: Repository p wR wU wT -> PatchType p -repoPatchType _ = PatchType - -cloneRepository :: - String -- origin repository path - -> String -- new repository name (for relative path) - -> Verbosity -> UseCache - -> CloneKind - -> UMask -> RemoteDarcs - -> SetScriptsExecutable - -> RemoteRepos -> SetDefault - -> [MatchFlag] - -> RepoFormat - -> WithWorkingDir - -> WithPatchIndex -- use patch index - -> Bool -- use packs - -> Bool -- --to-match given - -> ForgetParent - -> IO () -cloneRepository repodir mysimplename v uc cloneKind um rdarcs sse remoteRepos - setDefault matchFlags rfsource withWorkingDir usePatchIndex usePacks toMatch forget = do - createDirectory mysimplename - setCurrentDirectory mysimplename - createRepository (not $ formatHas Darcs2 rfsource) - withWorkingDir - (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex) - debugMessage "Finished initializing new directory." - addRepoSource repodir NoDryRun remoteRepos setDefault - - if toMatch && cloneKind /= LazyClone - then withRepository uc $ RepoJob $ \repository -> do - debugMessage "Using economical clone --to-match handling" - fromrepo <- identifyRepositoryFor repository uc repodir - Sealed patches_to_get <- getOnePatchset fromrepo matchFlags - patchSetToRepository fromrepo patches_to_get uc rdarcs - debugMessage "Finished converting selected patch set to new repository" - else copyRepoAndGoToChosenVersion repodir v uc cloneKind um rdarcs sse - matchFlags withWorkingDir usePacks forget - --- assumes that the target repo of the get is the current directory, --- and that an inventory in the right format has already been created. -copyRepoAndGoToChosenVersion :: - String -- repository directory - -> Verbosity -> UseCache - -> CloneKind - -> UMask -> RemoteDarcs - -> SetScriptsExecutable - -> [MatchFlag] - -> WithWorkingDir -> Bool - -> ForgetParent - -> IO () -copyRepoAndGoToChosenVersion repodir v uc gk um rdarcs sse matchFlags withWorkingDir usePacks forget = - withRepository uc $ RepoJob $ \repository -> do - debugMessage "Identifying and copying repository..." - fromRepo@(Repo fromDir rffrom _ _) <- identifyRepositoryFor repository uc repodir - case readProblem rffrom of - Just e -> fail $ "Incompatibility with repository " ++ fromDir ++ ":\n" ++ e - Nothing -> return () - debugMessage "Copying prefs" - copyFileOrUrl rdarcs (fromDir ++ "/" ++ darcsdir ++ "/prefs/prefs") - (darcsdir ++ "/prefs/prefs") (MaxAge 600) `catchall` return () - if formatHas HashedInventory rffrom - then do - -- copying basic repository (hashed_inventory and pristine) - if usePacks && (not . isValidLocalPath) fromDir - then copyBasicRepoPacked fromRepo v uc um rdarcs withWorkingDir - else copyBasicRepoNotPacked fromRepo v uc um rdarcs withWorkingDir - when (gk /= LazyClone) $ do - when (gk /= CompleteClone) $ - putInfo v $ text "Copying patches, to get lazy repository hit ctrl-C..." - -- copying complete repository (inventories and patches) - if usePacks && (not . isValidLocalPath) fromDir - then copyCompleteRepoPacked fromRepo v uc um gk - else copyCompleteRepoNotPacked fromRepo v uc um gk - else - -- old-fashioned repositories are cloned diferently since - -- we need to copy all patches first and then build pristine - copyRepoOldFashioned fromRepo v uc um withWorkingDir - when (sse == YesSetScriptsExecutable) setScriptsExecutable - when (havePatchsetMatch matchFlags) $ do - putStrLn "Going to specified version..." - -- read again repository on disk to get caches and sources right - withRepoLock NoDryRun uc YesUpdateWorking um $ RepoJob $ \repository' -> do - patches <- readRepo repository' - Sealed context <- getOnePatchset repository' matchFlags - when (snd (countUsThem patches context) > 0) $ - errorDoc $ text "Missing patches from context!" -- FIXME : - ( - _ :> us' <- return $ findCommonWithThem patches context - let ps = mapFL_FL hopefully us' - putInfo v $ text $ "Unapplying " ++ show (lengthFL ps) ++ " " ++ - englishNum (lengthFL ps) (Noun "patch") "" - invalidateIndex repository' - _ <- tentativelyRemovePatches repository' GzipCompression YesUpdateWorking us' - tentativelyAddToPending repository' YesUpdateWorking $ invert $ effect us' - finalizeRepositoryChanges repository' YesUpdateWorking GzipCompression - runDefault (apply (invert $ effect ps)) `catch` \(e :: IOException) -> - fail ("Couldn't undo patch in working dir.\n" ++ show e) - when (sse == YesSetScriptsExecutable) $ setScriptsExecutablePatches (invert $ effect ps) - when (forget == YesForgetParent) deleteSources - -putInfo :: Verbosity -> Doc -> IO () -putInfo Quiet _ = return () -putInfo _ d = hPutDocLn Encode stderr d - -putVerbose :: Verbosity -> Doc -> IO () -putVerbose Verbose d = putDocLn d -putVerbose _ _ = return () - -copyBasicRepoNotPacked :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT - -> Verbosity -> UseCache - -> UMask -> RemoteDarcs - -> WithWorkingDir - -> IO () -copyBasicRepoNotPacked (Repo fromDir _ _ fromCache) verb useCache umask rdarcs withWorkingDir = do - toRepo@(Repo toDir toFormat toPristine toCache) <- identifyRepository useCache "." - let (_dummy :: Repository p wR wU wT) = toRepo --The witnesses are wrong, but cannot escape - toCache2 <- unionRemoteCaches toCache fromCache fromDir - let toRepo2 :: Repository p wR wU wT - toRepo2 = Repo toDir toFormat toPristine toCache2 - HashedRepo.copyHashedInventory toRepo2 rdarcs fromDir - HashedRepo.copySources toRepo2 fromDir - debugMessage "Grabbing lock in new repository to copy basic repo..." - withRepoLock NoDryRun useCache YesUpdateWorking umask - $ RepoJob $ \torepository -> do - putVerbose verb $ text "Writing pristine and working directory contents..." - createPristineDirectoryTree torepository "." withWorkingDir - - -copyCompleteRepoNotPacked :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT - -> Verbosity -> UseCache - -> UMask -> CloneKind - -> IO () -copyCompleteRepoNotPacked _ verb useCache umask cloneKind = do - debugMessage "Grabbing lock in new repository to copy complete repo..." - withRepoLock NoDryRun useCache YesUpdateWorking umask - $ RepoJob $ \torepository@(Repo todir _ _ _) -> do - let cleanup = putInfo verb $ text "Using lazy repository." - allowCtrlC cloneKind cleanup $ do - fetchPatchesIfNecessary torepository - pi <- doesPatchIndexExist todir - when pi $ createPIWithInterrupt torepository - -packsDir :: String -packsDir = "/" ++ darcsdir ++ "/packs/" - -copyBasicRepoPacked :: - forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) - => Repository p wR wU wT - -> Verbosity -> UseCache - -> UMask -> RemoteDarcs - -> WithWorkingDir - -> IO () -copyBasicRepoPacked r@(Repo fromDir _ _ _) verb useCache umask rdarcs withWorkingDir = - do let hashURL = fromDir ++ packsDir ++ "pristine" - mPackHash <- (Just <$> gzFetchFilePS hashURL Uncachable) `catchall` (return Nothing) - let hiURL = fromDir ++ "/" ++ darcsdir ++ "/hashed_inventory" - i <- gzFetchFilePS hiURL Uncachable - let currentHash = BS.pack $ inv2pris i - let copyNormally = copyBasicRepoNotPacked r verb useCache umask rdarcs withWorkingDir - case mPackHash of - Just packHash | packHash == currentHash - -> ( copyBasicRepoPacked2 r verb useCache withWorkingDir - `catchall` do putStrLn "Problem while copying basic pack, copying normally." - copyNormally) - _ -> do putVerbose verb $ text "Remote repo has no basic pack or outdated basic pack, copying normally." - copyNormally - -copyBasicRepoPacked2 :: - forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) - => Repository p wR wU wT - -> Verbosity -> UseCache - -> WithWorkingDir -> IO () -copyBasicRepoPacked2 fromRepo@(Repo fromDir _ _ fromCache) verb useCache withWorkingDir = do - b <- fetchFileLazyPS (fromDir ++ packsDir ++ "basic.tar.gz") Uncachable - putVerbose verb $ text "Cloning packed basic repository." - Repo toDir toFormat toPristine toCache <- - identifyRepositoryFor fromRepo useCache "." - toCache2 <- unionRemoteCaches toCache fromCache fromDir - let toRepo :: Repository p wR wU wR -- In empty repo, t(entative) = r(ecorded) - toRepo = Repo toDir toFormat toPristine toCache2 - copySources toRepo fromDir - Repo _ _ _ toCache3 <- - identifyRepositoryFor toRepo useCache "." - -- unpack inventory & pristine cache - cleanDir "pristine.hashed" - removeFile $ darcsdir "hashed_inventory" - unpackBasic toCache3 . Tar.read $ decompress b - createPristineDirectoryTree toRepo "." withWorkingDir - putVerbose verb $ text "Basic repository unpacked. Will now see if there are new patches." - -- pull new patches - us <- readRepo toRepo - them <- readRepo fromRepo - us' :\/: them' <- return $ findUncommon us them - revertTentativeChanges - Sealed pw <- tentativelyMergePatches toRepo "clone" NoAllowConflicts YesUpdateWorking NoExternalMerge NoWantGuiPause GzipCompression verb NoReorder ( UseIndex, ScanKnown, MyersDiff ) us' them' - invalidateIndex toRepo - finalizeRepositoryChanges toRepo YesUpdateWorking GzipCompression - when (withWorkingDir == WithWorkingDir) $ void $ applyToWorking toRepo verb pw - where - cleanDir d = mapM_ (\x -> removeFile $ darcsdir d x) . - filter (\x -> head x /= '.') =<< getDirectoryContents (darcsdir d) - -copyCompleteRepoPacked :: - forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) - => Repository p wR wU wT - -> Verbosity -> UseCache - -> UMask - -> CloneKind - -> IO () -copyCompleteRepoPacked r verb useCache umask cloneKind = - ( copyCompleteRepoPacked2 r verb useCache cloneKind - `catchall` do putVerbose verb $ text "Problem while copying patches pack, copying normally." - copyCompleteRepoNotPacked r verb useCache umask cloneKind ) - -copyCompleteRepoPacked2 :: - forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) - => Repository p wR wU wT - -> Verbosity -> UseCache - -> CloneKind - -> IO () -copyCompleteRepoPacked2 fromRepo@(Repo fromDir _ _ fromCache) verb useCache cloneKind = do - Repo toDir toFormat toPristine toCache <- identifyRepositoryFor fromRepo useCache "." - toCache2 <- unionRemoteCaches toCache fromCache fromDir - let toRepo :: Repository p wR wU wR -- In empty repo, t(entative) = r(ecorded) - toRepo = Repo toDir toFormat toPristine toCache2 - Repo _ _ _ toCache3 <- identifyRepositoryFor toRepo useCache "." - us <- readRepo toRepo - -- get old patches - let cleanup = putInfo verb $ text "Using lazy repository." - allowCtrlC cloneKind cleanup $ do - cleanDir "patches" - putVerbose verb $ text "Using patches pack." - unpackPatches toCache3 (mapRL hashedPatchFileName $ newset2RL us) . - Tar.read . decompress =<< fetchFileLazyPS (fromDir ++ packsDir ++ "patches.tar.gz") Uncachable - pi <- doesPatchIndexExist toDir - when pi $ createPIWithInterrupt toRepo - where - cleanDir d = mapM_ (\x -> removeFile $ darcsdir d x) . - filter (\x -> head x /= '.') =<< getDirectoryContents (darcsdir d) - -allowCtrlC :: CloneKind -> IO () -> IO () -> IO () -allowCtrlC CompleteClone _ action = action -allowCtrlC _ cleanup action = action `catchInterrupt` cleanup - -copyRepoOldFashioned :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT - -> Verbosity -> UseCache - -> UMask - -> WithWorkingDir - -> IO () -copyRepoOldFashioned fromrepository verb useCache umask withWorkingDir = do - toRepo@(Repo _ _ _ toCache) <- identifyRepository useCache "." - let (_dummy :: Repository p wR wU wT) = toRepo --The witnesses are wrong, but cannot escape - -- copy all patches from remote - HashedRepo.revertTentativeChanges - patches <- readRepo fromrepository - let k = "Copying patch" - beginTedious k - tediousSize k (lengthRL $ newset2RL patches) - let patches' = progressPatchSet k patches - HashedRepo.writeTentativeInventory toCache GzipCompression patches' - endTedious k - HashedRepo.finalizeTentativeChanges toRepo GzipCompression - -- apply all patches into current hashed repository - debugMessage "Grabbing lock in new repository..." - withRepoLock NoDryRun useCache YesUpdateWorking umask - $ RepoJob $ \torepository -> do - local_patches <- readRepo torepository - replacePristine torepository emptyTree - let patchesToApply = progressFL "Applying patch" $ newset2FL local_patches - sequence_ $ mapFL applyToTentativePristine $ bunchFL 100 patchesToApply - finalizeRepositoryChanges torepository YesUpdateWorking GzipCompression - putVerbose verb $ text "Writing pristine and working directory contents..." - createPristineDirectoryTree torepository "." withWorkingDir - -withControlMVar :: (MVar () -> IO ()) -> IO () -withControlMVar f = do - mv <- newMVar () - f mv - takeMVar mv - -forkWithControlMVar :: MVar () -> IO () -> IO () -forkWithControlMVar mv f = do - takeMVar mv - _ <- forkIO $ finally f (putMVar mv ()) - return () - -removeMetaFiles :: IO () -removeMetaFiles = mapM_ (removeFile . (darcsdir )) . - filter ("meta-" `isPrefixOf`) =<< getDirectoryContents darcsdir - -unpackBasic :: Exception e => Cache -> Tar.Entries e -> IO () -unpackBasic c x = do - withControlMVar $ \mv -> unpackTar c (basicMetaHandler c mv) x - removeMetaFiles - -unpackPatches :: Exception e => Cache -> [String] -> Tar.Entries e -> IO () -unpackPatches c ps x = do - withControlMVar $ \mv -> unpackTar c (patchesMetaHandler c ps mv) x - removeMetaFiles - -unpackTar :: Exception e => Cache -> IO () -> Tar.Entries e -> IO () -unpackTar _ _ Tar.Done = return () -unpackTar _ _ (Tar.Fail e)= throwIO e -unpackTar c mh (Tar.Next x xs) = case Tar.entryContent x of - Tar.NormalFile x' _ -> do - let p = Tar.entryPath x - if "meta-" `isPrefixOf` takeFileName p - then do - BL.writeFile p x' - mh - unpackTar c mh xs - else do - ex <- doesFileExist p - if ex - then debugMessage $ "Tar thread: STOP " ++ p - else do - if p == darcsdir "hashed_inventory" - then writeFile' Nothing p x' - else writeFile' (cacheDir c) p $ compress x' - debugMessage $ "Tar thread: GET " ++ p - unpackTar c mh xs - _ -> fail "Unexpected non-file tar entry" - where - writeFile' Nothing path content = withTemp $ \tmp -> do - BL.writeFile tmp content - renameFile tmp path - writeFile' (Just ca) path content = do - let fileFullPath = case splitPath path of - _:hDir:hFile:_ -> joinPath [ca, hDir, bucketFolder hFile, hFile] - _ -> fail "Unexpected file path" - createDirectoryIfMissing True $ takeDirectory path - createLink fileFullPath path `catch` (\(ex :: IOException) -> do - if isAlreadyExistsError ex then - return () -- so much the better - else - -- ignore cache if we cannot link - writeFile' Nothing path content) - -basicMetaHandler :: Cache -> MVar () -> IO () -basicMetaHandler ca mv = do - ex <- doesFileExist $ darcsdir "meta-filelist-pristine" - when ex . forkWithControlMVar mv $ - fetchFilesUsingCache ca HashedPristineDir . lines =<< - readFile (darcsdir "meta-filelist-pristine") - -patchesMetaHandler :: Cache -> [String] -> MVar () -> IO () -patchesMetaHandler ca ps mv = do - ex <- doesFileExist $ darcsdir "meta-filelist-inventories" - when ex $ do - forkWithControlMVar mv $ fetchFilesUsingCache ca HashedPristineDir . - lines =<< readFile (darcsdir "meta-filelist-inventories") - forkWithControlMVar mv $ fetchFilesUsingCache ca HashedPatchesDir ps - -cacheDir :: Cache -> Maybe String -cacheDir (Ca cs) = listToMaybe . catMaybes .flip map cs $ \x -> case x of - Cache Directory Writable x' -> Just x' - _ -> Nothing - -hashedPatchFileName :: PatchInfoAnd p wA wB -> String -hashedPatchFileName x = case extractHash x of - Left _ -> fail "unexpected unhashed patch" - Right h -> h - --- | fetchFilesUsingCache is similar to mapM fetchFileUsingCache, exepts --- it stops execution if file it's going to fetch already exists. -fetchFilesUsingCache :: Cache -> HashedDir -> [FilePath] -> IO () -fetchFilesUsingCache _ _ [] = return () -fetchFilesUsingCache c d (f:fs) = do - ex <- doesFileExist $ darcsdir hashedDir d f - if ex - then debugMessage $ "Cache thread: STOP " ++ - (darcsdir hashedDir d f) - else do - debugMessage $ "Cache thread: GET " ++ - (darcsdir hashedDir d f) - _ <- fetchFileUsingCache c d f - fetchFilesUsingCache c d fs - --- | writePatchSet is like patchSetToRepository, except that it doesn't --- touch the working directory or pristine cache. -writePatchSet :: (RepoPatch p, ApplyState p ~ Tree) - => PatchSet p Origin wX - -> UseCache - -> IO (Repository p wR wU wT) -writePatchSet patchset useCache = do - maybeRepo <- maybeIdentifyRepository useCache "." - let repo@(Repo _ _ _ c) = - case maybeRepo of - GoodRepository r -> r - BadRepository e -> bug ("Current directory is a bad repository in writePatchSet: " ++ e) - NonRepository e -> bug ("Current directory not a repository in writePatchSet: " ++ e) - debugMessage "Writing inventory" - HashedRepo.writeTentativeInventory c GzipCompression patchset - HashedRepo.finalizeTentativeChanges repo GzipCompression - return repo - --- | patchSetToRepository takes a patch set, and writes a new repository --- in the current directory that contains all the patches in the patch --- set. This function is used when 'darcs get'ing a repository with --- the --to-match flag. -patchSetToRepository :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR1 wU1 wR1 - -> PatchSet p Origin wX - -> UseCache -> RemoteDarcs - -> IO () -patchSetToRepository (Repo fromrepo rf _ _) patchset useCache remoteDarcs = do - when (formatHas HashedInventory rf) $ -- set up sources and all that - do writeFile (darcsdir "tentative_pristine") "" -- this is hokey - repox <- writePatchSet patchset useCache - HashedRepo.copyHashedInventory repox remoteDarcs fromrepo - HashedRepo.copySources repox fromrepo - repo <- writePatchSet patchset useCache - readRepo repo >>= (runDefault . applyPatches . newset2FL) - debugMessage "Writing the pristine" - pristineFromWorking repo +import Darcs.Util.Tree( Tree, emptyTree, expand, list ) +import Darcs.Util.Tree.Plain( readPlainTree ) checkUnrelatedRepos :: RepoPatch p => Bool - -> PatchSet p wStart wX - -> PatchSet p wStart wY + -> PatchSet rt p wStart wX + -> PatchSet rt p wStart wY -> IO () checkUnrelatedRepos allowUnrelatedRepos us them = when ( not allowUnrelatedRepos && areUnrelatedRepos us them ) $ @@ -771,32 +211,11 @@ unless confirmed $ do putStrLn "Cancelled." exitSuccess --- | This function fetches all patches that the given repository has --- with fetchFileUsingCache, unless --lazy is passed. -fetchPatchesIfNecessary :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT - -> IO () -fetchPatchesIfNecessary torepository@(Repo _ _ _ c) = - do r <- readRepo torepository - pipelineLength <- maxPipelineLength - let patches = newset2RL r - ppatches = progressRLShowTags "Copying patches" patches - (first, other) = splitAt (pipelineLength - 1) $ tail $ hashes patches - speculate | pipelineLength > 1 = [] : first : map (:[]) other - | otherwise = [] - mapM_ fetchAndSpeculate $ zip (hashes ppatches) (speculate ++ repeat []) - where hashes :: forall wX wY . RL (PatchInfoAnd p) wX wY -> [String] - hashes = catMaybes . mapRL (either (const Nothing) Just . extractHash) - fetchAndSpeculate :: (String, [String]) -> IO () - fetchAndSpeculate (f, ss) = do - _ <- fetchFileUsingCache c HashedPatchesDir f - mapM_ (speculateFileUsingCache c HashedPatchesDir) ss - -- | 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) - => Repository p wR wU wT -> UpdateWorking +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 @@ -811,8 +230,8 @@ -- 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) - => Repository p wR wU wT -> UpdateWorking -> FL (PrimOf p) wU wY -> IO () +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 @@ -820,22 +239,6 @@ case genCommuteWhatWeCanRL commuteFL (reverseFL toUnrec :> p) of (toP' :> p' :> _excessUnrec) -> makeNewPending repo uw $ toPend +>+ reverseRL toP' +>+ p' - --- | Replace the existing pristine with a new one (loaded up in a Tree object). -replacePristine :: Repository p wR wU wT -> Tree IO -> IO () -replacePristine (Repo r _ _ _) = writePristine r - -writePristine :: FilePath -> Tree IO -> IO () -writePristine r tree = withCurrentDirectory r $ - do let t = darcsdir "hashed_inventory" - i <- gzReadFilePS t - tree' <- darcsAddMissingHashes tree - root <- writeDarcsHashed tree' $ darcsdir "pristine.hashed" - writeDocBinFile t $ pris2inv (BS.unpack $ encodeBase16 root) i - -pristineFromWorking :: RepoPatch p => Repository p wR wU wT -> IO () -pristineFromWorking repo@(Repo dir _ _ _) = - withCurrentDirectory dir $ readWorking >>= replacePristine repo -- | Get a list of all files and directories in the working copy, including -- boring files if necessary diff --git a/src/Darcs/Repository/ApplyPatches.hs b/src/Darcs/Repository/ApplyPatches.hs --- a/src/Darcs/Repository/ApplyPatches.hs +++ b/src/Darcs/Repository/ApplyPatches.hs @@ -25,7 +25,7 @@ , DefaultIO, runDefault ) where -import Prelude hiding ( catch ) +import Prelude hiding ( Applicative ) import Control.Exception ( catch, SomeException, IOException ) import Data.Char ( toLower ) import Data.List ( isSuffixOf ) @@ -39,21 +39,21 @@ doesDirectoryExist, doesFileExist ) -import Darcs.Patch.ApplyMonad( ApplyMonad(..) ) +import Darcs.Patch.ApplyMonad( ApplyMonad(..), ApplyMonadTree(..) ) import Darcs.Patch.ApplyPatches ( applyPatches ) import Darcs.Patch.MonadProgress ( MonadProgress(..), ProgressAction(..) ) import Darcs.Repository.Prefs( changePrefval ) -import Darcs.Repository.Lock ( writeAtomicFilePS ) +import Darcs.Util.Lock ( writeAtomicFilePS ) import Darcs.Util.Exception ( prettyException ) import Darcs.Util.Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) import Darcs.Util.Printer ( hPutDocLn, RenderMode(..) ) import Darcs.Util.Printer.Color ( showDoc ) -import Darcs.Repository.External ( backupByCopying, backupByRenaming ) +import Darcs.Util.External ( backupByCopying, backupByRenaming ) import Darcs.Util.Path ( FileName, fn2fp ) import qualified Data.ByteString as B (empty, null, readFile) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) newtype DefaultIO a = DefaultIO { runDefaultIO :: IO a } deriving (Functor, Applicative, Monad) @@ -71,8 +71,10 @@ do hPutDocLn Encode stderr $ paOnError item ioError e -instance ApplyMonad DefaultIO Tree where +instance ApplyMonad Tree DefaultIO where type ApplyMonadBase DefaultIO = IO + +instance ApplyMonadTree DefaultIO where mDoesDirectoryExist = DefaultIO . doesDirectoryExist . fn2fp mChangePref a b c = DefaultIO $ changePrefval a b c mModifyFilePS f j = DefaultIO $ B.readFile (fn2fp f) >>= runDefaultIO . j >>= writeAtomicFilePS (fn2fp f) @@ -137,8 +139,10 @@ runDefault :: DefaultIO a -> IO a runDefault = runDefaultIO -instance TolerantMonad m => ApplyMonad (TolerantWrapper m) Tree where +instance TolerantMonad m => ApplyMonad Tree (TolerantWrapper m) where type ApplyMonadBase (TolerantWrapper m) = IO + +instance TolerantMonad m => ApplyMonadTree (TolerantWrapper m) where mDoesDirectoryExist d = runTM $ runDefaultIO $ mDoesDirectoryExist d mReadFilePS f = runTM $ runDefaultIO $ mReadFilePS f mChangePref a b c = warning $ runDefaultIO $ mChangePref a b c diff --git a/src/Darcs/Repository/Cache.hs b/src/Darcs/Repository/Cache.hs --- a/src/Darcs/Repository/Cache.hs +++ b/src/Darcs/Repository/Cache.hs @@ -44,13 +44,13 @@ import Darcs.Util.ByteString ( gzWriteFilePS, linesPS ) import Darcs.Util.Global ( darcsdir, addBadSource, isBadSource, addReachableSource, - isReachableSource, getBadSourcesList ) -import Darcs.Repository.External ( gzFetchFilePS, fetchFilePS, - speculateFileOrUrl, copyFileOrUrl, - Cachable( Cachable ) ) -import Darcs.Repository.Flags ( Compression(..), RemoteDarcs(..) ) -import Darcs.Repository.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS, - withTemp ) + isReachableSource, getBadSourcesList, defaultRemoteDarcsCmd ) +import Darcs.Util.External ( gzFetchFilePS, fetchFilePS + , speculateFileOrUrl, copyFileOrUrl + , Cachable( Cachable ) ) +import Darcs.Repository.Flags ( Compression(..) ) +import Darcs.Util.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS, + withTemp ) import Darcs.Util.SignalHandler ( catchNonSignal ) import Darcs.Util.URL ( isValidLocalPath, isHttpUrl, isSshUrl ) import Darcs.Util.File ( withCurrentDirectory ) @@ -318,7 +318,7 @@ `catchNonSignal` \e -> checkCacheReachability (show e) c else do debugMessage $ "Copying from " ++ show cacheFile ++ " to " ++ show out - copyFileOrUrl DefaultRemoteDarcs cacheFile out Cachable + copyFileOrUrl defaultRemoteDarcsCmd cacheFile out Cachable `catchNonSignal` (\e -> do checkCacheReachability (show e) c sfuc out cs) -- try another read-only location @@ -382,7 +382,7 @@ checkHashedInventoryReachability :: CacheLoc -> IO Bool checkHashedInventoryReachability cache = withTemp $ \tempout -> do let f = cacheSource cache darcsdir "hashed_inventory" - copyFileOrUrl DefaultRemoteDarcs f tempout Cachable + copyFileOrUrl defaultRemoteDarcsCmd f tempout Cachable return True `catchNonSignal` const (return False) diff --git a/src/Darcs/Repository/Clone.hs b/src/Darcs/Repository/Clone.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Clone.hs @@ -0,0 +1,507 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +module Darcs.Repository.Clone + ( createRepository + , cloneRepository + , replacePristine + , writePatchSet + , patchSetToRepository + ) where + +import Prelude () +import Darcs.Prelude + +import Control.Exception ( catch, SomeException ) +import Control.Monad ( when, void ) +import qualified Data.ByteString.Char8 as BS +import Data.Maybe( catMaybes, isJust ) +import System.FilePath( () ) +import System.Directory + ( createDirectory + , removeFile + , getDirectoryContents + , getCurrentDirectory + , setCurrentDirectory + ) +import System.IO ( stderr ) +import System.IO.Error ( isAlreadyExistsError ) + +import Darcs.Repository.State ( invalidateIndex, readWorking ) + +import Darcs.Repository.Internal + ( Repository(..) + , IdentifyRepo(..) + , identifyRepositoryFor + , identifyRepository + , maybeIdentifyRepository + , readRepo + , tentativelyRemovePatches + , tentativelyAddToPending + , finalizeRepositoryChanges + , createPristineDirectoryTree + , setScriptsExecutable + , setScriptsExecutablePatches + , seekRepo + , repoPatchType + , revertRepositoryChanges + ) +import Darcs.Repository.InternalTypes + ( modifyCache ) +import Darcs.Repository.Job ( RepoJob(..), withRepoLock, withRepository ) +import Darcs.Repository.Cache + ( unionRemoteCaches + , unionCaches + , fetchFileUsingCache + , speculateFileUsingCache + , HashedDir(..) + , Cache(..) + , CacheLoc(..) + , repo2cache + ) +import qualified Darcs.Repository.Cache as DarcsCache + +import qualified Darcs.Repository.HashedRepo as HashedRepo +import Darcs.Repository.ApplyPatches ( applyPatches, runDefault ) +import Darcs.Repository.HashedRepo + ( applyToTentativePristine + , pris2inv + , inv2pris + ) +import Darcs.Repository.Format + ( RepoProperty ( HashedInventory, Darcs2 ) + , RepoFormat + , createRepoFormat + , formatHas + , writeRepoFormat + , readProblem + ) +import Darcs.Repository.Prefs ( writeDefaultPrefs, addRepoSource, deleteSources ) +import Darcs.Repository.Match ( getOnePatchset ) +import Darcs.Util.External + ( copyFileOrUrl + , Cachable(..) + , gzFetchFilePS + ) +import Darcs.Repository.PatchIndex + ( createOrUpdatePatchIndexDisk + , doesPatchIndexExist + , createPIWithInterrupt + ) +import Darcs.Repository.Packs + ( fetchAndUnpackBasic + , fetchAndUnpackPatches + , packsDir + ) +import Darcs.Util.Lock + ( writeBinFile + , writeDocBinFile + , appendBinFile + ) +import Darcs.Repository.Flags + ( UpdateWorking(..) + , UseCache(..) + , RemoteDarcs (..) + , remoteDarcs + , Compression (..) + , CloneKind (..) + , Verbosity (..) + , DryRun (..) + , UMask (..) + , SetScriptsExecutable (..) + , RemoteRepos (..) + , SetDefault (..) + , WithWorkingDir (..) + , ForgetParent (..) + , WithPatchIndex (..) + , PatchFormat (..) + ) + +import Darcs.Patch ( RepoPatch, IsRepoType, apply, invert, effect, PrimOf ) +import Darcs.Patch.Depends ( findCommonWithThem, countUsThem ) +import Darcs.Patch.Set ( Origin + , PatchSet(..) + , newset2RL + , newset2FL + , progressPatchSet + ) +import Darcs.Patch.Match ( MatchFlag(..), havePatchsetMatch ) +import Darcs.Patch.Progress ( progressRLShowTags, progressFL ) +import Darcs.Patch.Apply( ApplyState ) +import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) +import Darcs.Patch.Witnesses.Ordered + ( (:>)(..) + , lengthFL + , mapFL_FL + , RL(..) + , bunchFL + , mapFL + , mapRL + , lengthRL + ) +import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash, hopefully ) + +import Darcs.Util.Hash( encodeBase16 ) +import Darcs.Util.Tree( Tree, emptyTree ) +import Darcs.Util.Tree.Hashed( writeDarcsHashed, darcsAddMissingHashes ) + +import Darcs.Util.ByteString( gzReadFilePS ) +import Darcs.Util.Download ( maxPipelineLength ) +import Darcs.Util.Exception ( catchall ) +import Darcs.Util.File ( withCurrentDirectory ) +import Darcs.Util.English ( englishNum, Noun(..) ) +import Darcs.Util.Global ( darcsdir ) +import Darcs.Util.URL ( isValidLocalPath ) +import Darcs.Util.SignalHandler ( catchInterrupt ) +import Darcs.Util.Printer ( Doc, text, hPutDocLn, putDocLn, errorDoc, RenderMode(..) ) +import Darcs.Util.Progress + ( debugMessage + , tediousSize + , beginTedious + , endTedious + ) + +#include "impossible.h" + +createRepository :: PatchFormat -> WithWorkingDir -> WithPatchIndex -> IO () +createRepository patchfmt withWorkingDir createPatchIndex = do + createDirectory darcsdir `catch` + (\e-> if isAlreadyExistsError e + then fail "Tree has already been initialized!" + else fail $ "Error creating directory `"++darcsdir++"'.") + cwd <- getCurrentDirectory + x <- seekRepo + when (isJust x) $ do + setCurrentDirectory cwd + putStrLn "WARNING: creating a nested repository." + createDirectory $ darcsdir "pristine.hashed" + createDirectory $ darcsdir "patches" + createDirectory $ darcsdir "inventories" + createDirectory $ darcsdir "prefs" + writeDefaultPrefs + writeRepoFormat (createRepoFormat patchfmt withWorkingDir) (darcsdir "format") + writeBinFile (darcsdir "hashed_inventory") "" + writePristine "." emptyTree + withRepository NoUseCache $ RepoJob $ \repo -> case createPatchIndex of + NoPatchIndex -> return () -- default + YesPatchIndex -> createOrUpdatePatchIndexDisk repo + +cloneRepository :: + String -- origin repository path + -> String -- new repository name (for relative path) + -> Verbosity -> UseCache + -> CloneKind + -> UMask -> RemoteDarcs + -> SetScriptsExecutable + -> RemoteRepos -> SetDefault + -> [MatchFlag] + -> RepoFormat + -> WithWorkingDir + -> WithPatchIndex -- use patch index + -> Bool -- use packs + -> ForgetParent + -> IO () +cloneRepository repodir mysimplename v uc cloneKind um rdarcs sse remoteRepos + setDefault matchFlags rfsource withWorkingDir usePatchIndex usePacks forget = do + createDirectory mysimplename + setCurrentDirectory mysimplename + createRepository (if formatHas Darcs2 rfsource then PatchFormat2 else PatchFormat1) + withWorkingDir + (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex) + debugMessage "Finished initializing new repository." + addRepoSource repodir NoDryRun remoteRepos setDefault + + debugMessage "Grabbing lock in new repository." + withRepoLock NoDryRun uc YesUpdateWorking um + $ RepoJob $ \repository -> do + debugMessage "Identifying and copying repository..." + fromRepo@(Repo fromDir rffrom _ fromCache) <- identifyRepositoryFor repository uc repodir + case readProblem rffrom of + Just e -> fail $ "Incompatibility with repository " ++ fromDir ++ ":\n" ++ e + Nothing -> return () + debugMessage "Copying prefs" + copyFileOrUrl (remoteDarcs rdarcs) (fromDir darcsdir "prefs" "prefs") + (darcsdir "prefs/prefs") (MaxAge 600) `catchall` return () + -- prepare sources and cache + (Repo toDir toFormat toPristine toCache) <- identifyRepository uc "." + toCache2 <- unionRemoteCaches toCache fromCache fromDir + toRepo <- copySources (Repo toDir toFormat toPristine toCache2) fromDir + if formatHas HashedInventory rffrom then do + -- copying basic repository (hashed_inventory and pristine) + if usePacks && (not . isValidLocalPath) fromDir + then copyBasicRepoPacked fromRepo toRepo v rdarcs withWorkingDir + else copyBasicRepoNotPacked fromRepo toRepo v rdarcs withWorkingDir + when (cloneKind /= LazyClone) $ do + when (cloneKind /= CompleteClone) $ + putInfo v $ text "Copying patches, to get lazy repository hit ctrl-C..." + -- copying complete repository (inventories and patches) + if usePacks && (not . isValidLocalPath) fromDir + then copyCompleteRepoPacked fromRepo toRepo v cloneKind + else copyCompleteRepoNotPacked fromRepo toRepo v cloneKind + else + -- old-fashioned repositories are cloned diferently since + -- we need to copy all patches first and then build pristine + copyRepoOldFashioned fromRepo toRepo v withWorkingDir + when (sse == YesSetScriptsExecutable) setScriptsExecutable + when (havePatchsetMatch (repoPatchType repository) matchFlags) $ do + putStrLn "Going to specified version..." + -- the following is necessary to be able to read repo's patches + revertRepositoryChanges toRepo YesUpdateWorking + patches <- readRepo toRepo + Sealed context <- getOnePatchset toRepo matchFlags + when (snd (countUsThem patches context) > 0) $ + errorDoc $ text "Missing patches from context!" -- FIXME : - ( + _ :> us' <- return $ findCommonWithThem patches context + let ps = mapFL_FL hopefully us' + putInfo v $ text $ "Unapplying " ++ show (lengthFL ps) ++ " " ++ + englishNum (lengthFL ps) (Noun "patch") "" + invalidateIndex toRepo + _ <- tentativelyRemovePatches toRepo GzipCompression YesUpdateWorking us' + tentativelyAddToPending toRepo YesUpdateWorking $ invert $ effect us' + finalizeRepositoryChanges toRepo YesUpdateWorking GzipCompression + runDefault (apply (invert $ effect ps)) `catch` \(e :: SomeException) -> + fail ("Couldn't undo patch in working dir.\n" ++ show e) + when (sse == YesSetScriptsExecutable) $ setScriptsExecutablePatches (invert $ effect ps) + when (forget == YesForgetParent) deleteSources + +putInfo :: Verbosity -> Doc -> IO () +putInfo Quiet _ = return () +putInfo _ d = hPutDocLn Encode stderr d + +putVerbose :: Verbosity -> Doc -> IO () +putVerbose Verbose d = putDocLn d +putVerbose _ _ = return () + +copyBasicRepoNotPacked :: forall rt p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -- remote + -> Repository rt p wR wU wT -- existing empty local + -> Verbosity + -> RemoteDarcs + -> WithWorkingDir + -> IO () +copyBasicRepoNotPacked (Repo fromDir _ _ _) toRepo verb rdarcs withWorkingDir = do + putVerbose verb $ text "Copying hashed inventory from remote repo..." + HashedRepo.copyHashedInventory toRepo rdarcs fromDir + putVerbose verb $ text "Writing pristine and working directory contents..." + createPristineDirectoryTree toRepo "." withWorkingDir + +copyCompleteRepoNotPacked :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -- remote + -> Repository rt p wR wU wT -- existing basic local + -> Verbosity + -> CloneKind + -> IO () +copyCompleteRepoNotPacked _ torepository@(Repo todir _ _ _) verb cloneKind = do + let cleanup = putInfo verb $ text "Using lazy repository." + allowCtrlC cloneKind cleanup $ do + fetchPatchesIfNecessary torepository + pi <- doesPatchIndexExist todir + when pi $ createPIWithInterrupt torepository + +copyBasicRepoPacked :: + forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) + => Repository rt p wR wU wT -- remote + -> Repository rt p wR wU wT -- existing empty local repository + -> Verbosity + -> RemoteDarcs + -> WithWorkingDir + -> IO () +copyBasicRepoPacked r@(Repo fromDir _ _ _) toRepo verb rdarcs withWorkingDir = + do let hashURL = fromDir darcsdir packsDir "pristine" + mPackHash <- (Just <$> gzFetchFilePS hashURL Uncachable) `catchall` (return Nothing) + let hiURL = fromDir darcsdir "hashed_inventory" + i <- gzFetchFilePS hiURL Uncachable + let currentHash = BS.pack $ inv2pris i + let copyNormally = copyBasicRepoNotPacked r toRepo verb rdarcs withWorkingDir + case mPackHash of + Just packHash | packHash == currentHash + -> ( copyBasicRepoPacked2 r toRepo verb withWorkingDir + `catch` \(e :: SomeException) -> + do putStrLn ("Exception while getting basic pack:\n" ++ show e) + copyNormally) + _ -> do putVerbose verb $ text "Remote repo has no basic pack or outdated basic pack, copying normally." + copyNormally + +copyBasicRepoPacked2 :: + forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) + => Repository rt p wR wU wT -- remote + -> Repository rt p wR wU wT -- existing empty local repository + -> Verbosity + -> WithWorkingDir + -> IO () +copyBasicRepoPacked2 (Repo fromDir _ _ _) toRepo@(Repo _ _ _ toCache) verb withWorkingDir = do + putVerbose verb $ text "Cloning packed basic repository." + -- unpack inventory & pristine cache + cleanDir $ darcsdir "pristine.hashed" + removeFile $ darcsdir "hashed_inventory" + fetchAndUnpackBasic toCache fromDir + putInfo verb $ text "Done fetching and unpacking basic pack." + createPristineDirectoryTree toRepo "." withWorkingDir + +copyCompleteRepoPacked :: + forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) + => Repository rt p wR wU wT -- remote + -> Repository rt p wR wU wT -- existing basic local repository + -> Verbosity + -> CloneKind + -> IO () +copyCompleteRepoPacked r to verb cloneKind = + ( copyCompleteRepoPacked2 r to verb cloneKind + `catch` \(e :: SomeException) -> + do putStrLn ("Exception while getting patches pack:\n" ++ show e) + putVerbose verb $ text "Problem while copying patches pack, copying normally." + copyCompleteRepoNotPacked r to verb cloneKind ) + +copyCompleteRepoPacked2 :: + forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> Repository rt p wR wU wT + -> Verbosity + -> CloneKind + -> IO () +copyCompleteRepoPacked2 (Repo fromDir _ _ _) + toRepo@(Repo toDir _ _ toCache) + verb cloneKind = do + us <- readRepo toRepo + -- get old patches + let cleanup = putInfo verb $ text "Using lazy repository." + allowCtrlC cloneKind cleanup $ do + putVerbose verb $ text "Using patches pack." + fetchAndUnpackPatches (mapRL hashedPatchFileName $ newset2RL us) toCache fromDir + pi <- doesPatchIndexExist toDir + when pi $ createPIWithInterrupt toRepo + +cleanDir :: FilePath -> IO () +cleanDir d = mapM_ (\x -> removeFile $ d x) . + filter (\x -> head x /= '.') =<< getDirectoryContents d + +copyRepoOldFashioned :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -- remote repo + -> Repository rt p wR wU wT -- local empty repo + -> Verbosity + -> WithWorkingDir + -> IO () +copyRepoOldFashioned fromrepository toRepo@(Repo _ _ _ toCache) verb withWorkingDir = do + HashedRepo.revertTentativeChanges + patches <- readRepo fromrepository + let k = "Copying patch" + beginTedious k + tediousSize k (lengthRL $ newset2RL patches) + let patches' = progressPatchSet k patches + HashedRepo.writeTentativeInventory toCache GzipCompression patches' + endTedious k + HashedRepo.finalizeTentativeChanges toRepo GzipCompression + -- apply all patches into current hashed repository + HashedRepo.revertTentativeChanges + local_patches <- readRepo toRepo + replacePristine toRepo emptyTree + let patchesToApply = progressFL "Applying patch" $ newset2FL local_patches + sequence_ $ mapFL applyToTentativePristine $ bunchFL 100 patchesToApply + finalizeRepositoryChanges toRepo YesUpdateWorking GzipCompression + putVerbose verb $ text "Writing pristine and working directory contents..." + createPristineDirectoryTree toRepo "." withWorkingDir + +-- | This function fetches all patches that the given repository has +-- with fetchFileUsingCache, unless --lazy is passed. +fetchPatchesIfNecessary :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> IO () +fetchPatchesIfNecessary torepository@(Repo _ _ _ c) = + do r <- readRepo torepository + pipelineLength <- maxPipelineLength + let patches = newset2RL r + ppatches = progressRLShowTags "Copying patches" patches + (first, other) = splitAt (pipelineLength - 1) $ tail $ hashes patches + speculate | pipelineLength > 1 = [] : first : map (:[]) other + | otherwise = [] + mapM_ fetchAndSpeculate $ zip (hashes ppatches) (speculate ++ repeat []) + where hashes :: forall wX wY . RL (PatchInfoAnd rt p) wX wY -> [String] + hashes = catMaybes . mapRL (either (const Nothing) Just . extractHash) + fetchAndSpeculate :: (String, [String]) -> IO () + fetchAndSpeculate (f, ss) = do + _ <- fetchFileUsingCache c HashedPatchesDir f + mapM_ (speculateFileUsingCache c HashedPatchesDir) ss + +-- | patchSetToRepository takes a patch set, and writes a new repository +-- in the current directory that contains all the patches in the patch +-- set. This function is used when 'darcs get'ing a repository with +-- the --to-match flag. +patchSetToRepository :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR1 wU1 wR1 + -> PatchSet rt p Origin wX + -> UseCache -> RemoteDarcs + -> IO () +patchSetToRepository (Repo fromrepo rf _ _) patchset useCache rDarcs = do + when (formatHas HashedInventory rf) $ -- set up sources and all that + do writeFile (darcsdir "tentative_pristine") "" -- this is hokey + repox <- writePatchSet patchset useCache + HashedRepo.copyHashedInventory repox rDarcs fromrepo + void $ copySources repox fromrepo + repo@(Repo dir _ _ _) <- writePatchSet patchset useCache + readRepo repo >>= (runDefault . applyPatches . newset2FL) + debugMessage "Writing the pristine" + withCurrentDirectory dir $ readWorking >>= replacePristine repo + +-- | writePatchSet is like patchSetToRepository, except that it doesn't +-- touch the working directory or pristine cache. +writePatchSet :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => PatchSet rt p Origin wX + -> UseCache + -> IO (Repository rt p wR wU wT) +writePatchSet patchset useCache = do + maybeRepo <- maybeIdentifyRepository useCache "." + let repo@(Repo _ _ _ c) = + case maybeRepo of + GoodRepository r -> r + BadRepository e -> bug ("Current directory is a bad repository in writePatchSet: " ++ e) + NonRepository e -> bug ("Current directory not a repository in writePatchSet: " ++ e) + debugMessage "Writing inventory" + HashedRepo.writeTentativeInventory c GzipCompression patchset + HashedRepo.finalizeTentativeChanges repo GzipCompression + return repo + +-- | Replace the existing pristine with a new one (loaded up in a Tree object). +replacePristine :: Repository rt p wR wU wT -> Tree IO -> IO () +replacePristine (Repo r _ _ _) = writePristine r + +writePristine :: FilePath -> Tree IO -> IO () +writePristine r tree = withCurrentDirectory r $ + do let t = darcsdir "hashed_inventory" + i <- gzReadFilePS t + tree' <- darcsAddMissingHashes tree + root <- writeDarcsHashed tree' $ darcsdir "pristine.hashed" + writeDocBinFile t $ pris2inv (BS.unpack $ encodeBase16 root) i + +allowCtrlC :: CloneKind -> IO () -> IO () -> IO () +allowCtrlC CompleteClone _ action = action +allowCtrlC _ cleanup action = action `catchInterrupt` cleanup + +hashedPatchFileName :: PatchInfoAnd rt p wA wB -> String +hashedPatchFileName x = case extractHash x of + Left _ -> fail "unexpected unhashed patch" + Right h -> h + +-- |'copySources' does two things: +-- * it copies the prefs/sources file to the local repo, from the +-- remote, having first filtered the local filesystem sources. +-- * it returns the original list of sources of the local repo +-- updated with the remote repo as an additional source +copySources :: RepoPatch p + => Repository rt p wR wU wT + -> String + -> IO (Repository rt p wR wU wT) +copySources repo@(Repo outr _ _ cache0) inr = do + let (Repo s f p newCache1) = modifyCache repo dropNonRepos + let sourcesToWrite = repo2cache inr `unionCaches` newCache1 + appendBinFile (outr ++ "/" ++ darcsdir ++ "/prefs/sources") + (show sourcesToWrite) + debugMessage "Done copying and filtering pref/sources." + + -- put remote source last: + let newSources = cache0 `unionCaches` repo2cache inr + return (Repo s f p newSources) + where + dropNonRepos (Ca cache) = Ca $ filter notRepo cache + notRepo xs = case xs of + Cache DarcsCache.Directory _ _ -> False + -- we don't want to write thisrepo: entries to the disk + Cache DarcsCache.Repo DarcsCache.Writable _ -> False + _ -> True diff --git a/src/Darcs/Repository/Compat.hs b/src/Darcs/Repository/Compat.hs deleted file mode 100644 --- a/src/Darcs/Repository/Compat.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 -{-# LANGUAGE CPP, ForeignFunctionInterface #-} - -module Darcs.Repository.Compat - ( stdoutIsAPipe - , mkStdoutTemp - , canonFilename - , maybeRelink - , atomicCreate - , sloppyAtomicCreate - ) where - -import Prelude hiding ( catch ) - -import Darcs.Util.File ( withCurrentDirectory ) -#ifdef WIN32 -import Data.Bits ( (.&.) ) -import System.Random ( randomIO ) -import Numeric ( showHex ) -#else -#endif - -import Control.Monad ( unless ) -import Foreign.C.Types ( CInt(..) ) -import Foreign.C.String ( CString, withCString -#ifndef WIN32 - , peekCString -#endif - ) - -import Foreign.C.Error ( throwErrno, eEXIST, getErrno ) -import System.Directory ( getCurrentDirectory ) -import System.IO ( hFlush, stdout, stderr, hSetBuffering, - BufferMode(NoBuffering) ) -import System.IO.Error ( mkIOError, alreadyExistsErrorType ) -import System.Posix.Files ( stdFileMode ) -import System.Posix.IO ( openFd, closeFd, stdOutput, stdError, - dupTo, defaultFileFlags, exclusive, - OpenMode(WriteOnly) ) -import System.Posix.Types ( Fd(..) ) - -import Darcs.Util.SignalHandler ( stdoutIsAPipe ) - -canonFilename :: FilePath -> IO FilePath -canonFilename f@(_:':':_) = return f -- absolute windows paths -canonFilename f@('/':_) = return f -canonFilename ('.':'/':f) = do cd <- getCurrentDirectory - return $ cd ++ "/" ++ f -canonFilename f = case reverse $ dropWhile (/='/') $ reverse f of - "" -> fmap (++('/':f)) getCurrentDirectory - rd -> withCurrentDirectory rd $ - do fd <- getCurrentDirectory - return $ fd ++ "/" ++ simplefilename - where - simplefilename = reverse $ takeWhile (/='/') $ reverse f - -#ifdef WIN32 -mkstempCore :: FilePath -> IO (Fd, String) -mkstempCore fp - = do r <- randomIO - let fp' = fp ++ showHexLen 6 (r .&. 0xFFFFFF :: Int) - fd <- openFd fp' WriteOnly (Just stdFileMode) flags - return (fd, fp') - where flags = defaultFileFlags { exclusive = True } - -showHexLen :: (Integral a, Show a) - => Int - -> a - -> String -showHexLen n x = let s = showHex x "" - in replicate (n - length s) ' ' ++ s -#else -mkstempCore :: String -> IO (Fd, String) -mkstempCore str = withCString (str++"XXXXXX") $ - \cstr -> do fd <- c_mkstemp cstr - if fd < 0 - then throwErrno $ "Failed to create temporary file "++str - else do str' <- peekCString cstr - fname <- canonFilename str' - return (Fd fd, fname) - -foreign import ccall unsafe "static stdlib.h mkstemp" - c_mkstemp :: CString -> IO CInt -#endif - -mkStdoutTemp :: String -> IO String -mkStdoutTemp str = do (fd, fn) <- mkstempCore str - hFlush stdout - hFlush stderr - _ <- dupTo fd stdOutput - _ <- dupTo fd stdError - hFlush stdout - hFlush stderr - hSetBuffering stdout NoBuffering - hSetBuffering stderr NoBuffering - return fn - - - -foreign import ccall unsafe "maybe_relink.h maybe_relink" maybe_relink - :: CString -> CString -> CInt -> IO CInt - --- Checks whether src and dst are identical. If so, makes dst into a --- link to src. Returns True if dst is a link to src (either because --- we linked it or it already was). Safe against changes to src if --- they are not in place, but not to dst. -maybeRelink :: String -> String -> IO Bool -maybeRelink src dst = - withCString src $ \csrc -> - withCString dst $ \cdst -> - do rc <- maybe_relink csrc cdst 1 - case rc of - 0 -> return True - 1 -> return True - -1 -> throwErrno ("Relinking " ++ dst) - -2 -> return False - -3 -> do putStrLn ("Relinking: race condition avoided on file " ++ - dst) - return False - _ -> fail ("Unexpected situation when relinking " ++ dst) - -sloppyAtomicCreate :: FilePath -> IO () -sloppyAtomicCreate fp - = do fd <- openFd fp WriteOnly (Just stdFileMode) flags - closeFd fd - where flags = defaultFileFlags { exclusive = True } - -atomicCreate :: FilePath -> IO () -atomicCreate fp = withCString fp $ \cstr -> do - rc <- c_atomic_create cstr - unless (rc >= 0) $ - do errno <- getErrno - pwd <- getCurrentDirectory - if errno == eEXIST - then ioError $ mkIOError alreadyExistsErrorType - ("atomicCreate in "++pwd) - Nothing (Just fp) - else throwErrno $ "atomicCreate "++fp++" in "++pwd - -foreign import ccall unsafe "atomic_create.h atomic_create" c_atomic_create - :: CString -> IO CInt diff --git a/src/Darcs/Repository/Diff.hs b/src/Darcs/Repository/Diff.hs --- a/src/Darcs/Repository/Diff.hs +++ b/src/Darcs/Repository/Diff.hs @@ -34,6 +34,8 @@ treeDiff ) where +import Prelude () +import Darcs.Prelude import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.ByteString as BS @@ -41,7 +43,7 @@ import Data.List ( sortBy ) -import Storage.Hashed.Tree ( diffTrees +import Darcs.Util.Tree ( diffTrees , zipTrees , TreeItem(..) , Tree diff --git a/src/Darcs/Repository/External.hs b/src/Darcs/Repository/External.hs deleted file mode 100644 --- a/src/Darcs/Repository/External.hs +++ /dev/null @@ -1,297 +0,0 @@ -{-# LANGUAGE CPP #-} -module Darcs.Repository.External - ( cloneTree - , cloneFile - , fetchFilePS - , fetchFileLazyPS - , gzFetchFilePS - , speculateFileOrUrl - , copyFileOrUrl - , Cachable(..) - , backupByRenaming - , backupByCopying - , environmentHelpProtocols - ) where - -import Prelude hiding ( catch ) -import Control.Exception ( catch, IOException ) - -import System.Posix.Files - ( getSymbolicLinkStatus - , isRegularFile - , isDirectory - , createLink - ) -import System.Directory - ( createDirectory - , getDirectoryContents - , doesDirectoryExist - , doesFileExist - , renameFile - , renameDirectory - , copyFile - ) - -import System.Exit ( ExitCode(..) ) -import System.Environment ( getEnv ) -import System.FilePath.Posix ( (), normalise ) -import System.IO.Error ( isDoesNotExistError ) -import Control.Monad - ( unless - , when - , zipWithM_ - ) - -import Data.Char ( toUpper ) - -import Darcs.Util.Exec ( exec, Redirect(..) ) -import Darcs.Util.Download - ( copyUrl - , copyUrlFirst - , waitUrl - , Cachable(..) - ) - -import Darcs.Util.URL - ( isValidLocalPath - , isHttpUrl - , isSshUrl - , splitSshUrl - ) -import Darcs.Util.Text ( breakCommand ) -import Darcs.Util.Exception ( catchall ) -import Darcs.Repository.Flags ( RemoteDarcs(..) ) -import Darcs.Repository.Lock ( withTemp ) -import Darcs.Repository.Ssh ( copySSH ) - -import Darcs.Util.ByteString ( gzReadFilePS ) -import qualified Data.ByteString as B (ByteString, readFile ) -import qualified Data.ByteString.Lazy as BL - -#ifdef HAVE_HTTP -import Network.Browser - ( browse - , request - , setErrHandler - , setOutHandler - , setAllowRedirects - ) -import Network.HTTP - ( RequestMethod(GET) - , rspCode - , rspBody - , rspReason - , mkRequest - ) -import Network.URI - ( parseURI - , uriScheme - ) -#endif - -copyFileOrUrl :: RemoteDarcs -> FilePath -> FilePath -> Cachable -> IO () -copyFileOrUrl _ fou out _ | isValidLocalPath fou = copyLocal fou out -copyFileOrUrl _ fou out cache | isHttpUrl fou = copyRemote fou out cache -copyFileOrUrl rd fou out _ | isSshUrl fou = copySSH rd (splitSshUrl fou) out -copyFileOrUrl _ fou _ _ = fail $ "unknown transport protocol: " ++ fou - -copyLocal :: String -> FilePath -> IO () -copyLocal fou out = createLink fou out `catchall` cloneFile fou out - -copyRemote :: String -> FilePath -> Cachable -> IO () -copyRemote u v cache = - do maybeget <- maybeURLCmd "GET" u - case maybeget of - Nothing -> copyRemoteNormal u v cache - Just get -> - do let (cmd,args) = breakCommand get - r <- exec cmd (args++[u]) (Null, File v, AsIs) - when (r /= ExitSuccess) $ - fail $ "(" ++ get ++ ") failed to fetch: " ++ u - -cloneTree :: FilePath -> FilePath -> IO () -cloneTree = cloneTreeExcept [] - -cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO () -cloneTreeExcept except source dest = - do fs <- getSymbolicLinkStatus source - if isDirectory fs then do - fps <- getDirectoryContents source - let fps' = filter (`notElem` (".":"..":except)) fps - mk_source fp = source fp - mk_dest fp = dest fp - zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') - else fail ("cloneTreeExcept: Bad source " ++ source) - `catch` \(_ :: IOException) -> fail ("cloneTreeExcept: Bad source " ++ source) - -cloneSubTree :: FilePath -> FilePath -> IO () -cloneSubTree source dest = - do fs <- getSymbolicLinkStatus source - if isDirectory fs then do - createDirectory dest - fps <- getDirectoryContents source - let fps' = filter (`notElem` [".", ".."]) fps - mk_source fp = source fp - mk_dest fp = dest fp - zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') - else if isRegularFile fs then - cloneFile source dest - else fail ("cloneSubTree: Bad source "++ source) - `catch` (\e -> unless (isDoesNotExistError e) $ ioError e) - -cloneFile :: FilePath -> FilePath -> IO () -cloneFile = copyFile - -backupByRenaming :: FilePath -> IO () -backupByRenaming = backupBy rename - where rename x y = do - isD <- doesDirectoryExist x - if isD then renameDirectory x y else renameFile x y - -backupByCopying :: FilePath -> IO () -backupByCopying = backupBy copy - where - copy x y = do - isD <- doesDirectoryExist x - if isD then do createDirectory y - cloneTree (normalise x) (normalise y) - else copyFile x y - -backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO () -backupBy backup f = - do hasBF <- doesFileExist f - hasBD <- doesDirectoryExist f - when (hasBF || hasBD) $ helper 0 - where - helper :: Int -> IO () - helper i = do existsF <- doesFileExist next - existsD <- doesDirectoryExist next - if existsF || existsD - then helper (i + 1) - else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")" - backup f next - where next = f ++ suffix - suffix = ".~" ++ show i ++ "~" - -copyAndReadFile :: (FilePath -> IO a) -> String -> Cachable -> IO a -copyAndReadFile readfn fou _ | isValidLocalPath fou = readfn fou -copyAndReadFile readfn fou cache = withTemp $ \t -> do - copyFileOrUrl DefaultRemoteDarcs fou t cache - readfn t - --- | @fetchFile fileOrUrl cache@ returns the content of its argument (either a --- file or an URL). If it has to download an url, then it will use a cache as --- required by its second argument. --- --- We always use default remote darcs, since it is not fatal if the remote --- darcs does not exist or is too old -- anything that supports transfer-mode --- should do, and if not, we will fall back to SFTP or SCP. -fetchFilePS :: String -> Cachable -> IO B.ByteString -fetchFilePS = copyAndReadFile (B.readFile) - --- | @fetchFileLazyPS fileOrUrl cache@ lazily reads the content of its argument --- (either a file or an URL). Warning: this function may constitute a fd leak; --- make sure to force consumption of file contents to avoid that. See --- "fetchFilePS" for details. -fetchFileLazyPS :: String -> Cachable -> IO BL.ByteString -#ifdef HAVE_HTTP -fetchFileLazyPS x c = case parseURI x of - Just x' | uriScheme x' == "http:" -> do - rsp <- fmap snd . browse $ do - setErrHandler . const $ return () - setOutHandler . const $ return () - setAllowRedirects True - request $ mkRequest GET x' - if rspCode rsp /= (2, 0, 0) - then fail $ "fetchFileLazyPS: " ++ rspReason rsp - else return $ rspBody rsp - _ -> copyAndReadFile BL.readFile x c -#else -fetchFileLazyPS = copyAndReadFile BL.readFile -#endif - -gzFetchFilePS :: String -> Cachable -> IO B.ByteString -gzFetchFilePS = copyAndReadFile gzReadFilePS - -maybeURLCmd :: String -> String -> IO (Maybe String) -maybeURLCmd what url = - do let prot = map toUpper $ takeWhile (/= ':') url - fmap Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot)) - `catch` \(_ :: IOException) -> return Nothing - -copyRemoteNormal :: String -> FilePath -> Cachable -> IO () -copyRemoteNormal u v cache = copyUrlFirst u v cache >> waitUrl u - -speculateFileOrUrl :: String -> FilePath -> IO () -speculateFileOrUrl fou out | isHttpUrl fou = speculateRemote fou out - | otherwise = return () - -speculateRemote :: String -> FilePath -> IO () -- speculations are always Cachable -#if defined(HAVE_CURL) || defined(HAVE_HTTP) -speculateRemote u v = - do maybeget <- maybeURLCmd "GET" u - case maybeget of - Just _ -> return () -- can't pipeline these - Nothing -> copyUrl u v Cachable -#else -speculateRemote u _ = const () `fmap` maybeURLCmd "GET" u -#endif - -environmentHelpProtocols :: ([String], [String]) -environmentHelpProtocols = (["DARCS_GET_FOO", "DARCS_APPLY_FOO"],[ - "When trying to access a repository with a URL beginning foo://,", - "darcs will invoke the program specified by the DARCS_GET_FOO", - "environment variable (if defined) to download each file, and the", - "command specified by the DARCS_APPLY_FOO environment variable (if", - "defined) when pushing to a foo:// URL.", - "", - "This method overrides all other ways of getting `foo://xxx` URLs.", - "", - "Note that each command should be constructed so that it sends the downloaded", - "content to STDOUT, and the next argument to it should be the URL.", - "Here are some examples that should work for DARCS_GET_HTTP:", - "", - " fetch -q -o -", - " curl -s -f", - " lynx -source", - " wget -q -O -", - "", - "Apart from such toy examples, it is likely that you will need to", - "manipulate the argument before passing it to the actual fetcher", - "program. For example, consider the problem of getting read access to", - "a repository on a CIFS (SMB) share without mount privileges:", - "", - " export DARCS_GET_SMB='smbclient -c get'", - " darcs get smb://fs/twb/Desktop/hello-world", - "", - "The above command will not work for several reasons. Firstly, Darcs", - "will pass it an argument beginning with `smb:`, which smbclient does", - "not understand. Secondly, the host and share `//fs/twb` must be", - "presented as a separate argument to the path `Desktop/hello-world`.", - "Thirdly, smbclient requires that `get` and the path be a single", - "argument (including a space), rather than two separate arguments.", - "Finally, smbclient's `get` command writes the file to disk, while", - "Darcs expects it to be printed to standard output.", - "", - "In principle, we could get around such problems by making the variable", - "contain a shell script, unfortunately, Darcs splits the command on", - "whitespace and does not understand quotation or escaping. Therefore,", - "we instead need to put commands in separate, executable scripts.", - "", - "Continuing our smbclient example, we create an executable script", - "`~/.darcs/libexec/get_smb` with the following contents:", - "", - " #!/bin/bash -e", - " IFS=/ read host share file <<<'${1#smb://}'", - " smbclient //$host/$share -c 'get $file -'", - "", - "And at last we can say", - "", - " export DARCS_GET_SMB=~/.darcs/libexec/get_smb", - " darcs get smb://fs/twb/Desktop/hello-world", - "", - "The APPLY command will be called with a darcs patchfile piped into", - "its standard input." - ]) - - diff --git a/src/Darcs/Repository/Flags.hs b/src/Darcs/Repository/Flags.hs --- a/src/Darcs/Repository/Flags.hs +++ b/src/Darcs/Repository/Flags.hs @@ -2,6 +2,7 @@ ( Compression (..) , RemoteDarcs (..) + , remoteDarcs , Reorder (..) , Verbosity (..) , UpdateWorking (..) @@ -27,10 +28,14 @@ , WithPatchIndex (..) , WithWorkingDir (..) , ForgetParent (..) + , PatchFormat (..) + , IncludeBoring (..) ) where import Darcs.Util.Diff ( DiffAlgorithm(..) ) +import Darcs.Util.Global ( defaultRemoteDarcsCmd ) + data Verbosity = Quiet | NormalVerbosity | Verbose deriving ( Eq, Show ) @@ -45,6 +50,10 @@ | DefaultRemoteDarcs deriving ( Eq, Show ) +remoteDarcs :: RemoteDarcs -> String +remoteDarcs DefaultRemoteDarcs = defaultRemoteDarcsCmd +remoteDarcs (RemoteDarcs x) = x + data Reorder = NoReorder | Reorder deriving ( Eq ) @@ -69,6 +78,9 @@ data LookForMoves = YesLookForMoves | NoLookForMoves deriving ( Eq, Show ) +data IncludeBoring = YesIncludeBoring | NoIncludeBoring + deriving ( Eq, Show ) + data RunTest = YesRunTest | NoRunTest deriving ( Eq, Show ) @@ -89,6 +101,7 @@ data ScanKnown = ScanKnown -- ^Just files already known to darcs | ScanAll -- ^All files, i.e. look for new ones | ScanBoring -- ^All files, even boring ones + deriving ( Eq, Show ) -- Various kinds of getting repositories data CloneKind = LazyClone -- ^Just copy pristine and inventories @@ -112,4 +125,7 @@ deriving ( Eq, Show ) data ForgetParent = YesForgetParent | NoForgetParent + deriving ( Eq, Show ) + +data PatchFormat = PatchFormat1 | PatchFormat2 deriving ( Eq, Show ) diff --git a/src/Darcs/Repository/Format.hs b/src/Darcs/Repository/Format.hs --- a/src/Darcs/Repository/Format.hs +++ b/src/Darcs/Repository/Format.hs @@ -19,6 +19,9 @@ , removeFromFormat ) where +import Prelude () +import Darcs.Prelude + #include "impossible.h" import Control.Monad ( mplus, (<=<) ) @@ -27,13 +30,13 @@ import Data.List ( partition, intercalate, (\\) ) import Data.Maybe ( isJust, mapMaybe ) -import Darcs.Repository.External +import Darcs.Util.External ( fetchFilePS , Cachable( Cachable ) ) import Darcs.Util.Global ( darcsdir ) -import Darcs.Repository.Lock ( writeBinFile ) -import qualified Darcs.Repository.Flags as F ( WithWorkingDir (..) ) +import Darcs.Util.Lock ( writeBinFile ) +import qualified Darcs.Repository.Flags as F ( WithWorkingDir (..), PatchFormat (..) ) import Darcs.Util.SignalHandler ( catchNonSignal ) import Darcs.Util.Exception ( catchall, prettyException ) @@ -148,17 +151,18 @@ writeRepoFormat :: RepoFormat -> FilePath -> IO () writeRepoFormat rf loc = writeBinFile loc $ show rf --- | @createRepoFormat useFormat1 useNoWorkingDir@ create a repo format -createRepoFormat :: Bool -> F.WithWorkingDir -> RepoFormat -createRepoFormat useFormat1 wwd = RF $ (HashedInventory : flags2wd wwd) : flags2format +-- | Create a repo format. The first argument is whether to use the old (darcs-1) +-- format; the second says whether the repo has a working tree. +createRepoFormat :: F.PatchFormat -> F.WithWorkingDir -> RepoFormat +createRepoFormat fmt wwd = RF $ (HashedInventory : flags2wd wwd) : flags2format fmt where - flags2format = if useFormat1 then [] else [[Darcs2]] - flags2wd F.NoWorkingDir = [NoWorkingDir] - flags2wd _ = [] + flags2format F.PatchFormat1 = [] + flags2format F.PatchFormat2 = [[Darcs2]] + flags2wd F.NoWorkingDir = [NoWorkingDir] + flags2wd F.WithWorkingDir = [] --- | @writeProblem form@ tells if we can write to a repo in format @form@, --- first checking if we can read that repo It returns @Nothing@ if there's no --- problem writing to such a repository. +-- | @'writeProblem' source@ returns 'Just' an error message if we cannot write +-- to a repo in format @source@, or 'Nothing' if there's no such problem. writeProblem :: RepoFormat -> Maybe String writeProblem target = readProblem target `mplus` findProblems target wp where diff --git a/src/Darcs/Repository/HashedIO.hs b/src/Darcs/Repository/HashedIO.hs --- a/src/Darcs/Repository/HashedIO.hs +++ b/src/Darcs/Repository/HashedIO.hs @@ -25,21 +25,23 @@ , pathsAndContents ) where +import Prelude () +import Darcs.Prelude + import Darcs.Util.Global ( darcsdir ) import qualified Data.Set as Set import System.Directory ( getDirectoryContents, createDirectoryIfMissing ) import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift, evalStateT ) import Control.Monad ( when, void, unless ) -import Control.Applicative ( (<$>) ) import Data.Maybe ( isJust ) import System.IO.Unsafe ( unsafeInterleaveIO ) import Darcs.Repository.Cache ( Cache(..), fetchFileUsingCache, writeFileUsingCache, peekInCache, speculateFileUsingCache, okayHash, cleanCachesWithHint, HashedDir(..), hashedDir ) -import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) +import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) ) import Darcs.Repository.Flags ( Compression( .. ), WithWorkingDir (..) ) -import Darcs.Repository.Lock ( writeAtomicFilePS, removeFileMayNotExist ) +import Darcs.Util.Lock ( writeAtomicFilePS, removeFileMayNotExist ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Progress ( debugMessage, tediousSize, finishedOneIO ) import Darcs.Util.Path @@ -61,9 +63,9 @@ import qualified Data.ByteString as B (ByteString, length, empty) import qualified Data.ByteString.Char8 as BC (unpack, pack) -import Storage.Hashed.Darcs( readDarcsHashedDir, darcsLocation, +import Darcs.Util.Tree.Hashed( readDarcsHashedDir, darcsLocation, decodeDarcsHash, decodeDarcsSize ) -import Storage.Hashed.Tree( ItemType(..), Tree ) +import Darcs.Util.Tree( ItemType(..), Tree ) -- | @readHashFile c subdir hash@ reads the file with hash @hash@ in dir subdir, -- fetching it from 'Cache' @c@ if needed. @@ -119,8 +121,10 @@ Just h -> inh h $ mInCurrentDirectory fn'' j where fn' = normPath fn -instance ApplyMonad (HashedIO p) Tree where +instance ApplyMonad Tree (HashedIO p) where type ApplyMonadBase (HashedIO p) = IO + +instance ApplyMonadTree (HashedIO p) where mDoesDirectoryExist fn = do thing <- identifyThing fn case thing of Just (D,_) -> return True _ -> return False diff --git a/src/Darcs/Repository/HashedRepo.hs b/src/Darcs/Repository/HashedRepo.hs --- a/src/Darcs/Repository/HashedRepo.hs +++ b/src/Darcs/Repository/HashedRepo.hs @@ -41,7 +41,6 @@ , readHashedPristineRoot , pris2inv , inv2pris - , copySources , listInventories , listInventoriesLocal , listInventoriesRepoDir @@ -55,9 +54,9 @@ #include "impossible.h" -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude -import Control.Applicative ( (<$>) ) import Control.Arrow ( (&&&) ) import Control.Exception ( catch, IOException ) import Control.Monad ( unless ) @@ -66,13 +65,12 @@ ByteString, splitAt ) import qualified Data.ByteString.Char8 as BC ( unpack, dropWhile, break, pack, ByteString ) -import Data.List ( delete ) import qualified Data.Set as Set -import Storage.Hashed.Darcs( hashedTreeIO, readDarcsHashedNosize, +import Darcs.Util.Hash( encodeBase16, Hash(..) ) +import Darcs.Util.Tree( treeHash, Tree ) +import Darcs.Util.Tree.Hashed( hashedTreeIO, readDarcsHashedNosize, readDarcsHashed, writeDarcsHashed, decodeDarcsHash, decodeDarcsSize ) -import Storage.Hashed.Tree( treeHash, Tree ) -import Storage.Hashed.Hash( encodeBase16, Hash(..) ) import System.Directory ( createDirectoryIfMissing, getDirectoryContents , doesFileExist, doesDirectoryExist ) import System.FilePath.Posix( () ) @@ -80,16 +78,16 @@ import System.IO ( stderr, hPutStrLn ) import Darcs.Util.Printer.Color ( showDoc ) -import Darcs.Repository.External +import Darcs.Util.External ( copyFileOrUrl , cloneFile , fetchFilePS , gzFetchFilePS , Cachable( Uncachable ) ) -import Darcs.Repository.Flags ( Compression, RemoteDarcs, WithWorkingDir ) +import Darcs.Repository.Flags ( Compression, RemoteDarcs, remoteDarcs, WithWorkingDir ) import Darcs.Util.Global ( darcsdir ) -import Darcs.Repository.Lock +import Darcs.Util.Lock ( writeBinFile , writeDocBinFile , writeAtomicFilePS @@ -101,27 +99,24 @@ import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, patchInfoAndPatch, info, extractHash, createHashed ) -import Darcs.Patch ( RepoPatch, Patchy, showPatch, readPatch, apply ) +import Darcs.Patch ( IsRepoType, RepoPatch, Patchy, showPatch, readPatch, apply ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.ReadMonads ( parseStrictly ) -import Darcs.Patch.Depends ( commuteToEnd, slightlyOptimizePatchset ) +import Darcs.Patch.Depends ( removeFromPatchSet, slightlyOptimizePatchset ) import Darcs.Patch.Info ( PatchInfo, showPatchInfo, showPatchInfoUI, readPatchInfo ) import Darcs.Util.Path ( FilePathLike, ioAbsoluteOrRemote, toPath ) -import Darcs.Repository.Cache ( Cache(..), CacheLoc(..), fetchFileUsingCache, +import Darcs.Repository.Cache ( Cache(..), fetchFileUsingCache, speculateFilesUsingCache, writeFileUsingCache, - unionCaches, repo2cache, okayHash, takeHash, + okayHash, takeHash, HashedDir(..), hashedDir, peekInCache, bucketFolder ) -import qualified Darcs.Repository.Cache as DarcsCache import Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed, cleanHashdir ) -import Darcs.Repository.InternalTypes ( Repository(..), extractCache, - modifyCache ) +import Darcs.Repository.InternalTypes ( Repository(..), extractCache ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Patch.Witnesses.Ordered - ( reverseRL, reverseFL, (+<+), FL(..), RL(..), - (:>)(..), mapRL, mapFL ) + ( (+<+), FL(..), RL(..), mapRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) @@ -224,8 +219,8 @@ -- then writes out the new tentative inventory, and finally does the atomic -- swap. In general, we can't clean the pristine cache at the same time, since -- a simultaneous get might be in progress. -finalizeTentativeChanges :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> Compression -> IO () +finalizeTentativeChanges :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> Compression -> IO () finalizeTentativeChanges r compr = do debugMessage "Optimizing the inventory..." -- Read the tentative patches @@ -240,7 +235,7 @@ -- |readHashedPristineRoot attempts to read the pristine hash from the current -- inventory, returning Nothing if it cannot do so. -readHashedPristineRoot :: Repository p wR wU wT -> IO (Maybe String) +readHashedPristineRoot :: Repository rt p wR wU wT -> IO (Maybe String) readHashedPristineRoot (Repo d _ _ _) = withCurrentDirectory d $ do i <- (Just <$> gzReadFilePS hashedInventoryPath) `catch` (\(_ :: IOException) -> return Nothing) @@ -248,7 +243,7 @@ -- |cleanPristine removes any obsolete (unreferenced) entries in the pristine -- cache. -cleanPristine :: Repository p wR wU wT -> IO () +cleanPristine :: Repository rt p wR wU wT -> IO () cleanPristine r@(Repo d _ _ _) = withCurrentDirectory d $ do debugMessage "Cleaning out the pristine cache..." i <- gzReadFilePS hashedInventoryPath @@ -278,7 +273,7 @@ -- |cleanInventories removes any obsolete (unreferenced) files in the -- inventories directory. -cleanInventories :: Repository p wR wU wT -> IO () +cleanInventories :: Repository rt p wR wU wT -> IO () cleanInventories _ = do debugMessage "Cleaning out inventories..." hs <- listInventoriesLocal @@ -293,7 +288,7 @@ -- |cleanPatches removes any obsolete (unreferenced) files in the -- patches directory. -cleanPatches :: Repository p wR wU wT -> IO () +cleanPatches :: Repository rt p wR wU wT -> IO () cleanPatches _ = do debugMessage "Cleaning out patches..." hs <- listPatchesLocal darcsdir @@ -305,7 +300,7 @@ -- |addToSpecificInventory adds a patch to a specific inventory file, and -- returns the FilePath whichs corresponds to the written-out patch. addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression - -> PatchInfoAnd p wX wY -> IO FilePath + -> PatchInfoAnd rt p wX wY -> IO FilePath addToSpecificInventory invPath c compr p = do let invFile = darcsdir invPath hash <- snd <$> writePatchIfNecessary c compr p @@ -314,44 +309,28 @@ return $ darcsdir "patches" hash addToTentativeInventory :: RepoPatch p => Cache -> Compression - -> PatchInfoAnd p wX wY -> IO FilePath + -> PatchInfoAnd rt p wX wY -> IO FilePath addToTentativeInventory = addToSpecificInventory tentativeHashedInventory --- |removeFromTentativeInventory attempts to remove an FL of patches from the --- tentative inventory. This is used for commands that wish to modify --- already-recorded patches. -removeFromTentativeInventory :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> Compression - -> FL (PatchInfoAnd p) wX wT -> IO () +-- | Attempt to remove an FL of patches from the tentative inventory. +-- This is used for commands that wish to modify already-recorded patches. +-- +-- Precondition: it must be possible to remove the patches, i.e. +-- +-- * the patches are in the repository +-- +-- * any necessary commutations will succeed +removeFromTentativeInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> Compression + -> FL (PatchInfoAnd rt p) wX wT -> IO () removeFromTentativeInventory repo compr to_remove = do - -- FIXME: This algorithm should be *far* simpler. All we need do is to to - -- remove the patches from a patchset and then write that patchset. The - -- commutation behavior of PatchInfoAnd should track which patches need to - -- be rewritten for us. + debugMessage $ "Start removeFromTentativeInventory" allpatches <- readTentativeRepo repo "." - _ :> skipped <- return $ commuteToEnd (reverseFL to_remove) allpatches - okay <- simpleRemoveFromTentativeInventory $ - mapFL info to_remove ++ mapRL info skipped - unless okay $ bug "bug in HashedRepo.removeFromTentativeInventory" - sequence_ $ mapFL (addToTentativeInventory (extractCache repo) compr) - (reverseRL skipped) - where - simpleRemoveFromTentativeInventory :: [PatchInfo] -> IO Bool - simpleRemoveFromTentativeInventory pis = do - inv <- readTentativeRepo repo "." - case cut_inv pis inv of - Nothing -> return False - Just (Sealed inv') -> do - writeTentativeInventory (extractCache repo) compr inv' - return True - cut_inv :: [PatchInfo] -> PatchSet p wStart wX - -> Maybe (SealedPatchSet p wStart) - cut_inv [] x = Just $ seal x - cut_inv x (PatchSet NilRL (Tagged t _ ps :<: ts)) = - cut_inv x (PatchSet (t :<: ps) ts) - cut_inv xs (PatchSet (hp:<:r) ts) | info hp `elem` xs = - cut_inv (info hp `delete` xs) (PatchSet r ts) - cut_inv _ _ = Nothing + remaining <- case removeFromPatchSet to_remove allpatches of + Nothing -> bug "HashedRepo.removeFromTentativeInventory: precondition violated" + Just r -> return r + writeTentativeInventory (extractCache repo) compr remaining + debugMessage $ "Done removeFromTentativeInventory" -- |writeHashFile takes a Doc and writes it as a hash-named file, returning the -- filename that the contents were written to. @@ -361,21 +340,21 @@ writeFileUsingCache c compr subdir $ renderPS Standard d -- |readRepo returns the "current" repo patchset. -readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT - -> String -> IO (PatchSet p Origin wR) +readRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT + -> String -> IO (PatchSet rt p Origin wR) readRepo = readRepoUsingSpecificInventory hashedInventory -- |readRepo returns the tentative repo patchset. -readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> String - -> IO (PatchSet p Origin wT) +readTentativeRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> String + -> IO (PatchSet rt p Origin wT) readTentativeRepo = readRepoUsingSpecificInventory tentativeHashedInventory -- |readRepoUsingSpecificInventory uses the inventory at @invPath@ to read the -- repository @repo@. -readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree) - => String -> Repository p wR wU wT - -> String -> IO (PatchSet p Origin wS) +readRepoUsingSpecificInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => String -> Repository rt p wR wU wT + -> String -> IO (PatchSet rt p Origin wS) readRepoUsingSpecificInventory invPath repo dir = do realdir <- toPath <$> ioAbsoluteOrRemote dir Sealed ps <- readRepoPrivate (extractCache repo) realdir invPath @@ -384,8 +363,8 @@ ioError e return $ unsafeCoerceP ps where - readRepoPrivate :: (RepoPatch p, ApplyState p ~ Tree) => Cache -> FilePath - -> FilePath -> IO (SealedPatchSet p Origin) + readRepoPrivate :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Cache -> FilePath + -> FilePath -> IO (SealedPatchSet rt p Origin) readRepoPrivate cache d iname = do inventory <- readInventoryPrivate (d darcsdir) iname readRepoFromInventoryList cache inventory @@ -393,35 +372,35 @@ -- |readRepoFromInventoryList allows the caller to provide an optional "from -- inventory" hash, and a list of info/hash pairs that identify a list of -- patches, returning a patchset of the resulting repo. -readRepoFromInventoryList :: (RepoPatch p, ApplyState p ~ Tree) => Cache +readRepoFromInventoryList :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Cache -> (Maybe String, [(PatchInfo, String)]) - -> IO (SealedPatchSet p Origin) + -> IO (SealedPatchSet rt p Origin) readRepoFromInventoryList cache = parseinvs where speculateAndParse h is i = speculate h is >> parse i h - read_patches :: (RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)] - -> IO (Sealed (RL (PatchInfoAnd p) wX)) + read_patches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)] + -> IO (Sealed (RL (PatchInfoAnd rt p) wX)) read_patches [] = return $ seal NilRL read_patches allis@((i1, h1) : is1) = - lift2Sealed (\p rest -> i1 `patchInfoAndPatch` p :<: rest) (rp is1) + lift2Sealed (\p rest -> rest :<: i1 `patchInfoAndPatch` p) (rp is1) (createHashed h1 (const $ speculateAndParse h1 allis i1)) where - rp :: (RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)] - -> IO (Sealed (RL (PatchInfoAnd p) wX)) + rp :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)] + -> IO (Sealed (RL (PatchInfoAnd rt p) wX)) rp [] = return $ seal NilRL rp [(i, h), (il, hl)] = - lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest) + lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p) (rp [(il, hl)]) (createHashed h (const $ speculateAndParse h (reverse allis) i)) rp ((i, h) : is) = - lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest) + lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p) (rp is) (createHashed h (parse i)) - read_tag :: (RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String) - -> IO (Sealed (PatchInfoAnd p wX)) + read_tag :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String) + -> IO (Sealed (PatchInfoAnd rt p wX)) read_tag (i, h) = mapSeal (patchInfoAndPatch i) <$> createHashed h (parse i) @@ -441,21 +420,21 @@ , "which is patch" , renderString Encode $ showPatchInfoUI i ] - parseinvs :: (RepoPatch p, ApplyState p ~ Tree) + parseinvs :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => (Maybe String, [(PatchInfo, String)]) - -> IO (SealedPatchSet p Origin) + -> IO (SealedPatchSet rt p Origin) parseinvs (Nothing, ris) = - mapSeal (flip PatchSet NilRL) <$> read_patches (reverse ris) + mapSeal (PatchSet NilRL) <$> read_patches (reverse ris) parseinvs (Just h, []) = bug $ "bad inventory " ++ h ++ " (no tag) in parseinvs!" parseinvs (Just h, t : ris) = do Sealed ts <- unseal seal <$> unsafeInterleaveIO (read_ts t h) Sealed ps <- unseal seal <$> unsafeInterleaveIO (read_patches $ reverse ris) - return $ seal $ PatchSet ps ts + return $ seal $ PatchSet ts ps - read_ts :: (RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String) - -> String -> IO (Sealed (RL (Tagged p) Origin)) + read_ts :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String) + -> String -> IO (Sealed (RL (Tagged rt p) Origin)) read_ts tag0 h0 = do contents <- unsafeInterleaveIO $ readTaggedInventoryFromHash h0 let is = reverse $ case contents of @@ -470,7 +449,7 @@ (Nothing, _) -> return $ seal NilRL) Sealed ps <- unseal seal <$> unsafeInterleaveIO (read_patches is) Sealed tag00 <- read_tag tag0 - return $ seal $ Tagged tag00 (Just h0) ps :<: ts + return $ seal $ ts :<: Tagged tag00 (Just h0) ps readTaggedInventoryFromHash :: String -> IO (Maybe String, [(PatchInfo, String)]) @@ -515,33 +494,18 @@ -- |copyRepo copies the hashed inventory of @repo@ to the repository located at -- @remote@. -copyHashedInventory :: RepoPatch p => Repository p wR wU wT -> RemoteDarcs -> String -> IO () -copyHashedInventory (Repo outr _ _ _) remote inr = do +copyHashedInventory :: RepoPatch p => Repository rt p wR wU wT -> RemoteDarcs -> String -> IO () +copyHashedInventory (Repo outr _ _ _) rdarcs inr | remote <- remoteDarcs rdarcs = do createDirectoryIfMissing False (outr ++ "/" ++ inventoriesDirPath) copyFileOrUrl remote (inr darcsdir hashedInventory) (outr darcsdir hashedInventory) Uncachable -- no need to copy anything but hashed_inventory! debugMessage "Done copying hashed inventory." --- |'copySources' copies the prefs/sources file to the local repo, from the --- remote, having first filtered the local filesystem sources. -copySources :: RepoPatch p => Repository p wR wU wT -> String -> IO () -copySources repo@(Repo outr _ _ _) inr = do - let repoCache = extractCache $ modifyCache repo dropNonRepos - appendBinFile (outr ++ "/" ++ darcsdir ++ "/prefs/sources") - (show $ repo2cache inr `unionCaches` repoCache ) - debugMessage "Done copying and filtering pref/sources." - where - dropNonRepos (Ca cache) = Ca $ filter notRepo cache - notRepo xs = case xs of - Cache DarcsCache.Directory _ _ -> False - Cache _ DarcsCache.Writable _ -> False - _ -> True - -- |writeAndReadPatch makes a patch lazy, by writing it out to disk (thus -- forcing it), and then re-reads the patch lazily. -writeAndReadPatch :: RepoPatch p => Cache -> Compression - -> PatchInfoAnd p wX wY -> IO (PatchInfoAnd p wX wY) +writeAndReadPatch :: (IsRepoType rt, RepoPatch p) => Cache -> Compression + -> PatchInfoAnd rt p wX wY -> IO (PatchInfoAnd rt p wX wY) writeAndReadPatch c compr p = do (i, h) <- writePatchIfNecessary c compr p unsafeInterleaveIO $ readp h i @@ -560,7 +524,7 @@ -- | writeTentativeInventory writes @patchSet@ as the tentative inventory. writeTentativeInventory :: RepoPatch p => Cache -> Compression - -> PatchSet p Origin wX -> IO () + -> PatchSet rt p Origin wX -> IO () writeTentativeInventory cache compr patchSet = do debugMessage "in writeTentativeInventory..." createDirectoryIfMissing False inventoriesDirPath @@ -575,20 +539,20 @@ writeAtomicFilePS (darcsdir tentativeHashedInventory) content where tediousName = "Writing inventory" - writeInventoryPrivate :: RepoPatch p => PatchSet p Origin wX + writeInventoryPrivate :: RepoPatch p => PatchSet rt p Origin wX -> IO (Maybe String) writeInventoryPrivate (PatchSet NilRL NilRL) = return Nothing - writeInventoryPrivate (PatchSet ps NilRL) = do + writeInventoryPrivate (PatchSet NilRL ps) = do inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) ps let inventorylist = hcat (map pihash $ reverse inventory) hash <- writeHashFile cache compr HashedInventoriesDir inventorylist return $ Just hash writeInventoryPrivate - (PatchSet x xs@(Tagged t _ _ :<: _)) = do + (PatchSet xs@(_ :<: Tagged t _ _) x) = do resthash <- write_ts xs finishedOneIO tediousName $ fromMaybe "" resthash inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) - (x +<+ t :<: NilRL) + (NilRL :<: t +<+ x) let inventorylist = hcat (map pihash $ reverse inventory) inventorycontents = case resthash of @@ -600,18 +564,18 @@ where -- | write_ts writes out a tagged patchset. If it has already been -- written, we'll have the hash, so we can immediately return it. - write_ts :: RepoPatch p => RL (Tagged p) Origin wX + write_ts :: RepoPatch p => RL (Tagged rt p) Origin wX -> IO (Maybe String) - write_ts (Tagged _ (Just h) _ :<: _) = return (Just h) - write_ts (Tagged _ Nothing pps :<: tts) = - writeInventoryPrivate $ PatchSet pps tts + write_ts (_ :<: Tagged _ (Just h) _) = return (Just h) + write_ts (tts :<: Tagged _ Nothing pps) = + writeInventoryPrivate $ PatchSet tts pps write_ts NilRL = return Nothing -- |writeHashIfNecessary writes the patch and returns the resulting info/hash, -- if it has not already been written. If it has been written, we have the hash -- in the PatchInfoAnd, so we extract and return the info/hash. writePatchIfNecessary :: RepoPatch p => Cache -> Compression - -> PatchInfoAnd p wX wY -> IO (PatchInfo, String) + -> PatchInfoAnd rt p wX wY -> IO (PatchInfo, String) writePatchIfNecessary c compr hp = infohp `seq` case extractHash hp of Right h -> return (infohp, h) diff --git a/src/Darcs/Repository/Internal.hs b/src/Darcs/Repository/Internal.hs --- a/src/Darcs/Repository/Internal.hs +++ b/src/Darcs/Repository/Internal.hs @@ -49,7 +49,6 @@ , finalizeRepositoryChanges , unrevertUrl , applyToWorking - , patchSetToPatches , createPristineDirectoryTree , createPartialsPristineDirectoryTree , reorderInventory @@ -61,9 +60,12 @@ , applyToTentativePristine , makeNewPending , seekRepo + , repoPatchType + , repoXor ) where -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude import Darcs.Util.Printer ( putDocLn , (<+>) @@ -74,12 +76,12 @@ , ($$) ) import Darcs.Util.Printer.Color (fancyPrinters) - +import Darcs.Util.Crypt.SHA1 ( SHA1, sha1Xor, zero ) import Darcs.Repository.State ( readRecorded , readWorking , updateIndex ) -import Darcs.Repository.LowLevel +import Darcs.Repository.Pending ( readPending , readTentativePending , writeTentativePending @@ -115,13 +117,13 @@ , void ) -import Control.Applicative ( (<$>) ) import Control.Exception ( catch, IOException ) import qualified Data.ByteString as B ( readFile , isPrefixOf ) import qualified Data.ByteString.Char8 as BC (pack) +import Data.List( foldl' ) import Data.List.Ordered ( nubSort ) import Data.Maybe ( fromMaybe ) import Darcs.Patch ( Effect @@ -133,11 +135,12 @@ , commute , fromPrim , RepoPatch + , IsRepoType , Patchy , merge , listConflictedFiles , listTouchedFiles - , Named + , WrappedNamed , commuteRL , fromPrims , readPatch @@ -163,13 +166,14 @@ import Darcs.Patch.Bundle ( scanBundle , makeBundleN ) -import Darcs.Patch.Info ( isTag ) -import Darcs.Patch.MaybeInternal ( flIsInternal ) -import Darcs.Patch.Named ( patchcontents ) +import Darcs.Patch.Info ( isTag, makePatchname ) +import Darcs.Patch.Named.Wrapped ( namedIsInternal ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd , hopefully , info ) +import Darcs.Patch.Type ( PatchType(..) ) + import qualified Darcs.Repository.HashedRepo as HashedRepo ( revertTentativeChanges , finalizeTentativeChanges @@ -178,6 +182,7 @@ , copyPartialsPristine , applyToTentativePristine , addToTentativeInventory + , readRepo , readTentativeRepo , readRepoUsingSpecificInventory , cleanPristine @@ -186,6 +191,7 @@ ) import qualified Darcs.Repository.Old as Old ( revertTentativeChanges + , readOldRepo , oldRepoFailMsg ) import Darcs.Repository.Flags @@ -223,7 +229,6 @@ ) import Darcs.Patch.Set ( PatchSet(..) , SealedPatchSet - , newset2FL , newset2RL , Origin ) @@ -252,7 +257,7 @@ , setExecutable ) import Darcs.Repository.Prefs ( getCaches ) -import Darcs.Repository.Lock +import Darcs.Util.Lock ( writeDocBinFile , removeFileMayNotExist ) @@ -263,19 +268,19 @@ import System.Mem( performGC ) -import qualified Storage.Hashed.Tree as Tree -import Storage.Hashed.Tree ( Tree ) +import Darcs.Util.Tree ( Tree ) +import qualified Darcs.Util.Tree as Tree import Darcs.Repository.PatchIndex ( createOrUpdatePatchIndexDisk, doesPatchIndexExist ) -import Darcs.Repository.Read ( readRepo ) #include "impossible.h" -- | The status of a given directory: is it a darcs repository? -data IdentifyRepo p wR wU wT = BadRepository String -- ^ looks like a repository with some error - | NonRepository String -- ^ safest guess - | GoodRepository (Repository p wR wU wT) +data IdentifyRepo rt p wR wU wT + = BadRepository String -- ^ looks like a repository with some error + | NonRepository String -- ^ safest guess + | GoodRepository (Repository rt p wR wU wT) -- | Tries to identify the repository in a given directory -maybeIdentifyRepository :: UseCache -> String -> IO (IdentifyRepo p wR wU wT) +maybeIdentifyRepository :: UseCache -> String -> IO (IdentifyRepo rt p wR wU wT) maybeIdentifyRepository useCache "." = do darcs <- doesDirectoryExist darcsdir if not darcs @@ -314,8 +319,8 @@ -- | identifyRepository identifies the repo at 'url'. Warning: -- you have to know what kind of patches are found in that repo. -identifyRepository :: forall p wR wU wT. UseCache -> String - -> IO (Repository p wR wU wT) +identifyRepository :: forall rt p wR wU wT. UseCache -> String + -> IO (Repository rt p wR wU wT) identifyRepository useCache url = do er <- maybeIdentifyRepository useCache url case er of @@ -325,11 +330,11 @@ -- | @identifyRepositoryFor repo url@ identifies (and returns) the repo at 'url', -- but fails if it is not compatible for reading from and writing to. -identifyRepositoryFor :: forall p wR wU wT vR vU vT. RepoPatch p - => Repository p wR wU wT +identifyRepositoryFor :: forall rt p wR wU wT vR vU vT. RepoPatch p + => Repository rt p wR wU wT -> UseCache -> String - -> IO (Repository p vR vU vT) + -> IO (Repository rt p vR vU vT) identifyRepositoryFor (Repo _ source _ _) useCache url = do Repo absurl target x c <- identifyRepository useCache url case transferProblem target source of @@ -357,6 +362,9 @@ _ -> return (Left Old.oldRepoFailMsg) left -> return left +repoPatchType :: Repository rt p wR wU wT -> PatchType rt p +repoPatchType _ = PatchType + -- | 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. $ @@ -409,7 +417,7 @@ -- TODO: see also Repository.State.readPendingLL ... to be removed after GHC 7.2 readNewPendingLL :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> IO (Sealed ((FL p) wT)) + => Repository rt p wR wU wT -> IO (Sealed ((FL p) wT)) readNewPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` readNewPending repo @@ -417,8 +425,8 @@ -- @pendPs@ could be applied to pristine if we wanted to, and if so -- writes it to disk. If it can't be applied, @pendPs@ must -- be somehow buggy, so we save it for forensics and crash. -makeNewPending :: forall p wR wU wT wY. (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT +makeNewPending :: forall rt p wR wU wT wY. (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> UpdateWorking -> FL (PrimOf p) wT wY -> IO () @@ -470,37 +478,37 @@ -- we can nuke the hunk, but not so in (hunk :> replace) sift :: FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC) sift sofar NilRL = seal sofar - sift sofar (p:<:ps) | primIsHunk p || primIsBinary p = + sift sofar (ps:<:p) | primIsHunk p || primIsBinary p = case commuteFLorComplain (p :> sofar) of Right (sofar' :> _) -> sift sofar' ps Left _ -> sift (p:>:sofar) ps - sift sofar (p:<:ps) = sift (p:>:sofar) ps + sift sofar (ps:<:p) = sift (p:>:sofar) ps -readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT - -> IO (PatchSet p Origin wT) +readTentativeRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> IO (PatchSet rt p Origin wT) readTentativeRepo repo@(Repo r rf _ _) | formatHas HashedInventory rf = HashedRepo.readTentativeRepo repo r | otherwise = fail Old.oldRepoFailMsg -readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree) +readRepoUsingSpecificInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => String - -> Repository p wR wU wT - -> IO (PatchSet p Origin wT) + -> Repository rt p wR wU wT + -> IO (PatchSet rt p Origin wT) readRepoUsingSpecificInventory invPath repo@(Repo r rf _ _) | formatHas HashedInventory rf = HashedRepo.readRepoUsingSpecificInventory invPath repo r | otherwise = fail Old.oldRepoFailMsg -prefsUrl :: Repository p wR wU wT -> String +prefsUrl :: Repository rt p wR wU wT -> String prefsUrl (Repo r _ _ _) = r ++ "/"++darcsdir++"/prefs" -unrevertUrl :: Repository p wR wU wT -> String +unrevertUrl :: Repository rt p wR wU wT -> String unrevertUrl (Repo r _ _ _) = r ++ "/"++darcsdir++"/patches/unrevert" applyToWorking :: (ApplyState (PrimOf p) ~ Tree, RepoPatch p) - => Repository p wR wU wT -> Verbosity -> FL (PrimOf p) wU wY - -> IO (Repository p wR wY wT) + => Repository rt p wR wU wT -> Verbosity -> FL (PrimOf p) wU wY + -> IO (Repository rt p wR wY wT) applyToWorking (Repo r rf t c) verb patch = do unless (formatHas NoWorkingDir rf) $ @@ -515,10 +523,10 @@ -- somewhere else. -- -- Question (Eric Kow): how do we detect patch equivalence? -tentativelyRemoveFromPending :: forall p wR wU wT wX wY. (RepoPatch p) - => Repository p wR wU wT +tentativelyRemoveFromPending :: forall rt p wR wU wT wX wY. (RepoPatch p) + => Repository rt p wR wU wT -> UpdateWorking - -> PatchInfoAnd p wX wY + -> PatchInfoAnd rt p wX wY -> IO () tentativelyRemoveFromPending _ NoUpdateWorking _ = return () tentativelyRemoveFromPending repo YesUpdateWorking p = do @@ -527,7 +535,7 @@ -- changepref patches in p? isSimple includes changepref, so what do -- adddir/etc have to do with it? Why don't we we systematically -- crudeSift/not? - let effectp = if allFL isSimple pend + let effectp = if isSimple pend then crudeSift $ effect p else effect p Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp) @@ -556,19 +564,38 @@ -- DJR: I don't think this last case should be -- reached, but it also shouldn't lead to corruption. -isSimple :: PrimPatch prim => prim wX wY -> Bool -isSimple x = primIsHunk x || primIsBinary x || primIsSetpref x - --- This seems to do the opposite of sifting, ie. we retain hunk/binary patches --- but delete changepref patches. +-- | A sequence of primitive patches (candidates for the pending patch) +-- is considered simple if we can reason about their continued status as +-- pending patches solely on the basis of them being hunk/binary patches. -- --- Why not just filterOutFLFL (not . primIsSetpref)? Is it important to only --- have this behaviour when all other patches are either hunk or binary? +-- Simple here seems to mean that all patches are either hunk/binary +-- patches, or patches that cannot (indirectly) depend on hunk/binary +-- patches. For now, the only other kinds of patches in this category +-- are changepref patches. +-- +-- It might be tempting to add, say, adddir patches but it's probably not a +-- good idea because Darcs also inverts patches a lot in its reasoning so an +-- innocent addir may be inverted to a rmdir which in turn may depend on +-- a rmfile, which in turn depends on a hunk/binary. Likewise, we would +-- not want to add move patches to this category for similar reasons of +-- a potential dependency chain forming. +isSimple :: PrimPatch prim => FL prim wX wY -> Bool +isSimple = + allFL isSimp + where + isSimp x = primIsHunk x || primIsBinary x || primIsSetpref x + +-- | 'crudeSift' can be seen as a first pass approximation of 'siftForPending' +-- that works without having to do any commutation. It either returns a +-- sifted pending (if the input is simple enough for this crude approach) +-- or has no effect. crudeSift :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> FL prim wX wY -crudeSift xs = if allFL isSimple xs then filterOutFLFL ishunkbinary xs else xs - where ishunkbinary :: prim wA wB -> EqCheck wA wB - ishunkbinary x | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq - | otherwise = NotEq +crudeSift xs = + if isSimple xs then filterOutFLFL ishunkbinary xs else xs + where + ishunkbinary :: prim wA wB -> EqCheck wA wB + ishunkbinary x | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq + | otherwise = NotEq data HashedVsOld a = HvsO { old, hashed :: a } @@ -602,16 +629,16 @@ " "++cmd++" mark-conflicts\n"++ "to "++darcsdir++"/prefs/defaults in the target repo. " -checkUnrecordedConflicts :: forall p wT wY. RepoPatch p +checkUnrecordedConflicts :: forall rt p wT wY. RepoPatch p => UpdateWorking - -> FL (Named p) wT wY + -> FL (WrappedNamed rt p) wT wY -> IO Bool checkUnrecordedConflicts NoUpdateWorking _ = return False -- because we are called by `darcs convert` hence we don't care checkUnrecordedConflicts _ pc = do repository <- identifyRepository NoUseCache "." cuc repository - where cuc :: Repository p wR wU wT -> IO Bool + where cuc :: Repository rt p wR wU wT -> IO Bool cuc r = do Sealed (mpend :: FL (PrimOf p) wT wX) <- readPending r :: IO (Sealed (FL (PrimOf p) wT)) case mpend of NilFL -> return False @@ -631,12 +658,12 @@ fromPrims_ = fromPrims tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT + => Repository rt p wR wU wT -> Compression -> Verbosity -> UpdateWorking - -> PatchInfoAnd p wT wY - -> IO (Repository p wR wU wY) + -> PatchInfoAnd rt p wT wY + -> IO (Repository rt p wR wU wY) tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine data UpdatePristine = UpdatePristine @@ -644,15 +671,15 @@ | DontUpdatePristineNorRevert deriving Eq tentativelyAddPatches_ - :: forall p wR wU wT wY + :: forall rt p wR wU wT wY . (RepoPatch p, ApplyState p ~ Tree) => UpdatePristine - -> Repository p wR wU wT + -> Repository rt p wR wU wT -> Compression -> Verbosity -> UpdateWorking - -> FL (PatchInfoAnd p) wT wY - -> IO (Repository p wR wU wY) + -> FL (PatchInfoAnd rt p) wT wY + -> IO (Repository rt p wR wU wY) tentativelyAddPatches_ _up r _compr _verb _uw NilFL = return r tentativelyAddPatches_ up r compr verb uw (p:>:ps) = do r' <- tentativelyAddPatch_ up r compr verb uw p @@ -660,15 +687,15 @@ -- TODO re-add a safety catch for --dry-run? Maybe using a global, like dryRun -- :: Bool, with dryRun = unsafePerformIO $ readIORef ... -tentativelyAddPatch_ :: forall p wR wU wT wY +tentativelyAddPatch_ :: forall rt p wR wU wT wY . (RepoPatch p, ApplyState p ~ Tree) => UpdatePristine - -> Repository p wR wU wT + -> Repository rt p wR wU wT -> Compression -> Verbosity -> UpdateWorking - -> PatchInfoAnd p wT wY - -> IO (Repository p wR wU wY) + -> PatchInfoAnd rt p wT wY + -> IO (Repository rt p wR wU wY) tentativelyAddPatch_ up r@(Repo dir rf t c) compr verb uw p = withCurrentDirectory dir $ do @@ -682,7 +709,7 @@ return (Repo dir rf t c) applyToTentativePristine :: (ApplyState q ~ Tree, Effect q, Patchy q, ShowPatch q, PrimPatchBase q) - => Repository p wR wU wT + => Repository rt p wR wU wT -> Verbosity -> q wT wY -> IO () @@ -700,8 +727,8 @@ -- This fuction is unsafe because it accepts a patch that works on the -- tentative pending and we don't currently track the state of the -- tentative pending. -tentativelyAddToPending :: forall p wR wU wT wX wY. RepoPatch p - => Repository p wR wU wT +tentativelyAddToPending :: forall rt p wR wU wT wX wY. RepoPatch p + => Repository rt p wR wU wT -> UpdateWorking -> FL (PrimOf p) wX wY -> IO () @@ -719,8 +746,8 @@ -- | setTentativePending is basically unsafe. It overwrites the pending -- state with a new one, not related to the repository state. -setTentativePending :: forall p wR wU wT wX wY. RepoPatch p - => Repository p wR wU wT +setTentativePending :: forall rt p wR wU wT wX wY. RepoPatch p + => Repository rt p wR wU wT -> UpdateWorking -> FL (PrimOf p) wX wY -> IO () @@ -735,8 +762,8 @@ -- -- This function is basically unsafe. It overwrites the pending state -- with a new one, not related to the repository state. -prepend :: forall p wR wU wT wX wY. RepoPatch p - => Repository p wR wU wT +prepend :: forall rt p wR wU wT wX wY. RepoPatch p + => Repository rt p wR wU wT -> UpdateWorking -> FL (PrimOf p) wX wY -> IO () @@ -750,21 +777,22 @@ newpend NilFL patch_ = seal patch_ newpend p patch_ = seal $ patch_ +>+ p -tentativelyRemovePatches :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT +tentativelyRemovePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> Compression -> UpdateWorking - -> FL (PatchInfoAnd p) wX wT - -> IO (Repository p wR wU wX) + -> FL (PatchInfoAnd rt p) wX wT + -> IO (Repository rt p wR wU wX) tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine -tentativelyRemovePatches_ :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree) +tentativelyRemovePatches_ :: forall rt p wR wU wT wX + . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => UpdatePristine - -> Repository p wR wU wT + -> Repository rt p wR wU wT -> Compression -> UpdateWorking - -> FL (PatchInfoAnd p) wX wT - -> IO (Repository p wR wU wX) + -> FL (PatchInfoAnd rt p) wX wT + -> IO (Repository rt p wR wU wX) tentativelyRemovePatches_ up repository@(Repo dir rf t c) compr uw ps = withCurrentDirectory dir $ do when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..." @@ -789,19 +817,20 @@ -- with the same name and then adding the passed in sequence. -- Typically callers will have obtained the passed in sequence using -- 'findCommon' and friends. -tentativelyReplacePatches :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT +tentativelyReplacePatches :: forall rt p wR wU wT wX + . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> Compression -> UpdateWorking -> Verbosity - -> FL (PatchInfoAnd p) wX wT + -> FL (PatchInfoAnd rt p) wX wT -> IO () tentativelyReplacePatches repository compr uw verb ps = - do let ps' = filterOutFLFL (flIsInternal . patchcontents . hopefully) ps + do let ps' = filterOutFLFL (namedIsInternal . hopefully) ps repository' <- tentativelyRemovePatches_ DontUpdatePristineNorRevert repository compr uw ps' mapAdd repository' ps' - where mapAdd :: Repository p wM wL wI - -> FL (PatchInfoAnd p) wI wJ + where mapAdd :: Repository rt p wM wL wI + -> FL (PatchInfoAnd rt p) wI wJ -> IO () mapAdd _ NilFL = return () mapAdd r (a:>:as) = @@ -817,7 +846,7 @@ -- inconsistency of the @NoUpdateWorking@ doing deletion, but -- @YesUpdateWorking@ not bothering. finalizePending :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT + => Repository rt p wR wU wT -> UpdateWorking -> IO () finalizePending (Repo dir _ _ _) NoUpdateWorking = @@ -828,8 +857,8 @@ Sealed new_pending <- return $ siftForPending tpend makeNewPending repository updateWorking new_pending -finalizeRepositoryChanges :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT +finalizeRepositoryChanges :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO () @@ -851,7 +880,7 @@ -- changes, revertRepositoryChanges also re-initialises the tentative state. -- It's therefore used before makign any changes to the repo. revertRepositoryChanges :: RepoPatch p - => Repository p wR wU wT + => Repository rt p wR wU wT -> UpdateWorking -> IO () revertRepositoryChanges r@(Repo dir rf _ _) uw = @@ -863,12 +892,10 @@ decideHashedOrNormal rf HvsO { hashed = HashedRepo.revertTentativeChanges, old = Old.revertTentativeChanges } -patchSetToPatches :: RepoPatch p => PatchSet p wX wY -> FL (Named p) wX wY -patchSetToPatches patchSet = mapFL_FL hopefully $ newset2FL patchSet - -removeFromUnrevertContext :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT - -> FL (PatchInfoAnd p) wX wT +removeFromUnrevertContext :: forall rt p wR wU wT wX + . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> FL (PatchInfoAnd rt p) wX wT -> IO () removeFromUnrevertContext repository ps = do Sealed bundle <- unrevert_patch_bundle `catchall` return (seal (PatchSet NilRL NilRL)) @@ -877,12 +904,12 @@ do confirmed <- promptYorn "This operation will make unrevert impossible!\nProceed?" if confirmed then removeFileMayNotExist (unrevertUrl repository) else fail "Cancelled." - unrevert_patch_bundle :: IO (SealedPatchSet p Origin) + unrevert_patch_bundle :: IO (SealedPatchSet rt p Origin) unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository) case scanBundle pf of Right foo -> return foo Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err - remove_from_unrevert_context_ :: PatchSet p Origin wZ -> IO () + remove_from_unrevert_context_ :: PatchSet rt p Origin wZ -> IO () remove_from_unrevert_context_ (PatchSet NilRL NilRL) = return () remove_from_unrevert_context_ bundle = do debugMessage "Adjusting the context of the unrevert changes..." @@ -905,7 +932,7 @@ writeDocBinFile (unrevertUrl repository) bundle' debugMessage "Done adjusting the context of the unrevert changes!" -cleanRepository :: RepoPatch p => Repository p wR wU wT -> IO () +cleanRepository :: RepoPatch p => Repository rt p wR wU wT -> IO () cleanRepository repository@(Repo _ rf _ _) = decideHashedOrNormal rf HvsO { hashed = cleanHashedRepo repository, @@ -919,7 +946,7 @@ -- | grab the pristine hash of _darcs/hash_inventory, and retrieve whole pristine tree, -- possibly writing a clean working copy in the process. -createPristineDirectoryTree :: RepoPatch p => Repository p wR wU wT -> FilePath -> WithWorkingDir -> IO () +createPristineDirectoryTree :: RepoPatch p => Repository rt p wR wU wT -> FilePath -> WithWorkingDir -> IO () createPristineDirectoryTree (Repo r rf _ c) reldir wwd | formatHas HashedInventory rf = do createDirectoryIfMissing True reldir @@ -929,7 +956,7 @@ -- fp below really should be FileName -- | Used by the commands dist and diff createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) - => Repository p wR wU wT + => Repository rt p wR wU wT -> [fp] -> FilePath -> IO () @@ -941,7 +968,7 @@ | otherwise = fail Old.oldRepoFailMsg withRecorded :: RepoPatch p - => Repository p wR wU wT + => Repository rt p wR wU wT -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a @@ -949,8 +976,8 @@ = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d) WithWorkingDir f d -withTentative :: forall p a wR wU wT. (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT +withTentative :: forall rt p a wR wU wT. (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a @@ -1006,8 +1033,8 @@ -- to a given tag are included in that tag, so less commutation and -- history traversal is needed. This latter issue can become very -- important in large repositories. -reorderInventory :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wR +reorderInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wR -> Compression -> UpdateWorking -> Verbosity @@ -1016,16 +1043,16 @@ decideHashedOrNormal rf HvsO { hashed = do debugMessage "Reordering the inventory." - PatchSet ps _ <- misplacedPatches `fmap` readRepo repository + PatchSet _ ps <- misplacedPatches `fmap` readRepo repository tentativelyReplacePatches repository compr uw verb $ reverseRL ps HashedRepo.finalizeTentativeChanges repository compr debugMessage "Done reordering the inventory.", old = fail Old.oldRepoFailMsg } -- | Returns the patches that make the most recent tag dirty. -misplacedPatches :: forall p wS wX . RepoPatch p - => PatchSet p wS wX - -> PatchSet p wS wX +misplacedPatches :: forall rt p wS wX . RepoPatch p + => PatchSet rt p wS wX + -> PatchSet rt p wS wX misplacedPatches ps = -- Filter the repository keeping only with the tags, ordered from the -- most recent. @@ -1036,7 +1063,30 @@ -- the clean PatchSet "up to" the tag (ts), and a RL of -- patches after the tag (r). case splitOnTag lt ps of - Just (PatchSet xs ts :> r) -> PatchSet (r+<+xs) ts + Just (PatchSet ts xs :> r) -> PatchSet ts (xs+<+r) _ -> impossible -- Because the tag is in ps. +-- @todo: we should not have to open the result of HashedRepo and +-- seal it. Instead, update this function to work with type witnesses +-- by fixing DarcsRepo to match HashedRepo in the handling of +-- Repository state. +readRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> IO (PatchSet rt p Origin wR) +readRepo repo@(Repo r rf _ _) + | formatHas HashedInventory rf = HashedRepo.readRepo repo r + | otherwise = do Sealed ps <- Old.readOldRepo r + return $ unsafeCoerceP ps +-- | XOR of all hashes of the patches' metadata. +-- It enables to quickly see whether two repositories +-- have the same patches, independently of their order. +-- It relies on the assumption that the same patch cannot +-- be present twice in a repository. +-- This checksum is not cryptographically secure, +-- see http://robotics.stanford.edu/~xb/crypto06b/ . +repoXor :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wR -> IO SHA1 +repoXor repo = do + hashes <- mapRL (makePatchname . info) . newset2RL <$> readRepo repo + return $ foldl' sha1Xor zero hashes diff --git a/src/Darcs/Repository/InternalTypes.hs b/src/Darcs/Repository/InternalTypes.hs --- a/src/Darcs/Repository/InternalTypes.hs +++ b/src/Darcs/Repository/InternalTypes.hs @@ -21,10 +21,13 @@ , extractCache, modifyCache ) where +import Prelude () +import Darcs.Prelude + import Data.List ( nub, sortBy ) import Darcs.Repository.Cache ( Cache (..) , compareByLocality ) import Darcs.Repository.Format ( RepoFormat ) -import Darcs.Patch ( RepoPatch ) +import Darcs.Patch ( RepoPatch, RepoType ) data Pristine = NoPristine @@ -38,15 +41,15 @@ -- the unrecorded state (what's in the working directory now), -- and the tentative state, which represents work in progress that will -- eventually become the new recorded state unless something goes wrong. -data Repository (p :: * -> * -> *) wRecordedstate wUnrecordedstate wTentativestate = +data Repository (rt :: RepoType) (p :: * -> * -> *) wRecordedstate wUnrecordedstate wTentativestate = Repo !String !RepoFormat !Pristine Cache deriving ( Show ) -extractCache :: Repository p wR wU wT -> Cache +extractCache :: Repository rt p wR wU wT -> Cache extractCache (Repo _ _ _ c) = c -- | 'modifyCache' @repository function@ modifies the cache of -- @repository@ with @function@, remove duplicates and sort the results with 'compareByLocality'. -modifyCache :: forall p wR wU wT . (RepoPatch p) => Repository p wR wU wT -> (Cache -> Cache) -> Repository p wR wU wT +modifyCache :: forall rt p wR wU wT . (RepoPatch p) => Repository rt p wR wU wT -> (Cache -> Cache) -> Repository rt p wR wU wT modifyCache (Repo dir rf pristine cache) f = Repo dir rf pristine $ cmap ( sortBy compareByLocality . nub ) $ f cache where cmap g (Ca c) = Ca (g c) diff --git a/src/Darcs/Repository/Job.hs b/src/Darcs/Repository/Job.hs --- a/src/Darcs/Repository/Job.hs +++ b/src/Darcs/Repository/Job.hs @@ -27,21 +27,25 @@ , withRepositoryDirectory ) where +import Prelude () +import Darcs.Prelude import Darcs.Util.Global ( darcsdir ) import Darcs.Patch.Apply ( ApplyState ) -import Darcs.Patch.V1 ( Patch ) -import Darcs.Patch.V2 ( RealPatch ) -import Darcs.Patch.Named ( Named ) +import Darcs.Patch.V1 ( RepoPatchV1 ) +import Darcs.Patch.V2 ( RepoPatchV2 ) import Darcs.Patch.Prim.V1 ( Prim ) import Darcs.Patch.Prim ( PrimOf ) -import Darcs.Patch.Rebase ( Rebasing ) import Darcs.Patch.RepoPatch ( RepoPatch ) +import Darcs.Patch.RepoType + ( RepoType(..), SRepoType(..), IsRepoType + , RebaseType(..), SRebaseType(..), IsRebaseType + ) import Darcs.Repository.Flags ( UseCache(..), UpdateWorking(..), DryRun(..), UMask (..) - , Compression, Verbosity ) + ) import Darcs.Repository.Format ( RepoProperty( Darcs2 , RebaseInProgress @@ -55,22 +59,24 @@ ) import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Repository.Rebase - ( repoJobOnRebaseRepo + ( RebaseJobFlags , startRebaseJob , rebaseJob ) -import Darcs.Repository.Lock ( withLock, withLockCanFail ) +import qualified Darcs.Repository.Rebase as Rebase ( maybeDisplaySuspendedStatus ) +import Darcs.Util.Lock ( withLock, withLockCanFail ) import Darcs.Util.Progress ( debugMessage ) import Control.Monad ( when ) -import Control.Exception ( bracket_ ) +import Control.Exception ( bracket_, finally ) +import Data.List ( intercalate ) import Foreign.C.String ( CString, withCString ) import Foreign.C.Error ( throwErrno ) import Foreign.C.Types ( CInt(..) ) -import Storage.Hashed.Tree ( Tree ) +import Darcs.Util.Tree ( Tree ) #include "impossible.h" @@ -108,44 +114,67 @@ = -- |The most common @RepoJob@; the underlying action can accept any patch type that -- a darcs repository may use. - RepoJob (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => Repository p wR wU wR -> IO a) + RepoJob (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => Repository rt p wR wU wR -> IO a) -- |A job that only works on darcs 1 patches - | V1Job (forall wR wU . Repository (Patch Prim) wR wU wR -> IO a) + | V1Job (forall wR wU . Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR -> IO a) -- |A job that only works on darcs 2 patches - | V2Job (forall wR wU . Repository (RealPatch Prim) wR wU wR -> IO a) + | V2Job (forall rt wR wU . Repository rt (RepoPatchV2 Prim) wR wU wR -> IO a) -- |A job that works on any repository where the patch type @p@ has 'PrimOf' @p@ = 'Prim'. -- -- This was added to support darcsden, which inspects the internals of V1 prim patches. -- -- In future this should be replaced with a more abstract inspection API as part of 'PrimPatch'. - | PrimV1Job (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, PrimOf p ~ Prim) - => Repository p wR wU wR -> IO a) + | PrimV1Job (forall rt p wR wU . (RepoPatch p, ApplyState p ~ Tree, PrimOf p ~ Prim) + => Repository rt p wR wU wR -> IO a) -- A job that works on normal darcs repositories, but will want access to the rebase patch if it exists. - | RebaseAwareJob Compression Verbosity UpdateWorking (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository p wR wU wR -> IO a) - | RebaseJob Compression Verbosity UpdateWorking (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository (Rebasing p) wR wU wR -> IO a) - | StartRebaseJob Compression Verbosity UpdateWorking (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository (Rebasing p) wR wU wR -> IO a) + | RebaseAwareJob RebaseJobFlags (forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository rt p wR wU wR -> IO a) + | RebaseJob RebaseJobFlags (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a) + | StartRebaseJob RebaseJobFlags (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO a) onRepoJob :: RepoJob a - -> (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => (Repository p wR wU wR -> IO a) -> Repository p wR wU wR -> IO a) + -> (forall rt p wR wU . (RepoPatch p, ApplyState p ~ Tree) => (Repository rt p wR wU wR -> IO a) -> Repository rt p wR wU wR -> IO a) -> RepoJob a onRepoJob (RepoJob job) f = RepoJob (f job) --- onRepoJob (TreeJob job) f = TreeJob (f job) onRepoJob (V1Job job) f = V1Job (f job) onRepoJob (V2Job job) f = V2Job (f job) onRepoJob (PrimV1Job job) f = PrimV1Job (f job) -onRepoJob (RebaseAwareJob compr verb uw job) f = RebaseAwareJob compr verb uw (f job) -onRepoJob (RebaseJob compr verb uw job) f = RebaseJob compr verb uw (f job) -onRepoJob (StartRebaseJob compr verb uw job) f = StartRebaseJob compr verb uw (f job) +onRepoJob (RebaseAwareJob flags job) f = RebaseAwareJob flags (f job) +onRepoJob (RebaseJob flags job) f = RebaseJob flags (f job) +onRepoJob (StartRebaseJob flags job) f = StartRebaseJob flags (f job) -- | apply a given RepoJob to a repository in the current working directory withRepository :: UseCache -> RepoJob a -> IO a withRepository useCache = withRepositoryDirectory useCache "." +-- | This is just an internal type to Darcs.Repository.Job for +-- calling runJob in a strongly-typed way +data RepoPatchType p where + RepoV1 :: RepoPatchType (RepoPatchV1 Prim) + RepoV2 :: RepoPatchType (RepoPatchV2 Prim) + +-- | This type allows us to check multiple patch types against the +-- constraints required by most repository jobs +data IsTree p where + IsTree :: (ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => IsTree p + +checkTree :: RepoPatchType p -> IsTree p +checkTree RepoV1 = IsTree +checkTree RepoV2 = IsTree + +-- | This type allows us to check multiple patch types against the +-- constraints required by 'PrimV1Job' +data UsesPrimV1 p where + UsesPrimV1 :: (ApplyState p ~ Tree, PrimOf p ~ Prim) => UsesPrimV1 p + +checkPrimV1 :: RepoPatchType p -> UsesPrimV1 p +checkPrimV1 RepoV1 = UsesPrimV1 +checkPrimV1 RepoV2 = UsesPrimV1 + -- | apply a given RepoJob to a repository in a given url withRepositoryDirectory :: UseCache -> String -> RepoJob a -> IO a withRepositoryDirectory useCache url repojob = do - Repo dir rf t c <- identifyRepository useCache url + repo@(Repo _ rf _ _) <- identifyRepository useCache url let startRebase = @@ -153,61 +182,103 @@ StartRebaseJob {} -> True _ -> False - case (formatHas Darcs2 rf, startRebase || formatHas RebaseInProgress rf) of + -- in order to pass SRepoType and RepoPatchType at different types, we need a polymorphic + -- function that we call in two different ways, rather than directly varying the argument. + runJob1 + :: IsRebaseType rebaseType + => SRebaseType rebaseType -> Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a + runJob1 isRebase = + if formatHas Darcs2 rf + then runJob RepoV2 (SRepoType isRebase) + else runJob RepoV1 (SRepoType isRebase) - (True, False) -> do - debugMessage $ "Identified darcs-2 repo: " ++ dir - let therepo = Repo dir rf t c :: Repository (RealPatch Prim) wR wU wR - case repojob of - RepoJob job -> job therepo - PrimV1Job job -> job therepo - -- TreeJob job -> job therepo - V2Job job -> job therepo - V1Job _ -> fail $ "This repository contains darcs v1 patches," - ++ " but the command requires darcs v2 patches." - RebaseAwareJob _compr _verb _uw job -> job therepo - RebaseJob {} -> fail "No rebase in progress. Try 'darcs rebase suspend' first." - StartRebaseJob {} -> impossible + runJob2 :: Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a + runJob2 = + if startRebase || formatHas RebaseInProgress rf + then runJob1 SIsRebase + else runJob1 SNoRebase - (False, False) -> do - debugMessage $ "Identified darcs-1 repo: " ++ dir - let therepo = Repo dir rf t c :: Repository (Patch Prim) wR wU wR - case repojob of - RepoJob job -> job therepo - PrimV1Job job -> job therepo - V1Job job -> job therepo - V2Job _ -> fail $ "This repository contains darcs v2 patches," - ++ " but the command requires darcs v1 patches." - RebaseAwareJob _compr _verb _uw job -> job therepo - RebaseJob {} -> fail "No rebase in progress. Try 'darcs rebase suspend' first." - StartRebaseJob {} -> impossible + runJob2 repo repojob - (True, True ) -> do - debugMessage $ "Identified darcs-2 rebase repo: " ++ dir - let therepo = Repo dir rf t c :: Repository (Rebasing (RealPatch Prim)) wR wU wR - case repojob of - RepoJob job -> repoJobOnRebaseRepo job therepo - PrimV1Job job -> repoJobOnRebaseRepo job therepo - -- TreeJob job -> job therepo - V2Job _ -> fail "This command is not supported while a rebase is in progress." - V1Job _ -> fail $ "This repository contains darcs v1 patches," - ++ " but the command requires darcs v2 patches." - RebaseAwareJob compr verb uw job -> rebaseJob job therepo compr verb uw - RebaseJob compr verb uw job -> rebaseJob job therepo compr verb uw - StartRebaseJob compr verb uw job -> startRebaseJob job therepo compr verb uw - (False, True ) -> do - debugMessage $ "Identified darcs-1 rebase repo: " ++ dir - let therepo = Repo dir rf t c :: Repository (Rebasing (Patch Prim)) wR wU wR - case repojob of - RepoJob job -> repoJobOnRebaseRepo job therepo - PrimV1Job job -> repoJobOnRebaseRepo job therepo - V1Job _ -> fail "This command is not supported while a rebase is in progress." - V2Job _ -> fail $ "This repository contains darcs v2 patches," - ++ " but the command requires darcs v1 patches." - RebaseAwareJob compr verb uw job -> rebaseJob job therepo compr verb uw - RebaseJob compr verb uw job -> rebaseJob job therepo compr verb uw - StartRebaseJob compr verb uw job -> startRebaseJob job therepo compr verb uw +runJob + :: forall rt p rtDummy pDummy wR wU a + . (IsRepoType rt, RepoPatch p) + => RepoPatchType p -> SRepoType rt -> Repository rtDummy pDummy wR wU wR -> RepoJob a -> IO a +runJob patchType (SRepoType isRebase) (Repo dir rf t c) repojob = do + + -- The actual type the repository should have is only known when + -- when this function is called, so we need to "cast" it to its proper type + let + therepo = Repo dir rf t c :: Repository rt p wR wU wR + + patchTypeString :: String + patchTypeString = + case patchType of + RepoV2 -> "darcs-2" + RepoV1 -> "darcs-1" + + repoAttributes :: [String] + repoAttributes = + case isRebase of + SIsRebase -> ["rebase"] + SNoRebase -> [] + + repoAttributesString :: String + repoAttributesString = + case repoAttributes of + [] -> "" + _ -> " " ++ intercalate "+" repoAttributes + + debugMessage $ "Identified " ++ patchTypeString ++ repoAttributesString ++ " repo: " ++ dir + + case repojob of + RepoJob job -> + case checkTree patchType of + IsTree -> + job therepo + `finally` + Rebase.maybeDisplaySuspendedStatus isRebase therepo + + PrimV1Job job -> + case checkPrimV1 patchType of + UsesPrimV1 -> do + job therepo + `finally` + Rebase.maybeDisplaySuspendedStatus isRebase therepo + + V2Job job -> + case (patchType, isRebase) of + (RepoV2, SNoRebase) -> job therepo + (RepoV1, _ ) -> + fail $ "This repository contains darcs v1 patches," + ++ " but the command requires darcs v2 patches." + (RepoV2, SIsRebase) -> + fail "This command is not supported while a rebase is in progress." + + V1Job job -> + case (patchType, isRebase) of + (RepoV1, SNoRebase) -> job therepo + (RepoV2, _ ) -> + fail $ "This repository contains darcs v2 patches," + ++ " but the command requires darcs v1 patches." + (RepoV1, SIsRebase) -> + fail "This command is not supported while a rebase is in progress." + + RebaseAwareJob flags job -> + case (checkTree patchType, isRebase) of + (IsTree, SNoRebase) -> job therepo + (IsTree, SIsRebase) -> rebaseJob job therepo flags + + RebaseJob flags job -> + case (checkTree patchType, isRebase) of + (_ , SNoRebase) -> fail "No rebase in progress. Try 'darcs rebase suspend' first." + (IsTree, SIsRebase) -> rebaseJob job therepo flags + + StartRebaseJob flags job -> + case (checkTree patchType, isRebase) of + (_ , SNoRebase) -> impossible + (IsTree, SIsRebase) -> startRebaseJob job therepo flags -- | apply a given RepoJob to a repository in the current working directory, -- taking a lock diff --git a/src/Darcs/Repository/Lock.hs b/src/Darcs/Repository/Lock.hs deleted file mode 100644 --- a/src/Darcs/Repository/Lock.hs +++ /dev/null @@ -1,382 +0,0 @@ --- Copyright (C) 2003 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 CPP #-} - -module Darcs.Repository.Lock - ( withLock - , withLockCanFail - , environmentHelpLocks - , withTemp - , withOpenTemp - , withStdoutTemp - , withTempDir - , withPermDir - , withDelayedDir - , withNamedTemp - , writeToFile - , appendToFile - , writeBinFile - , writeLocaleFile - , writeDocBinFile - , appendBinFile - , appendDocBinFile - , readBinFile - , readLocaleFile - , readDocBinFile - , writeAtomicFilePS - , gzWriteAtomicFilePS - , gzWriteAtomicFilePSs - , gzWriteDocFile - , rmRecursive - , removeFileMayNotExist - , canonFilename - , maybeRelink - , worldReadableTemp - , tempdirLoc - , environmentHelpTmpdir - , environmentHelpKeepTmpdir - , addToErrorLoc - ) where - -import Prelude hiding ( catch ) -import Data.List ( inits ) -import Data.Maybe ( isJust, listToMaybe ) -import System.Exit ( exitWith, ExitCode(..) ) -import System.IO ( withBinaryFile, openBinaryTempFile, - hClose, hPutStr, Handle, - IOMode(WriteMode, AppendMode), hFlush, stdout ) -import System.IO.Error - ( isAlreadyExistsError - , annotateIOError - ) -import Control.Exception - ( IOException - , bracket - , throwIO - , catch - , try - , SomeException - ) -import System.Directory ( removeFile, removeDirectory, - doesFileExist, doesDirectoryExist, - getDirectoryContents, createDirectory, - getTemporaryDirectory, - ) -import System.FilePath.Posix ( splitDirectories ) -import Control.Concurrent ( threadDelay ) -import Control.Monad ( unless, when, liftM ) - -import Darcs.Util.URL ( isRelative ) -import Darcs.Util.Environment ( maybeGetEnv ) -import Darcs.Util.Exception - ( firstJustIO - , catchall - ) -import Darcs.Util.File ( withCurrentDirectory - , doesDirectoryReallyExist, removeFileMayNotExist ) -import Darcs.Util.Path ( AbsolutePath, FilePathLike, toFilePath, - getCurrentDirectory, setCurrentDirectory ) - -import Darcs.Util.ByteString ( gzWriteFilePSs, decodeLocale, encodeLocale ) -import qualified Data.ByteString as B (null, readFile, hPut, ByteString) -import qualified Data.ByteString.Char8 as BC (unpack) - -import Darcs.Util.SignalHandler ( withSignalsBlocked ) -import Darcs.Util.Printer ( Doc, hPutDoc, packedString, empty, renderPSs, RenderMode(..) ) -import Darcs.Util.AtExit ( atexit ) -import Darcs.Util.Global ( darcsdir ) -import Darcs.Util.Workaround ( renameFile ) -import Darcs.Repository.Compat - ( mkStdoutTemp - , canonFilename - , maybeRelink - , atomicCreate - , sloppyAtomicCreate - ) -import System.Posix.Files ( fileMode, getFileStatus, setFileMode ) -#include "impossible.h" - -withLock :: String -> IO a -> IO a -withLock s job = bracket (getlock s 30) releaseLock (\_ -> job) - -releaseLock :: String -> IO () -releaseLock = removeFileMayNotExist - --- | Tries to perform some task if it can obtain the lock, --- Otherwise, just gives up without doing the task -withLockCanFail :: String -> IO a -> IO (Either () a) -withLockCanFail s job = - bracket (takeLock s) - (\l -> when l $ releaseLock s) - (\l -> if l then liftM Right job - else return $ Left ()) - -getlock :: String -> Int -> IO String -getlock l 0 = do putStrLn $ "Couldn't get lock "++l - exitWith $ ExitFailure 1 -getlock lbad tl = do l <- canonFilename lbad - gotit <- takeLock l - if gotit then return l - else do putStrLn $ "Waiting for lock "++l - hFlush stdout -- for Windows - threadDelay 2000000 - getlock l (tl - 1) - - -takeLock :: FilePathLike p => p -> IO Bool -takeLock fp = - do atomicCreate $ toFilePath fp - return True - `catch` \e -> if isAlreadyExistsError e - then return False - else do pwd <- getCurrentDirectory - throwIO $ addToErrorLoc e - ("takeLock "++toFilePath fp++" in "++toFilePath pwd) - -takeFile :: FilePath -> IO Bool -takeFile fp = - do sloppyAtomicCreate fp - return True - `catch` \e -> if isAlreadyExistsError e - then return False - else do pwd <- getCurrentDirectory - throwIO $ addToErrorLoc e - ("takeFile "++fp++" in "++toFilePath pwd) - -environmentHelpLocks :: ([String],[String]) -environmentHelpLocks = (["DARCS_SLOPPY_LOCKS"],[ - "If on some filesystems you get an error of the kind:", - "", - " darcs: takeLock [...]: atomic_create [...]: unsupported operation", - "", - "you may want to try to export DARCS_SLOPPY_LOCKS=True."]) - --- |'withTemp' safely creates an empty file (not open for writing) and --- returns its name. --- --- The temp file operations are rather similar to the locking operations, in --- that they both should always try to clean up, so exitWith causes trouble. -withTemp :: (String -> IO a) -> IO a -withTemp = bracket get_empty_file removeFileMayNotExist - where get_empty_file = do (f,h) <- openBinaryTempFile "." "darcs" - hClose h - return f - --- |'withOpenTemp' creates a temporary file, and opens it. --- Both of them run their argument and then delete the file. Also, --- both of them (to my knowledge) are not susceptible to race conditions on --- the temporary file (as long as you never delete the temporary file; that --- would reintroduce a race condition). -withOpenTemp :: ((Handle, String) -> IO a) -> IO a -withOpenTemp = bracket get_empty_file cleanup - where cleanup (h,f) = do _ <- try (hClose h) :: IO (Either SomeException ()) - removeFileMayNotExist f - get_empty_file = invert `fmap` openBinaryTempFile "." "darcs" - invert (a,b) = (b,a) - -withStdoutTemp :: (String -> IO a) -> IO a -withStdoutTemp = bracket (mkStdoutTemp "stdout_") removeFileMayNotExist - -tempdirLoc :: IO FilePath -tempdirLoc = liftM fromJust $ - firstJustIO [ liftM (Just . head . words) (readBinFile (darcsdir++"/prefs/tmpdir")) >>= chkdir, - maybeGetEnv "DARCS_TMPDIR" >>= chkdir, - getTemporaryDirectory >>= chkdir . Just, - getCurrentDirectorySansDarcs, - return $ Just "." -- always returns a Just - ] - where chkdir Nothing = return Nothing - chkdir (Just d) = liftM (\e -> if e then Just (d++"/") else Nothing) $ doesDirectoryExist d - -environmentHelpTmpdir :: ([String], [String]) -environmentHelpTmpdir = (["DARCS_TMPDIR", "TMPDIR"], [ - "Darcs often creates temporary directories. For example, the `darcs", - "diff` command creates two for the working trees to be diffed. By", - "default temporary directories are created in /tmp, or if that doesn't", - "exist, in _darcs (within the current repo). This can be overridden by", - "specifying some other directory in the file _darcs/prefs/tmpdir or the", - "environment variable $DARCS_TMPDIR or $TMPDIR."]) - -getCurrentDirectorySansDarcs :: IO (Maybe FilePath) -getCurrentDirectorySansDarcs = do - c <- getCurrentDirectory - return $ listToMaybe $ drop 5 $ reverse $ takeWhile no_darcs $ inits $ toFilePath c - where no_darcs x = darcsdir `notElem` splitDirectories x - -data WithDirKind = Perm | Temp | Delayed - --- | Creates a directory based on the path parameter; --- if a relative path is given the dir is created in the darcs temp dir. --- If an absolute path is given this dir will be created if it doesn't exist. --- If it is specified as a temporary dir, it is deleted after finishing the job. -withDir :: WithDirKind -- specifies if and when directory will be deleted - -> String -- path parameter - -> (AbsolutePath -> IO a) -> IO a -withDir _ "" _ = bug "withDir called with empty directory name" -withDir kind absoluteOrRelativeName job = do - absoluteName <- if isRelative absoluteOrRelativeName - then fmap (++ absoluteOrRelativeName) tempdirLoc - else return absoluteOrRelativeName - formerdir <- getCurrentDirectory - bracket (createDir absoluteName 0) - (\dir -> do setCurrentDirectory formerdir - k <- keepTempDir - unless k $ case kind of - Perm -> return () - Temp -> rmRecursive (toFilePath dir) - Delayed -> atexit $ rmRecursive (toFilePath dir)) - job - where newname name 0 = name - newname name n = name ++ "-" ++ show n - createDir :: FilePath -> Int -> IO AbsolutePath - createDir name n - = do createDirectory $ newname name n - setCurrentDirectory $ newname name n - getCurrentDirectory - `catch` (\e -> if isAlreadyExistsError e - then createDir name (n+1) - else throwIO e) - keepTempDir = isJust `fmap` maybeGetEnv "DARCS_KEEP_TMPDIR" - -environmentHelpKeepTmpdir :: ([String], [String]) -environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[ - "If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will", - "not remove the temporary directories it creates. This is intended", - "primarily for debugging Darcs itself, but it can also be useful, for", - "example, to determine why your test preference (see `darcs setpref`)", - "is failing when you run `darcs record`, but working when run manually."]) - --- |'withPermDir' is like 'withTempDir', except that it doesn't --- delete the directory afterwards. -withPermDir :: String -> (AbsolutePath -> IO a) -> IO a -withPermDir = withDir Perm - --- |'withTempDir' creates an empty directory and then removes it when it --- is no longer needed. withTempDir creates a temporary directory. The --- location of that directory is determined by the contents of --- _darcs/prefs/tmpdir, if it exists, otherwise by @$DARCS_TMPDIR@, and if --- that doesn't exist then whatever your operating system considers to be a --- a temporary directory (e.g. @$TMPDIR@ under Unix, @$TEMP@ under --- Windows). --- --- If none of those exist it creates the temporary directory --- in the current directory, unless the current directory is under a _darcs --- directory, in which case the temporary directory in the parent of the highest --- _darcs directory to avoid accidentally corrupting darcs's internals. --- This should not fail, but if it does indeed fail, we go ahead and use the --- current directory anyway. If @$DARCS_KEEP_TMPDIR@ variable is set --- temporary directory is not removed, this can be useful for debugging. -withTempDir :: String -> (AbsolutePath -> IO a) -> IO a -withTempDir = withDir Temp - -withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a -withDelayedDir = withDir Delayed - -rmRecursive :: FilePath -> IO () -rmRecursive d = - do isd <- doesDirectoryReallyExist d - if not isd - then removeFile d - else do conts <- actual_dir_contents - withCurrentDirectory d $ - mapM_ rmRecursive conts - removeDirectory d - where actual_dir_contents = -- doesn't include . or .. - do c <- getDirectoryContents d - return $ filter (/=".") $ filter (/="..") c - -worldReadableTemp :: String -> IO String -worldReadableTemp f = wrt 0 - where wrt :: Int -> IO String - wrt 100 = fail $ "Failure creating temp named "++f - wrt n = let f_new = f++"-"++show n - in do ok <- takeFile f_new - if ok then return f_new - else wrt (n+1) - -withNamedTemp :: String -> (String -> IO a) -> IO a -withNamedTemp n = bracket get_empty_file removeFileMayNotExist - where get_empty_file = worldReadableTemp n - -readBinFile :: FilePathLike p => p -> IO String -readBinFile = fmap BC.unpack . B.readFile . toFilePath - --- | Reads a file. Differs from readBinFile in that it interprets the file in --- the current locale instead of as ISO-8859-1. -readLocaleFile :: FilePathLike p => p -> IO String -readLocaleFile f = decodeLocale `fmap` B.readFile (toFilePath f) - -readDocBinFile :: FilePathLike p => p -> IO Doc -readDocBinFile fp = do ps <- B.readFile $ toFilePath fp - return $ if B.null ps then empty else packedString ps - -appendBinFile :: FilePathLike p => p -> String -> IO () -appendBinFile f s = appendToFile f $ \h -> hPutStr h s - -appendDocBinFile :: FilePathLike p => p -> Doc -> IO () -appendDocBinFile f d = appendToFile f $ \h -> hPutDoc Standard h d - -writeBinFile :: FilePathLike p => p -> String -> IO () -writeBinFile f s = writeToFile f $ \h -> hPutStr h s - --- | Writes a file. Differs from writeBinFile in that it writes the string --- encoded with the current locale instead of what GHC thinks is right. -writeLocaleFile :: FilePathLike p => p -> String -> IO () -writeLocaleFile f s = writeToFile f $ \h -> B.hPut h (encodeLocale s) - -writeDocBinFile :: FilePathLike p => p -> Doc -> IO () -writeDocBinFile f d = writeToFile f $ \h -> hPutDoc Standard h d - -writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO () -writeAtomicFilePS f ps = writeToFile f $ \h -> B.hPut h ps - -gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO () -gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps] - -gzWriteAtomicFilePSs :: FilePathLike p => p -> [B.ByteString] -> IO () -gzWriteAtomicFilePSs f pss = - withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do - gzWriteFilePSs newf pss - already_exists <- doesFileExist $ toFilePath f - when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f) - setFileMode newf mode - `catchall` return () - renameFile newf (toFilePath f) - -gzWriteDocFile :: FilePathLike p => p -> Doc -> IO () -gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs Standard d - -writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO () -writeToFile f job = - withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do - withBinaryFile newf WriteMode job - already_exists <- doesFileExist (toFilePath f) - when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f) - setFileMode newf mode - `catchall` return () - renameFile newf (toFilePath f) - -appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO () -appendToFile f job = withSignalsBlocked $ - withBinaryFile (toFilePath f) AppendMode job - - -addToErrorLoc :: IOException - -> String - -> IOException -addToErrorLoc ioe s = annotateIOError ioe s Nothing Nothing diff --git a/src/Darcs/Repository/LowLevel.hs b/src/Darcs/Repository/LowLevel.hs deleted file mode 100644 --- a/src/Darcs/Repository/LowLevel.hs +++ /dev/null @@ -1,126 +0,0 @@ --- Copyright (C) 2002-2004,2007-2008 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 #-} - -module Darcs.Repository.LowLevel - ( readPending - , readTentativePending - , writeTentativePending - -- deprecated interface: - , readNewPending - , writeNewPending - , pendingName - ) where - -import Control.Applicative -import qualified Data.ByteString as BS ( empty ) - -import Darcs.Util.Global ( darcsdir ) -import Darcs.Repository.Lock ( writeDocBinFile ) -import Darcs.Repository.InternalTypes ( Repository(..) ) -import Darcs.Patch ( readPatch, RepoPatch, PrimOf ) -import Darcs.Patch.Read ( ReadPatch(..), bracketedFL ) -import Darcs.Patch.ReadMonads ( ParserM ) -import Darcs.Patch.Show ( ShowPatchBasic(..) ) -import Darcs.Util.Exception ( catchall ) -import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), mapSeal ) -import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL ) - -import Darcs.Util.ByteString ( gzReadFilePS ) -import Darcs.Util.Printer ( Doc, ($$), (<>), text, vcat ) - -pendingName :: String -pendingName = darcsdir ++ "/patches/pending" - -newSuffix, tentativeSuffix :: String -newSuffix = ".new" -tentativeSuffix = ".tentative" - --- | Read the contents of pending. --- The return type is currently incorrect as it refers to the tentative --- state rather than the recorded state. -readPending :: RepoPatch p => Repository p wR wU wT - -> IO (Sealed (FL (PrimOf p) wT)) -readPending = readPendingFile "" - --- |Read the contents of tentative pending. -readTentativePending :: RepoPatch p => Repository p wR wU wT - -> IO (Sealed (FL (PrimOf p) wT)) -readTentativePending = readPendingFile tentativeSuffix - --- |Read the contents of tentative pending. -readNewPending :: RepoPatch p => Repository p wR wU wT - -> IO (Sealed (FL (PrimOf p) wT)) -readNewPending = readPendingFile newSuffix - --- |Read the pending file with the given suffix. CWD should be the repository --- directory. -readPendingFile :: ReadPatch prim => String -> Repository p wR wU wT - -> IO (Sealed (FL prim wX)) -readPendingFile suffix _ = do - pend <- gzReadFilePS (pendingName ++ suffix) `catchall` return BS.empty - return . maybe (Sealed NilFL) (mapSeal unFLM) . readPatch $ pend - --- Wrapper around FL where printed format uses { } except around singletons. --- Now that the Show behaviour of FL p can be customised (using --- showFLBehavior), we could instead change the general behaviour of FL Prim; --- but since the pending code can be kept nicely compartmentalised, it's nicer --- to do it this way. -newtype FLM p wX wY = FLM { unFLM :: FL p wX wY } - -instance ReadPatch p => ReadPatch (FLM p) where - readPatch' = mapSeal FLM <$> readMaybeBracketedFL readPatch' '{' '}' - -instance ShowPatchBasic p => ShowPatchBasic (FLM p) where - showPatch = showMaybeBracketedFL showPatch '{' '}' . unFLM - -readMaybeBracketedFL :: forall m p wX . ParserM m - => (forall wY . m (Sealed (p wY))) -> Char -> Char - -> m (Sealed (FL p wX)) -readMaybeBracketedFL parser pre post = - bracketedFL parser pre post <|> (mapSeal (:>:NilFL) <$> parser) - -showMaybeBracketedFL :: (forall wX wY . p wX wY -> Doc) -> Char -> Char - -> FL p wA wB -> Doc -showMaybeBracketedFL _ pre post NilFL = text [pre] $$ text [post] -showMaybeBracketedFL printer _ _ (p :>: NilFL) = printer p -showMaybeBracketedFL printer pre post ps = text [pre] $$ - vcat (mapFL printer ps) $$ - text [post] - --- |Write the contents of tentative pending. -writeTentativePending :: RepoPatch p => Repository p wR wU wT - -> FL (PrimOf p) wT wY -> IO () -writeTentativePending = writePendingFile tentativeSuffix - --- |Write the contents of new pending. CWD should be the repository directory. -writeNewPending :: RepoPatch p => Repository p wR wU wT - -> FL (PrimOf p) wT wY -> IO () -writeNewPending = writePendingFile newSuffix - --- Write a pending file, with the given suffix. CWD should be the repository --- directory. -writePendingFile :: ShowPatchBasic prim => String -> Repository p wR wU wT - -> FL prim wX wY -> IO () -writePendingFile suffix _ = writePatch name . FLM - where - name = pendingName ++ suffix - -writePatch :: ShowPatchBasic p => FilePath -> p wX wY -> IO () -writePatch f p = writeDocBinFile f $ showPatch p <> text "\n" diff --git a/src/Darcs/Repository/Match.hs b/src/Darcs/Repository/Match.hs --- a/src/Darcs/Repository/Match.hs +++ b/src/Darcs/Repository/Match.hs @@ -20,11 +20,13 @@ module Darcs.Repository.Match ( getNonrangeMatch - , getPartialNonrangeMatch , getFirstMatch , getOnePatchset ) where +import Prelude () +import Darcs.Prelude + import Darcs.Patch.Match ( getNonrangeMatchS , getFirstMatchS @@ -40,7 +42,7 @@ import Darcs.Patch.Bundle ( scanContextFile ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) import Darcs.Patch.Apply( ApplyState ) -import Darcs.Patch ( RepoPatch ) +import Darcs.Patch ( RepoPatch, IsRepoType ) import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, Origin ) import Darcs.Patch.Witnesses.Sealed ( seal ) @@ -50,14 +52,14 @@ import Darcs.Repository.Internal ( Repository, readRepo, createPristineDirectoryTree ) -import Storage.Hashed.Tree ( Tree ) +import Darcs.Util.Tree ( Tree ) -import Darcs.Util.Path ( FileName, toFilePath ) +import Darcs.Util.Path ( toFilePath ) #include "impossible.h" -getNonrangeMatch :: (ApplyMonad DefaultIO (ApplyState p), RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT +getNonrangeMatch :: (ApplyMonad (ApplyState p) DefaultIO, IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> [MatchFlag] -> IO () getNonrangeMatch r = withRecordedMatch r . getMatch where @@ -66,24 +68,16 @@ | otherwise -> fail "Index range is not allowed for this command." _ -> getNonrangeMatchS fs -getPartialNonrangeMatch :: (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree) - => Repository p wR wU wT - -> [MatchFlag] - -> [FileName] - -> IO () -getPartialNonrangeMatch r fs _ = - withRecordedMatch r (getNonrangeMatchS fs) - -getFirstMatch :: (ApplyMonad DefaultIO (ApplyState p), RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT +getFirstMatch :: (ApplyMonad (ApplyState p) DefaultIO, IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> [MatchFlag] -> IO () getFirstMatch r fs = withRecordedMatch r (getFirstMatchS fs) -getOnePatchset :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT +getOnePatchset :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> [MatchFlag] - -> IO (SealedPatchSet p Origin) + -> IO (SealedPatchSet rt p Origin) getOnePatchset repository fs = case nonrangeMatcher fs of Just m -> do ps <- readRepo repository @@ -95,9 +89,9 @@ context_f (Context f:_) = f context_f (_:xs) = context_f xs -withRecordedMatch :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT - -> (PatchSet p Origin wR -> DefaultIO ()) +withRecordedMatch :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> (PatchSet rt p Origin wR -> DefaultIO ()) -> IO () withRecordedMatch r job = do createPristineDirectoryTree r "." WithWorkingDir diff --git a/src/Darcs/Repository/Merge.hs b/src/Darcs/Repository/Merge.hs --- a/src/Darcs/Repository/Merge.hs +++ b/src/Darcs/Repository/Merge.hs @@ -23,10 +23,13 @@ , considerMergeToWorking ) where +import Prelude () +import Darcs.Prelude + import Control.Monad ( when ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) -import Darcs.Repository.External ( backupByCopying ) +import Darcs.Util.External ( backupByCopying ) import Darcs.Repository.Flags ( UseIndex , ScanKnown @@ -39,10 +42,11 @@ , WantGuiPause (..) , DiffAlgorithm (..) ) -import Darcs.Patch ( RepoPatch, PrimOf, merge, listTouchedFiles, patchcontents, - anonymous, fromPrims, effect ) +import Darcs.Patch ( RepoPatch, IsRepoType, PrimOf, merge, listTouchedFiles, + fromPrims, effect ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Depends( merge2FL ) +import Darcs.Patch.Named.Wrapped ( activecontents, anonymous ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully ) import Darcs.Patch.Progress( progressFL ) import Darcs.Patch.Witnesses.Ordered @@ -61,27 +65,29 @@ UpdatePristine(..) ) import Darcs.Util.Progress( debugMessage ) -tentativelyMergePatches_ :: forall p wR wU wT wY wX. (RepoPatch p, - ApplyState p ~ Tree) => MakeChanges - -> Repository p wR wU wT -> String +tentativelyMergePatches_ :: forall rt p wR wU wT wY wX + . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => MakeChanges + -> Repository rt p wR wU wT -> String -> AllowConflicts -> UpdateWorking -> ExternalMerge -> WantGuiPause -> Compression -> Verbosity -> Reorder -> ( UseIndex, ScanKnown, DiffAlgorithm ) - -> FL (PatchInfoAnd p) wX wT - -> FL (PatchInfoAnd p) wX wY + -> FL (PatchInfoAnd rt p) wX wT + -> FL (PatchInfoAnd rt p) wX wY -> IO (Sealed (FL (PrimOf p) wU)) -tentativelyMergePatches_ mc r cmd allowConflicts updateWorking externalMerge wantGuiPause compression verbosity reorder diffingOpts@(_, _, dflag) usi themi = do +tentativelyMergePatches_ mc r cmd allowConflicts updateWorking externalMerge wantGuiPause + compression verbosity reorder diffingOpts@(_, _, dflag) usi themi = do let us = mapFL_FL hopefully usi them = mapFL_FL hopefully themi - ((pc :: FL (PatchInfoAnd p) wT wMerged) :/\: us_merged) + ((pc :: FL (PatchInfoAnd rt p) wT wMerged) :/\: us_merged) <- return $ merge2FL (progressFL "Merging us" usi) (progressFL "Merging them" themi) pend <- unrecordedChanges diffingOpts r Nothing anonpend <- n2pia `fmap` anonymous (fromPrims pend) pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL) let pwprim = concatFL $ progressFL "Examining patches for conflicts" $ - mapFL_FL (patchcontents . hopefully) pw + mapFL_FL (activecontents . hopefully) pw Sealed standard_resolved_pw <- return $ standardResolution pwprim debugMessage "Checking for conflicts..." when (allowConflicts == YesAllowConflictsAndMark) $ @@ -105,7 +111,7 @@ (effect us +>+ pend) (effect them) pwprim debugMessage "Applying patches to the local directories..." when (mc == MakeChanges) $ do - let doChanges :: FL (PatchInfoAnd p) wX wT -> IO (Repository p wR wU wMerged) + let doChanges :: FL (PatchInfoAnd rt p) wX wT -> IO (Repository rt p wR wU wMerged) -- This first case is a possible optimisation: if 'usi' is empty, then -- the merge2FL call above will return pc = themi, but the wMerged -- witness is quantified in the :/\: constructor so we lose the @@ -129,14 +135,15 @@ tentativelyReplacePatches r' compression YesUpdateWorking verbosity us_merged return $ seal (effect pwprim +>+ pw_resolution) where - mapAdd :: Repository p wM wL wI -> FL (PatchInfoAnd p) wI wJ - -> IO (Repository p wM wL wJ) + mapAdd :: Repository rt p wM wL wI -> FL (PatchInfoAnd rt p) wI wJ + -> IO (Repository rt p wM wL wJ) mapAdd repo NilFL = return repo mapAdd repo (a:>:as) = do repo' <- tentativelyAddPatch_ DontUpdatePristine repo compression verbosity updateWorking a mapAdd repo' as - applyps :: Repository p wM wL wI -> FL (PatchInfoAnd p) wI wJ -> IO (Repository p wM wL wJ) + applyps :: Repository rt p wM wL wI -> FL (PatchInfoAnd rt p) wI wJ + -> IO (Repository rt p wM wL wJ) applyps repo ps = do debugMessage "Adding patches to inventory..." repo' <- mapAdd repo ps @@ -144,26 +151,26 @@ applyToTentativePristine repo verbosity ps return repo' -tentativelyMergePatches :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> String +tentativelyMergePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => Repository rt p wR wU wT -> String -> AllowConflicts -> UpdateWorking -> ExternalMerge -> WantGuiPause -> Compression -> Verbosity -> Reorder -> ( UseIndex, ScanKnown, DiffAlgorithm ) - -> FL (PatchInfoAnd p) wX wT - -> FL (PatchInfoAnd p) wX wY + -> FL (PatchInfoAnd rt p) wX wT + -> FL (PatchInfoAnd rt p) wX wY -> IO (Sealed (FL (PrimOf p) wU)) tentativelyMergePatches = tentativelyMergePatches_ MakeChanges -considerMergeToWorking :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> String +considerMergeToWorking :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => Repository rt p wR wU wT -> String -> AllowConflicts -> UpdateWorking -> ExternalMerge -> WantGuiPause -> Compression -> Verbosity -> Reorder -> ( UseIndex, ScanKnown, DiffAlgorithm ) - -> FL (PatchInfoAnd p) wX wT - -> FL (PatchInfoAnd p) wX wY + -> FL (PatchInfoAnd rt p) wX wT + -> FL (PatchInfoAnd rt p) wX wY -> IO (Sealed (FL (PrimOf p) wU)) considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges diff --git a/src/Darcs/Repository/Motd.hs b/src/Darcs/Repository/Motd.hs --- a/src/Darcs/Repository/Motd.hs +++ b/src/Darcs/Repository/Motd.hs @@ -20,11 +20,14 @@ , showMotd ) where +import Prelude () +import Darcs.Prelude + import Control.Monad ( unless ) import qualified Data.ByteString as B (null, hPut, empty, ByteString) import System.IO ( stdout ) -import Darcs.Repository.External ( fetchFilePS, Cachable(..) ) +import Darcs.Util.External ( fetchFilePS, Cachable(..) ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Exception ( catchall ) diff --git a/src/Darcs/Repository/Old.hs b/src/Darcs/Repository/Old.hs --- a/src/Darcs/Repository/Old.hs +++ b/src/Darcs/Repository/Old.hs @@ -21,7 +21,8 @@ module Darcs.Repository.Old ( readOldRepo, revertTentativeChanges, oldRepoFailMsg ) where -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude import Darcs.Util.Progress ( debugMessage, beginTedious, endTedious, finishedOneIO ) import Darcs.Util.Path ( ioAbsoluteOrRemote, toPath ) @@ -34,19 +35,19 @@ import qualified Data.ByteString.Char8 as BC (break, pack) -import Darcs.Patch ( RepoPatch, Named, +import Darcs.Patch ( RepoPatch, IsRepoType, WrappedNamed, readPatch ) import Darcs.Patch.Witnesses.Ordered ( RL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unseal, mapSeal ) import Darcs.Patch.Info ( PatchInfo, makeFilename, readPatchInfos, showPatchInfo ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin ) -import Darcs.Repository.External +import Darcs.Util.External ( gzFetchFilePS , Cachable(..) , cloneFile ) -import Darcs.Repository.Lock ( writeBinFile ) +import Darcs.Util.Lock ( writeBinFile ) import Darcs.Util.Printer ( renderString, RenderMode(..) ) import Darcs.Util.Global ( darcsdir ) @@ -54,7 +55,7 @@ #include "impossible.h" -readOldRepo :: RepoPatch p => String -> IO (SealedPatchSet p Origin) +readOldRepo :: (IsRepoType rt, RepoPatch p) => String -> IO (SealedPatchSet rt p Origin) readOldRepo d = do realdir <- toPath `fmap` ioAbsoluteOrRemote d let k = "Reading inventory of repository "++d @@ -63,7 +64,8 @@ (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) ioError e) -readRepoPrivate :: RepoPatch p => String -> FilePath -> FilePath -> IO (SealedPatchSet p Origin) +readRepoPrivate :: (IsRepoType rt, RepoPatch p) + => String -> FilePath -> FilePath -> IO (SealedPatchSet rt p Origin) readRepoPrivate k d iname = do i <- gzFetchFilePS (d darcsdir iname) Uncachable finishedOneIO k iname @@ -76,10 +78,10 @@ _ -> (Nothing, reverse $ readPatchInfos i) Sealed ts <- unseal seal `fmap` unsafeInterleaveIO (read_ts parse mt) Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is) - return $ seal (PatchSet ps ts) + return $ seal (PatchSet ts ps) where read_ts :: RepoPatch p => - (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd p wB))) - -> Maybe PatchInfo -> IO (Sealed (RL (Tagged p) Origin)) + (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd rt p wB))) + -> Maybe PatchInfo -> IO (Sealed (RL (Tagged rt p) Origin)) read_ts _ Nothing = do endTedious k return $ seal NilRL read_ts parse (Just tag0) = @@ -100,22 +102,23 @@ \(e :: IOException) -> return $ seal $ patchInfoAndPatch tag0 $ unavailable $ show e - return $ seal $ Tagged tag00 Nothing ps :<: ts - parse2 :: RepoPatch p => PatchInfo -> FilePath - -> IO (Sealed (PatchInfoAnd p wX)) + return $ seal $ ts :<: Tagged tag00 Nothing ps + parse2 :: (IsRepoType rt, RepoPatch p) + => PatchInfo -> FilePath + -> IO (Sealed (PatchInfoAnd rt p wX)) parse2 i fn = do ps <- unsafeInterleaveIO $ gzFetchFilePS fn Cachable return $ patchInfoAndPatch i `mapSeal` hopefullyNoParseError (toPath fn) (readPatch ps) - hopefullyNoParseError :: String -> Maybe (Sealed (Named a1dr wX)) - -> Sealed (Hopefully (Named a1dr) wX) + hopefullyNoParseError :: String -> Maybe (Sealed (WrappedNamed rt a1dr wX)) + -> Sealed (Hopefully (WrappedNamed rt a1dr) wX) hopefullyNoParseError _ (Just (Sealed x)) = seal $ actually x hopefullyNoParseError s Nothing = seal $ unavailable $ "Couldn't parse file "++s read_patches :: RepoPatch p => - (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd p wB))) - -> [PatchInfo] -> IO (Sealed (RL (PatchInfoAnd p) wX)) + (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd rt p wB))) + -> [PatchInfo] -> IO (Sealed (RL (PatchInfoAnd rt p) wX)) read_patches _ [] = return $ seal NilRL read_patches parse (i:is) = - lift2Sealed (:<:) + lift2Sealed (flip (:<:)) (read_patches parse is) (parse i `catch` \(e :: IOException) -> return $ seal $ patchInfoAndPatch i $ unavailable $ show e) diff --git a/src/Darcs/Repository/Packs.hs b/src/Darcs/Repository/Packs.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Packs.hs @@ -0,0 +1,117 @@ +module Darcs.Repository.Packs + ( fetchAndUnpackBasic + , fetchAndUnpackPatches + , packsDir + ) where + +import qualified Codec.Archive.Tar as Tar +import Codec.Compression.GZip as GZ ( compress, decompress ) + +import Control.Concurrent.Async ( withAsync ) +import Control.Exception ( Exception, IOException, throwIO, catch ) +import Control.Monad ( void ) +import System.IO.Error ( isAlreadyExistsError ) + +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.List ( isPrefixOf ) +import Data.Maybe( catMaybes, listToMaybe ) + +import System.Directory ( createDirectoryIfMissing + , renameFile + , doesFileExist + ) +import System.FilePath ( () + , takeFileName + , splitPath + , joinPath + , takeDirectory + ) +import System.Posix.Files ( createLink ) + +import Darcs.Util.Lock ( withTemp ) +import Darcs.Util.External ( Cachable(..), fetchFileLazyPS ) +import Darcs.Repository.Cache ( fetchFileUsingCache + , HashedDir(..) + , Cache(..) + , CacheLoc(..) + , WritableOrNot(..) + , hashedDir + , bucketFolder + , CacheType(Directory) + ) + +import Darcs.Util.Global ( darcsdir ) +import Darcs.Util.Progress ( debugMessage ) + +packsDir :: String +packsDir = "packs" + +fetchAndUnpack :: FilePath + -> HashedDir + -> Cache + -> FilePath + -> IO () +fetchAndUnpack filename dir cache remote = do + unpackTar cache dir . Tar.read . GZ.decompress =<< + fetchFileLazyPS (remote darcsdir packsDir filename) Uncachable + +fetchAndUnpackPatches :: [String] -> Cache -> FilePath -> IO () +fetchAndUnpackPatches paths cache remote = + -- Patches pack can miss some new patches of the repository. + -- So we download pack asynchonously and alway do a complete pass + -- of individual patch files. + withAsync (fetchAndUnpack "patches.tar.gz" HashedInventoriesDir cache remote) $ \_ -> do + fetchFilesUsingCache cache HashedPatchesDir paths + +fetchAndUnpackBasic :: Cache -> FilePath -> IO () +fetchAndUnpackBasic = fetchAndUnpack "basic.tar.gz" HashedPristineDir + +unpackTar :: Exception e => Cache -> HashedDir -> Tar.Entries e -> IO () +unpackTar _ _ Tar.Done = return () +unpackTar _ _ (Tar.Fail e) = throwIO e +unpackTar c dir (Tar.Next e es) = case Tar.entryContent e of + Tar.NormalFile bs _ -> do + let p = Tar.entryPath e + if "meta-" `isPrefixOf` takeFileName p + then unpackTar c dir es -- just ignore them + else do + ex <- doesFileExist p + if ex + then debugMessage $ "TAR thread: exists " ++ p ++ "\nStopping TAR thread." + else do + if p == darcsdir "hashed_inventory" + then writeFile' Nothing p bs + else writeFile' (cacheDir c) p $ GZ.compress bs + debugMessage $ "TAR thread: GET " ++ p + unpackTar c dir es + _ -> fail "Unexpected non-file tar entry" + where + writeFile' Nothing path content = withTemp $ \tmp -> do + BL.writeFile tmp content + renameFile tmp path + writeFile' (Just ca) path content = do + let fileFullPath = case splitPath path of + _:hDir:hFile:_ -> joinPath [ca, hDir, bucketFolder hFile, hFile] + _ -> fail "Unexpected file path" + createDirectoryIfMissing True $ takeDirectory path + createLink fileFullPath path `catch` (\(ex :: IOException) -> do + if isAlreadyExistsError ex then + return () -- so much the better + else + -- ignore cache if we cannot link + writeFile' Nothing path content) + +-- | Similar to @'mapM_' ('void' 'fetchFileUsingCache')@, exepts +-- it stops execution if file it's going to fetch already exists. +fetchFilesUsingCache :: Cache -> HashedDir -> [FilePath] -> IO () +fetchFilesUsingCache cache dir = mapM_ go where + go path = do + ex <- doesFileExist $ darcsdir hashedDir dir path + if ex + then debugMessage $ "FILE thread: exists " ++ path + else void $ fetchFileUsingCache cache dir path + +cacheDir :: Cache -> Maybe String +cacheDir (Ca cs) = listToMaybe . catMaybes .flip map cs $ \x -> case x of + Cache Directory Writable x' -> Just x' + _ -> Nothing diff --git a/src/Darcs/Repository/PatchIndex.hs b/src/Darcs/Repository/PatchIndex.hs --- a/src/Darcs/Repository/PatchIndex.hs +++ b/src/Darcs/Repository/PatchIndex.hs @@ -27,7 +27,6 @@ createOrUpdatePatchIndexDisk, deletePatchIndex, dumpPatchIndex, - dumpPatchIndexFiles, filterPatches, PatchFilter, maybeFilterPatches, @@ -36,7 +35,7 @@ attemptCreatePatchIndex ) where -import Prelude hiding ( catch, pi ) +import Prelude hiding ( pi, (<$>) ) import Data.Binary ( encodeFile, decodeFile ) import Data.Word ( Word32 ) import Data.Int ( Int8 ) @@ -53,12 +52,12 @@ import System.Directory ( createDirectory, renameDirectory, doesFileExist, doesDirectoryExist ) import Darcs.Repository.Format ( formatHas, RepoProperty( HashedInventory ) ) import Darcs.Repository.InternalTypes ( Repository(..) ) -import Darcs.Repository.Read ( readRepo ) +import Darcs.Repository.HashedRepo ( readRepo ) import Darcs.Patch.Witnesses.Ordered ( mapFL, RL(..), FL(..), reverseRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal, seal2, unsafeUnseal ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd(..), info ) -import Darcs.Repository.Lock ( withPermDir, rmRecursive ) -import Darcs.Patch ( RepoPatch, listTouchedFiles ) +import Darcs.Util.Lock ( withPermDir, rmRecursive ) +import Darcs.Patch ( RepoPatch, IsRepoType, listTouchedFiles ) import Darcs.Util.Path ( FileName, fp2fn, fn2fp, toFilePath ) import Darcs.Patch.Apply ( applyToFileMods, ApplyState(..) ) import Darcs.Patch.Set ( newset2FL, Origin, newset2FL ) @@ -72,7 +71,7 @@ import qualified Data.ByteString as B import Darcs.Util.Crypt.SHA256 (sha256sum ) import Darcs.Util.Crypt.SHA1 ( SHA1(..), showAsHex ) -import Storage.Hashed.Tree ( Tree(..) ) +import Darcs.Util.Tree ( Tree(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.SignalHandler ( catchInterrupt ) #include "impossible.h" @@ -318,15 +317,17 @@ -- Create/Update patch-index on disk -- | create patch index that corresponds to all patches in repo -createPatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () -createPatchIndexDisk repository = do - rawpatches <- newset2FL `fmap` readRepo repository +createPatchIndexDisk + :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> IO () +createPatchIndexDisk repository@(Repo r _ _ _) = do + rawpatches <- newset2FL `fmap` readRepo repository r let patches = mapFL Sealed2 rawpatches createPatchIndexFrom repository $ patches2patchMods patches S.empty -- | convert patches to patchmods patches2patchMods :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) - => [Sealed2 (PatchInfoAnd p)] -> Set FileName -> [(PatchId, [PatchMod FileName])] + => [Sealed2 (PatchInfoAnd rt p)] -> Set FileName -> [(PatchId, [PatchMod FileName])] patches2patchMods patches fns = snd $ mapAccumL go fns patches where go filenames (Sealed2 p) = (filenames', (pid, pmods_effect ++ pmods_dup)) @@ -385,18 +386,20 @@ | otherwise = [] -- | update the patch index to the current state of the repository -updatePatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () +updatePatchIndexDisk + :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> IO () updatePatchIndexDisk repo@(Repo repodir _ _ _) = do (_,_,pid2idx,pindex) <- loadPatchIndex repodir -- check that patch index is up to date - patches <- newset2FL `fmap` readRepo repo + patches <- newset2FL `fmap` readRepo repo repodir let pidsrepo = mapFL (makePatchID . info) patches (oldpids,_,len_common) = uncommon (reverse $ pids pindex) pidsrepo pindex' = removePidSuffix pid2idx oldpids pindex filenames = fpSpans2fileNames (fpspans pindex') cdir = repodir indexDir -- reread to prevent holding onto patches for too long - rawpatches <- newset2FL `fmap` readRepo repo + rawpatches <- newset2FL `fmap` readRepo repo repodir let newpatches = drop len_common $ mapFL seal2 rawpatches newpmods = patches2patchMods newpatches filenames inv_hash <- getInventoryHash repodir @@ -411,7 +414,7 @@ -- | 'createPatchIndexFrom repo pmods' creates a patch index from the given -- patchmods. -createPatchIndexFrom :: RepoPatch p => Repository p wR wU wT +createPatchIndexFrom :: RepoPatch p => Repository rt p wR wU wT -> [(PatchId, [PatchMod FileName])] -> IO () createPatchIndexFrom (Repo repodir _ _ _) pmods = do inv_hash <- getInventoryHash repodir @@ -438,8 +441,8 @@ -- | ensuring that whenever loaded, the patch-index -- | can actually be read by the current version of darcs, -- | and up to date. -loadSafePatchIndex :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT +loadSafePatchIndex :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> IO (Map PatchId Int, PatchIndex) loadSafePatchIndex repo@(Repo repodir _ _ _) = do can_use <- isPatchIndexInSync repo @@ -466,8 +469,8 @@ isPatchIndexDisabled repodir = doesFileExist (repodir darcsdir noPatchIndex) -- | create or update patch index -createOrUpdatePatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> IO () +createOrUpdatePatchIndexDisk :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> IO () createOrUpdatePatchIndexDisk repo@(Repo repodir _ _ _)= do rmRecursive (repodir darcsdir noPatchIndex) `catch` \(_ :: IOError) -> return () dpie <- doesPatchIndexExist repodir @@ -478,7 +481,7 @@ -- | Checks whether a patch index can (and should) be created. If we are not in -- an old-fashioned repo, and if we haven't been told not to, then we should -- create a patch index if it doesn't already exist. -canCreatePI :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT +canCreatePI :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO Bool canCreatePI (Repo repodir format _ _) = (not . or) <$> sequence [ doesntHaveHashedInventory format @@ -491,7 +494,7 @@ -- | see if the default is to use patch index or not -- | creates Patch index, if it does not exist, and noPatchIndex is not set canUsePatchIndex :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> IO Bool + => Repository rt p wR wU wT -> IO Bool canUsePatchIndex (Repo repodir _ _ _) = do piExists <- doesPatchIndexExist repodir piDisabled <- isPatchIndexDisabled repodir @@ -501,8 +504,8 @@ (True, True) -> error "patch index exists, and patch index is disabled. run optimize enable-patch-index or disable-patch-index to rectify." (False, False) -> return False -createPIWithInterrupt :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> IO () +createPIWithInterrupt :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> IO () createPIWithInterrupt repo@(Repo repodir _ _ _) = do putStrLn "Creating a patch index, please wait. To stop press Ctrl-C" (do @@ -511,7 +514,7 @@ -- | check if patch-index is in sync with repository isPatchIndexInSync :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> IO Bool + => Repository rt p wR wU wT -> IO Bool isPatchIndexInSync (Repo repodir _ _ _) = do dpie <- doesPatchIndexExist repodir if dpie @@ -666,17 +669,11 @@ putStrLn "==============" putStrLn $ unlines $ fpSpans2filePaths fpspans infom - -dumpPatchIndexFiles :: FilePath -> IO () -dumpPatchIndexFiles repodir = do - (_,_,_,PatchIndex _ _ fpspans infom) <- loadPatchIndex repodir - putStr $ unlines $ fpSpans2filePaths fpspans infom - ----------------------------------------------------------------------- -- Filtering functions based on FilePaths -- returns an RL in which the order of patches matters, for annotate to use -getRelevantSubsequence :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p) - => Sealed ((RL a) wK) -> Repository p wR wU wR -> [FileName] -> IO (Sealed ((RL a) Origin)) +getRelevantSubsequence :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd rt p) + => Sealed ((RL a) wK) -> Repository rt p wR wU wR -> [FileName] -> IO (Sealed ((RL a) Origin)) getRelevantSubsequence pxes repository fns = do (_, pi@(PatchIndex _ _ _ infom)) <- loadSafePatchIndex repository let fids = map (\fn -> evalState (lookupFid fn) pi) fns @@ -685,29 +682,29 @@ let flpxes = reverseRL $ unsafeUnseal pxes return.seal $ keepElems flpxes NilRL pids - where keepElems :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p) + where keepElems :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd rt p) => FL a wX wY -> RL a wB wX -> S.Set Word32 -> RL a wP wQ keepElems NilFL acc _ = unsafeCoerceP acc keepElems (x:>:xs) acc pids - | (short $ makePatchID $ info x) `S.member` pids = keepElems xs (x:<:acc) pids + | (short $ makePatchID $ info x) `S.member` pids = keepElems xs (acc:<:x) pids | otherwise = keepElems (unsafeCoerceP xs) acc pids -- | filter given patches so as to keep only the patches that modify the given files -filterPatches :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p) => Repository p wR wU wT -> [FilePath] -> [Sealed2 a] -> IO [Sealed2 a] +filterPatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd rt p) => Repository rt p wR wU wT -> [FilePath] -> [Sealed2 a] -> IO [Sealed2 a] filterPatches repository fps ops = do (_, pi@(PatchIndex _ _ _ infom)) <- loadSafePatchIndex repository let fids = concatMap ((\fn -> evalState (lookupFids' fn) pi). fp2fn) fps npids = S.unions $ map (touching.fromJust.(`M.lookup` infom)) fids return $ filter (flip S.member npids . (\(Sealed2 (PIAP pin _)) -> short $ makePatchID pin)) ops -type PatchFilter p = [FilePath] -> [Sealed2 (PatchInfoAnd p)] -> IO [Sealed2 (PatchInfoAnd p)] +type PatchFilter rt p = [FilePath] -> [Sealed2 (PatchInfoAnd rt p)] -> IO [Sealed2 (PatchInfoAnd rt p)] -- | If a patch index is available, filter given patches so as to keep only the patches that -- modify the given files. If none is available, return the original input. maybeFilterPatches - :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT - -> PatchFilter p + :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> PatchFilter rt p maybeFilterPatches repo fps ops = do usePI <- canUsePatchIndex repo -- in theory we could change the type signature to make this function staged, @@ -718,7 +715,7 @@ ----------------------------------------------------------------------- -- Test patch index -piTest :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () +piTest :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO () piTest repository = do (_, PatchIndex rpids fidspans fpspans infom) <- loadSafePatchIndex repository let pids = reverse rpids @@ -764,7 +761,8 @@ isInOrder _ [] = False -- | Check if patch index can be created and build it with interrupt. -attemptCreatePatchIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () +attemptCreatePatchIndex + :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO () attemptCreatePatchIndex repo = do canCreate <- canCreatePI repo when canCreate $ createPIWithInterrupt repo diff --git a/src/Darcs/Repository/Pending.hs b/src/Darcs/Repository/Pending.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Pending.hs @@ -0,0 +1,129 @@ +-- Copyright (C) 2002-2004,2007-2008 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 #-} + +module Darcs.Repository.Pending + ( readPending + , readTentativePending + , writeTentativePending + -- deprecated interface: + , readNewPending + , writeNewPending + , pendingName + ) where + +import Prelude () +import Darcs.Prelude + +import Control.Applicative +import qualified Data.ByteString as BS ( empty ) + +import Darcs.Util.Global ( darcsdir ) +import Darcs.Util.Lock ( writeDocBinFile ) +import Darcs.Repository.InternalTypes ( Repository(..) ) +import Darcs.Patch ( readPatch, RepoPatch, PrimOf ) +import Darcs.Patch.Read ( ReadPatch(..), bracketedFL ) +import Darcs.Patch.ReadMonads ( ParserM ) +import Darcs.Patch.Show ( ShowPatchBasic(..) ) +import Darcs.Util.Exception ( catchall ) +import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), mapSeal ) +import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL ) + +import Darcs.Util.ByteString ( gzReadFilePS ) +import Darcs.Util.Printer ( Doc, ($$), (<>), text, vcat ) + +pendingName :: String +pendingName = darcsdir ++ "/patches/pending" + +newSuffix, tentativeSuffix :: String +newSuffix = ".new" +tentativeSuffix = ".tentative" + +-- | Read the contents of pending. +-- The return type is currently incorrect as it refers to the tentative +-- state rather than the recorded state. +readPending :: RepoPatch p => Repository rt p wR wU wT + -> IO (Sealed (FL (PrimOf p) wT)) +readPending = readPendingFile "" + +-- |Read the contents of tentative pending. +readTentativePending :: RepoPatch p => Repository rt p wR wU wT + -> IO (Sealed (FL (PrimOf p) wT)) +readTentativePending = readPendingFile tentativeSuffix + +-- |Read the contents of tentative pending. +readNewPending :: RepoPatch p => Repository rt p wR wU wT + -> IO (Sealed (FL (PrimOf p) wT)) +readNewPending = readPendingFile newSuffix + +-- |Read the pending file with the given suffix. CWD should be the repository +-- directory. +readPendingFile :: ReadPatch prim => String -> Repository rt p wR wU wT + -> IO (Sealed (FL prim wX)) +readPendingFile suffix _ = do + pend <- gzReadFilePS (pendingName ++ suffix) `catchall` return BS.empty + return . maybe (Sealed NilFL) (mapSeal unFLM) . readPatch $ pend + +-- Wrapper around FL where printed format uses { } except around singletons. +-- Now that the Show behaviour of FL p can be customised (using +-- showFLBehavior), we could instead change the general behaviour of FL Prim; +-- but since the pending code can be kept nicely compartmentalised, it's nicer +-- to do it this way. +newtype FLM p wX wY = FLM { unFLM :: FL p wX wY } + +instance ReadPatch p => ReadPatch (FLM p) where + readPatch' = mapSeal FLM <$> readMaybeBracketedFL readPatch' '{' '}' + +instance ShowPatchBasic p => ShowPatchBasic (FLM p) where + showPatch = showMaybeBracketedFL showPatch '{' '}' . unFLM + +readMaybeBracketedFL :: forall m p wX . ParserM m + => (forall wY . m (Sealed (p wY))) -> Char -> Char + -> m (Sealed (FL p wX)) +readMaybeBracketedFL parser pre post = + bracketedFL parser pre post <|> (mapSeal (:>:NilFL) <$> parser) + +showMaybeBracketedFL :: (forall wX wY . p wX wY -> Doc) -> Char -> Char + -> FL p wA wB -> Doc +showMaybeBracketedFL _ pre post NilFL = text [pre] $$ text [post] +showMaybeBracketedFL printer _ _ (p :>: NilFL) = printer p +showMaybeBracketedFL printer pre post ps = text [pre] $$ + vcat (mapFL printer ps) $$ + text [post] + +-- |Write the contents of tentative pending. +writeTentativePending :: RepoPatch p => Repository rt p wR wU wT + -> FL (PrimOf p) wT wY -> IO () +writeTentativePending = writePendingFile tentativeSuffix + +-- |Write the contents of new pending. CWD should be the repository directory. +writeNewPending :: RepoPatch p => Repository rt p wR wU wT + -> FL (PrimOf p) wT wY -> IO () +writeNewPending = writePendingFile newSuffix + +-- Write a pending file, with the given suffix. CWD should be the repository +-- directory. +writePendingFile :: ShowPatchBasic prim => String -> Repository rt p wR wU wT + -> FL prim wX wY -> IO () +writePendingFile suffix _ = writePatch name . FLM + where + name = pendingName ++ suffix + +writePatch :: ShowPatchBasic p => FilePath -> p wX wY -> IO () +writePatch f p = writeDocBinFile f $ showPatch p <> text "\n" diff --git a/src/Darcs/Repository/Prefs.hs b/src/Darcs/Repository/Prefs.hs --- a/src/Darcs/Repository/Prefs.hs +++ b/src/Darcs/Repository/Prefs.hs @@ -47,12 +47,14 @@ , oldGlobalCacheDir ) where +import Prelude () +import Darcs.Prelude + import Control.Exception ( catch ) import Control.Monad ( unless, when, liftM ) import Data.Char ( toUpper ) -import Data.List ( nub, isPrefixOf, union, sortBy ) +import Data.List ( nub, isPrefixOf, union, sortBy, lookup ) import Data.Maybe ( isJust, fromMaybe, mapMaybe, catMaybes, maybeToList ) -import Prelude hiding ( catch ) import qualified Control.Exception as C import qualified Data.ByteString as B ( empty ) import qualified Data.ByteString.Char8 as BC ( unpack ) @@ -67,10 +69,10 @@ import Darcs.Repository.Cache ( Cache(..), CacheType(..), CacheLoc(..), WritableOrNot(..), compareByLocality ) -import Darcs.Repository.External ( gzFetchFilePS , Cachable( Cachable )) +import Darcs.Util.External ( gzFetchFilePS , Cachable( Cachable )) import Darcs.Repository.Flags( UseCache (..), DryRun (..), SetDefault (..), RemoteRepos (..) ) -import Darcs.Repository.Lock( readBinFile, writeBinFile ) +import Darcs.Util.Lock( readBinFile, writeBinFile ) import Darcs.Util.Exception ( catchall ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Path ( AbsolutePath, ioAbsolute, toFilePath, diff --git a/src/Darcs/Repository/Read.hs b/src/Darcs/Repository/Read.hs deleted file mode 100644 --- a/src/Darcs/Repository/Read.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Darcs.Repository.Read ( readRepo ) where - -import Darcs.Patch (RepoPatch) -import Darcs.Patch.Apply ( ApplyState ) -import Storage.Hashed.Tree ( Tree ) -import Darcs.Repository.InternalTypes ( Repository(Repo) ) -import Darcs.Patch.Set ( PatchSet, Origin ) -import Darcs.Repository.Format ( formatHas, RepoProperty(HashedInventory) ) -import qualified Darcs.Repository.HashedRepo as HashedRepo ( readRepo ) -import qualified Darcs.Repository.Old as Old ( readOldRepo ) -import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) -import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) - - --- @todo: we should not have to open the result of HashedRepo and --- seal it. Instead, update this function to work with type witnesses --- by fixing DarcsRepo to match HashedRepo in the handling of --- Repository state. -readRepo :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT - -> IO (PatchSet p Origin wR) -readRepo repo@(Repo r rf _ _) - | formatHas HashedInventory rf = HashedRepo.readRepo repo r - | otherwise = do Sealed ps <- Old.readOldRepo r - return $ unsafeCoerceP ps diff --git a/src/Darcs/Repository/Rebase.hs b/src/Darcs/Repository/Rebase.hs --- a/src/Darcs/Repository/Rebase.hs +++ b/src/Darcs/Repository/Rebase.hs @@ -3,34 +3,36 @@ -- BSD3 {-# LANGUAGE CPP #-} module Darcs.Repository.Rebase - ( - withManualRebaseUpdate + ( RebaseJobFlags(..) + , withManualRebaseUpdate , rebaseJob , startRebaseJob - , repoJobOnRebaseRepo + , maybeDisplaySuspendedStatus ) where +import Prelude () +import Darcs.Prelude + import Darcs.Util.Global ( darcsdir ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.CommuteFn ( commuterIdRL ) import Darcs.Patch.Commute ( selfCommuter ) +import Darcs.Patch.Named.Wrapped ( WrappedNamed(..), mkRebase ) import Darcs.Patch.PatchInfoAnd ( n2pia, hopefully ) -import Darcs.Patch.Rebase ( RebaseFixup - , Rebasing - , mkSuspended - , takeHeadRebase - , takeAnyRebase - , takeAnyRebaseAndTrailingPatches - , countToEdit - ) -import Darcs.Patch.Rebase.Recontext ( RecontextRebase(..) - , RecontextRebase1(..) - , RecontextRebase2(..) - ) +import Darcs.Patch.Rebase + ( takeHeadRebase + , takeAnyRebase + , takeAnyRebaseAndTrailingPatches + ) +import Darcs.Patch.Rebase.Container ( Suspended(..), countToEdit, simplifyPushes ) +import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) ) import Darcs.Patch.RepoPatch ( RepoPatch ) +import Darcs.Patch.RepoType + ( RepoType(..), IsRepoType(..), SRepoType(..) + , RebaseType(..), SRebaseType(..) + ) import Darcs.Patch.Set ( PatchSet(..) ) -import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), RL(..), reverseRL ) @@ -64,66 +66,64 @@ ) import Darcs.Repository.InternalTypes ( Repository(..) ) +import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) ) import Darcs.Util.Progress ( debugMessage ) -import Storage.Hashed.Tree ( Tree ) +import Darcs.Util.Tree ( Tree ) -import Control.Applicative ( (<$>) ) import Control.Exception ( finally ) import System.FilePath.Posix ( () ) #include "impossible.h" +-- | Some common flags that are needed to run rebase jobs. +-- Normally flags are captured directly by the implementation of the specific +-- job's function, but the rebase infrastructure needs to do work on the repository +-- directly that sometimes needs these options, so they have to be passed +-- as part of the job definition. +data RebaseJobFlags = + RebaseJobFlags + { rjoCompression :: Compression + , rjoVerbosity :: Verbosity + , rjoUpdateWorking :: UpdateWorking + } + withManualRebaseUpdate - :: forall p x wR wU wT1 wT2 - . (RepoPatch p, ApplyState p ~ Tree) - => Compression - -> Verbosity - -> UpdateWorking - -> Repository p wR wU wT1 - -> (Repository p wR wU wT1 -> IO (Repository p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x)) - -> IO (Repository p wR wU wT2, x) -withManualRebaseUpdate compr verb uw r subFunc - | Just (RecontextRebase1 recontext1) <- recontextRebase :: Maybe (RecontextRebase1 p) + :: forall rt p x wR wU wT1 wT2 + . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => RebaseJobFlags + -> Repository rt p wR wU wT1 + -> (Repository rt p wR wU wT1 -> IO (Repository rt p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x)) + -> IO (Repository rt p wR wU wT2, x) +withManualRebaseUpdate (RebaseJobFlags compr verb uw) r subFunc + | SRepoType SIsRebase <- singletonRepoType :: SRepoType rt = do patches <- readTentativeRepo r - let go :: PatchSet p wS wT1 -> IO (Repository p wR wU wT2, x) - go (PatchSet NilRL _) = bug "trying to recontext rebase without rebase patch at head (tag)" - go (PatchSet (q :<: _) _) = - case recontext1 (hopefully q) of - (NotEq, _) -> bug "trying to recontext rebase without rebase patch at head (not match)" - (IsEq, recontext2) -> do - r' <- tentativelyRemovePatches r compr uw (q :>: NilFL) - (r'', fixups, x) <- subFunc r' - q' <- n2pia <$> recontextFunc2 recontext2 fixups - r''' <- tentativelyAddPatch r'' compr verb uw q' - return (r''', x) + let go :: PatchSet rt p wS wT1 -> IO (Repository rt p wR wU wT2, x) + go (PatchSet _ NilRL) = bug "trying to recontext rebase without rebase patch at head (tag)" + go (PatchSet _ (_ :<: q)) = + case hopefully q of + NormalP {} -> + bug "trying to recontext rebase without a rebase patch at head (not match)" + RebaseP _ s -> do + r' <- tentativelyRemovePatches r compr uw (q :>: NilFL) + (r'', fixups, x) <- subFunc r' + q' <- n2pia <$> mkRebase (simplifyPushes D.MyersDiff fixups s) + r''' <- tentativelyAddPatch r'' compr verb uw q' + return (r''', x) go patches -withManualRebaseUpdate _compr _verb _uw r subFunc +withManualRebaseUpdate _flags r subFunc = do (r', _, x) <- subFunc r return (r', x) - --- got a normal darcs operation to run on a repo that happens to have a rebase in progress -repoJobOnRebaseRepo :: (RepoPatch p, ApplyState p ~ Tree) - => (Repository (Rebasing p) wR wU wR -> IO a) - -> Repository (Rebasing p) wR wU wR - -> IO a -repoJobOnRebaseRepo job repo = do - res <- job repo -- TODO can we munge the repo here to hide the rebase patch? - displaySuspendedStatus repo - return res - -- got a rebase operation to run where it is required that a rebase is already in progress rebaseJob :: (RepoPatch p, ApplyState p ~ Tree) - => (Repository (Rebasing p) wR wU wR -> IO a) - -> Repository (Rebasing p) wR wU wR - -> Compression - -> Verbosity - -> UpdateWorking + => (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a) + -> Repository ('RepoType 'IsRebase) p wR wU wR + -> RebaseJobFlags -> IO a -rebaseJob job repo compr verb uw = do - repo' <- moveRebaseToEnd repo compr verb uw +rebaseJob job repo flags = do + repo' <- moveRebaseToEnd repo flags job repo' -- the use of finally here is because various things in job -- might cause an "expected" early exit leaving us needing @@ -135,27 +135,23 @@ -- The better fix would be to standardise expected early exits -- e.g. using a layer on top of IO or a common Exception type -- and then just catch those. - `finally` checkSuspendedStatus repo' compr verb uw + `finally` checkSuspendedStatus repo' flags -- got a rebase operation to run where we may need to initialise the rebase state first startRebaseJob :: (RepoPatch p, ApplyState p ~ Tree) - => (Repository (Rebasing p) wR wU wR -> IO a) - -> Repository (Rebasing p) wR wU wR - -> Compression - -> Verbosity - -> UpdateWorking + => (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a) + -> Repository ('RepoType 'IsRebase) p wR wU wR + -> RebaseJobFlags -> IO a -startRebaseJob job repo compr verb uw = do - repo' <- startRebaseIfNecessary repo compr verb uw - rebaseJob job repo' compr verb uw +startRebaseJob job repo flags = do + repo' <- startRebaseIfNecessary repo flags + rebaseJob job repo' flags checkSuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree) - => Repository (Rebasing p) wR wU wR - -> Compression - -> Verbosity - -> UpdateWorking + => Repository ('RepoType 'IsRebase) p wR wU wR + -> RebaseJobFlags -> IO () -checkSuspendedStatus repo@(Repo _ rf _ _) compr verb uw = do +checkSuspendedStatus repo@(Repo _ rf _ _) flags@(RebaseJobFlags compr _verb uw) = do allpatches <- readRepo repo (_, Sealed2 ps) <- return $ takeAnyRebase allpatches case countToEdit ps of @@ -164,7 +160,7 @@ -- this shouldn't actually be necessary since the count should -- only go to zero after an actual rebase operation which would -- leave the patch at the end anyway, but be defensive. - repo' <- moveRebaseToEnd repo compr verb uw + repo' <- moveRebaseToEnd repo flags revertRepositoryChanges repo' uw -- in theory moveRebaseToEnd could just return the commuted one, -- but since the repository has been committed and re-opened @@ -177,12 +173,10 @@ n -> putStrLn $ "Rebase in progress: " ++ show n ++ " suspended patches" moveRebaseToEnd :: (RepoPatch p, ApplyState p ~ Tree) - => Repository (Rebasing p) wR wU wR - -> Compression - -> Verbosity - -> UpdateWorking - -> IO (Repository (Rebasing p) wR wU wR) -moveRebaseToEnd repo compr verb uw = do + => Repository ('RepoType 'IsRebase) p wR wU wR + -> RebaseJobFlags + -> IO (Repository ('RepoType 'IsRebase) p wR wU wR) +moveRebaseToEnd repo (RebaseJobFlags compr verb uw) = do allpatches <- readRepo repo case takeAnyRebaseAndTrailingPatches allpatches of FlippedSeal (_ :> NilRL) -> return repo -- already at head @@ -197,26 +191,30 @@ finalizeRepositoryChanges repo'''' uw compr return repo'''' -displaySuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree) => Repository (Rebasing p) wR wU wR -> IO () +displaySuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wR -> IO () displaySuspendedStatus repo = do allpatches <- readRepo repo (_, Sealed2 ps) <- return $ takeAnyRebase allpatches putStrLn $ "Rebase in progress: " ++ show (countToEdit ps) ++ " suspended patches" +maybeDisplaySuspendedStatus + :: (RepoPatch p, ApplyState p ~ Tree) + => SRebaseType rebaseType -> Repository ('RepoType rebaseType) p wR wU wR -> IO () +maybeDisplaySuspendedStatus SIsRebase repo = displaySuspendedStatus repo +maybeDisplaySuspendedStatus SNoRebase _ = return () + startRebaseIfNecessary :: (RepoPatch p, ApplyState p ~ Tree) - => Repository (Rebasing p) wR wU wT - -> Compression - -> Verbosity - -> UpdateWorking - -> IO (Repository (Rebasing p) wR wU wT) -startRebaseIfNecessary repo@(Repo _ rf _ _) compr verb uw = + => Repository ('RepoType 'IsRebase) p wR wU wT + -> RebaseJobFlags + -> IO (Repository ('RepoType 'IsRebase) p wR wU wT) +startRebaseIfNecessary repo@(Repo _ rf _ _) (RebaseJobFlags compr verb uw) = if formatHas RebaseInProgress rf then return repo else do -- TODO this isn't under the repo lock, and it should be writeRepoFormat (addToFormat RebaseInProgress rf) (darcsdir "format") debugMessage "Writing the rebase patch file..." revertRepositoryChanges repo uw - mypatch <- mkSuspended NilFL + mypatch <- mkRebase (Items NilFL) repo' <- tentativelyAddPatch_ UpdatePristine repo compr verb uw $ n2pia mypatch finalizeRepositoryChanges repo' uw compr return repo' diff --git a/src/Darcs/Repository/Repair.hs b/src/Darcs/Repository/Repair.hs --- a/src/Darcs/Repository/Repair.hs +++ b/src/Darcs/Repository/Repair.hs @@ -5,11 +5,11 @@ RepositoryConsistency(..) ) where -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude import Control.Monad ( when, unless ) import Control.Monad.Trans ( liftIO ) -import Control.Applicative( (<$>) ) import Control.Exception ( catch, finally, IOException ) import Data.Maybe ( catMaybes ) import Data.List ( sort, (\\) ) @@ -28,8 +28,7 @@ import Darcs.Patch.Repair ( Repair(applyAndTryToFix) ) import Darcs.Patch.Info ( showPatchInfoUI ) import Darcs.Patch.Set ( Origin, PatchSet(..), newset2FL, newset2RL ) -import Darcs.Patch ( RepoPatch, PrimOf, isInconsistent ) -import Darcs.Patch.Named ( patchcontents ) +import Darcs.Patch ( RepoPatch, IsRepoType, PrimOf, isInconsistent ) import Darcs.Repository.Flags ( Verbosity(..), Compression, DiffAlgorithm ) @@ -52,33 +51,33 @@ import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Exception ( catchall ) import Darcs.Util.Global ( darcsdir ) -import Darcs.Repository.Lock( rmRecursive, withTempDir ) +import Darcs.Util.Lock( rmRecursive, withTempDir ) import Darcs.Util.Printer ( Doc, putDocLn, text, RenderMode(..) ) import Darcs.Util.Printer.Color ( showDoc ) -import Storage.Hashed.Monad( TreeIO ) -import Storage.Hashed.Darcs( darcsUpdateHashes, hashedTreeIO ) -import Storage.Hashed.Hash( Hash(NoHash), encodeBase16 ) -import Storage.Hashed.Tree( Tree, emptyTree, list, restrict, expand, itemHash, zipTrees ) -import Storage.Hashed.Index( updateIndex ) -import Storage.Hashed( readPlainTree ) +import Darcs.Util.Hash( Hash(NoHash), encodeBase16 ) +import Darcs.Util.Tree( Tree, emptyTree, list, restrict, expand, itemHash, zipTrees ) +import Darcs.Util.Tree.Monad( TreeIO ) +import Darcs.Util.Tree.Hashed( darcsUpdateHashes, hashedTreeIO ) +import Darcs.Util.Tree.Plain( readPlainTree ) +import Darcs.Util.Index( updateIndex ) import qualified Data.ByteString.Char8 as BS #include "impossible.h" -replaceInFL :: FL (PatchInfoAnd a) wX wY - -> [Sealed2 (WPatchInfo :||: PatchInfoAnd a)] - -> FL (PatchInfoAnd a) wX wY +replaceInFL :: FL (PatchInfoAnd rt a) wX wY + -> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)] + -> FL (PatchInfoAnd rt a) wX wY replaceInFL orig [] = orig replaceInFL NilFL _ = impossible replaceInFL (o:>:orig) ch@(Sealed2 (o':||:c):ch_rest) | IsEq <- winfo o `compareWPatchInfo` o' = c:>:replaceInFL orig ch_rest | otherwise = o:>:replaceInFL orig ch -applyAndFix :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> Compression -> FL (PatchInfoAnd p) Origin wR - -> TreeIO (FL (PatchInfoAnd p) Origin wR, Bool) +applyAndFix :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> Compression -> FL (PatchInfoAnd rt p) Origin wR + -> TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool) applyAndFix _ _ NilFL = return (NilFL, True) applyAndFix r@(Repo r' _ _ c) compr psin = do liftIO $ beginTedious k @@ -88,11 +87,11 @@ orig <- liftIO $ newset2FL `fmap` readRepo r return (replaceInFL orig repaired, ok) where k = "Replaying patch" - aaf :: FL (PatchInfoAnd p) wW wZ -> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd p)], Bool) + aaf :: FL (PatchInfoAnd rt p) wW wZ -> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool) aaf NilFL = return ([], True) aaf (p:>:ps) = do mp' <- applyAndTryToFix p - case isInconsistent . patchcontents . hopefully $ p of + case isInconsistent . hopefully $ p of Just err -> liftIO $ putDocLn err Nothing -> return () let !winfp = winfo p -- assure that 'p' can be garbage collected. @@ -104,13 +103,13 @@ p' <- withCurrentDirectory r' $ writeAndReadPatch c compr pp return (Sealed2 (winfp :||: p'):ps', False) -data RepositoryConsistency p wX = +data RepositoryConsistency rt p wX = RepositoryConsistent | BrokenPristine (Tree IO) - | BrokenPatches (Tree IO) (PatchSet p Origin wX) + | BrokenPatches (Tree IO) (PatchSet rt p Origin wX) -checkUniqueness :: (RepoPatch p, ApplyState p ~ Tree) - => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p wR wU wT -> IO () +checkUniqueness :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository rt p wR wU wT -> IO () checkUniqueness putVerbose putInfo repository = do putVerbose $ text "Checking that patch names are unique..." r <- readRepo repository @@ -127,8 +126,8 @@ hd (x1:x2:xs) | x1 == x2 = Just x1 | otherwise = hd (x2:xs) replayRepository' :: - forall p wR wU wT . (RepoPatch p, ApplyState p ~ Tree) - => DiffAlgorithm -> AbsolutePath -> Repository p wR wU wT -> Compression -> Verbosity -> IO (RepositoryConsistency p wR) + forall rt p wR wU wT . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => DiffAlgorithm -> AbsolutePath -> Repository rt p wR wU wT -> Compression -> Verbosity -> IO (RepositoryConsistency rt p wR) replayRepository' dflag whereToReplay' repo compr verbosity = do let whereToReplay = toFilePath whereToReplay' putVerbose s = when (verbosity == Verbose) $ putDocLn s @@ -145,7 +144,7 @@ ((ps, patches_ok), newpris) <- hashedTreeIO repair emptyTree whereToReplay debugMessage "Done fixing broken patches..." - let newpatches = PatchSet (reverseFL ps) NilRL + let newpatches = PatchSet NilRL (reverseFL ps) debugMessage "Checking pristine against slurpy" ftf <- filetypeFunction @@ -160,7 +159,7 @@ then BrokenPristine newpris else BrokenPatches newpris newpatches) -cleanupRepositoryReplay :: Repository p wR wU wT -> IO () +cleanupRepositoryReplay :: Repository rt p wR wU wT -> IO () cleanupRepositoryReplay r = do let c = extractCache r rf <- identifyRepoFormat "." @@ -170,18 +169,18 @@ current <- readHashedPristineRoot r cleanHashdir c HashedPristineDir $ catMaybes [current] -replayRepositoryInTemp :: (RepoPatch p, ApplyState p ~ Tree) - => DiffAlgorithm -> Repository p wR wU wT -> Compression -> Verbosity - -> IO (RepositoryConsistency p wR) +replayRepositoryInTemp :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => DiffAlgorithm -> Repository rt p wR wU wT -> Compression -> Verbosity + -> IO (RepositoryConsistency rt p wR) replayRepositoryInTemp dflag r compr verb = do repodir <- getCurrentDirectory withTempDir "darcs-check" $ \tmpDir -> do setCurrentDirectory repodir replayRepository' dflag tmpDir r compr verb -replayRepository :: (RepoPatch p, ApplyState p ~ Tree) - => DiffAlgorithm -> Repository p wR wU wT -> Compression -> Verbosity - -> (RepositoryConsistency p wR -> IO a) -> IO a +replayRepository :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => DiffAlgorithm -> Repository rt p wR wU wT -> Compression -> Verbosity + -> (RepositoryConsistency rt p wR -> IO a) -> IO a replayRepository dflag r compr verb f = run `finally` cleanupRepositoryReplay r where run = do @@ -190,7 +189,7 @@ st <- replayRepository' dflag hashedPristine r compr verb f st -checkIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Bool -> IO Bool +checkIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> Bool -> IO Bool checkIndex repo quiet = do index <- updateIndex =<< readIndex repo pristine <- expand =<< readRecordedAndPending repo diff --git a/src/Darcs/Repository/Resolution.hs b/src/Darcs/Repository/Resolution.hs --- a/src/Darcs/Repository/Resolution.hs +++ b/src/Darcs/Repository/Resolution.hs @@ -24,6 +24,9 @@ , patchsetConflictResolutions ) where +import Prelude () +import Darcs.Prelude + import System.FilePath.Posix ( () ) import System.Exit ( ExitCode( ExitSuccess ) ) import System.Directory ( setCurrentDirectory, getCurrentDirectory ) @@ -32,10 +35,11 @@ import Darcs.Repository.Diff( treeDiff ) import Darcs.Patch ( PrimOf, PrimPatch, RepoPatch, resolveConflicts, - effectOnFilePaths, patchcontents, + effectOnFilePaths, invert, listConflictedFiles, commute, applyToTree, fromPrim ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts ) +import Darcs.Patch.Named.Wrapped ( activecontents ) import Darcs.Patch.Prim ( PrimPatchBase ) import Darcs.Util.Path ( toFilePath, filterFilePaths ) import Darcs.Patch.Witnesses.Ordered @@ -49,12 +53,12 @@ import Darcs.Patch.Set ( PatchSet(..), Origin ) import Darcs.Repository.Prefs ( filetypeFunction ) import Darcs.Util.Exec ( exec, Redirect(..) ) -import Darcs.Repository.Lock ( withTempDir ) -import Darcs.Repository.External ( cloneTree ) +import Darcs.Util.Lock ( withTempDir ) +import Darcs.Util.External ( cloneTree ) import Darcs.Repository.Flags ( WantGuiPause(..), DiffAlgorithm(..) ) -import qualified Storage.Hashed.Tree as Tree -import Storage.Hashed ( writePlainTree, readPlainTree ) +import qualified Darcs.Util.Tree as Tree +import Darcs.Util.Tree.Plain ( writePlainTree, readPlainTree ) --import Darcs.Util.Printer.Color ( traceDoc ) --import Darcs.Util.Printer ( greenText, ($$), Doc ) @@ -62,7 +66,7 @@ standardResolution :: (PrimPatchBase p, Conflict p, CommuteNoConflicts p) => FL p wX wY -> Sealed (FL (PrimOf p) wY) -standardResolution p = mergeList $ map head $ resolveConflicts p +standardResolution = mergeList . map head . resolveConflicts mergeList :: forall prim wX . PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (FL prim wX) mergeList = doml NilFL @@ -148,14 +152,14 @@ exec command args (Null,Null,Null) rr [] = return ExitSuccess -patchsetConflictResolutions :: RepoPatch p => PatchSet p Origin wX -> Sealed (FL (PrimOf p) wX) -patchsetConflictResolutions (PatchSet NilRL _) = Sealed NilFL -patchsetConflictResolutions (PatchSet xs _) +patchsetConflictResolutions :: RepoPatch p => PatchSet rt p Origin wX -> Sealed (FL (PrimOf p) wX) +patchsetConflictResolutions (PatchSet _ NilRL) = Sealed NilFL +patchsetConflictResolutions (PatchSet _ xs) = --traceDoc (greenText "looking at resolutions" $$ -- (sh $ resolveConflicts $ joinPatches $ -- mapFL_FL (patchcontents . hopefully) $ reverseRL xs )) $ - mergeList $ map head $ resolveConflicts $ concatFL $ - mapFL_FL (patchcontents . hopefully) $ reverseRL xs + standardResolution $ concatFL $ + mapFL_FL (activecontents . hopefully) $ reverseRL xs --where sh :: [[Sealed (FL Prim)]] -> Doc -- sh [] = greenText "no more conflicts" -- sh (x:ps) = greenText "one conflict" $$ sh1 x $$ sh ps diff --git a/src/Darcs/Repository/Ssh.hs b/src/Darcs/Repository/Ssh.hs deleted file mode 100644 --- a/src/Darcs/Repository/Ssh.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | --- Module : Darcs.Repository.Ssh --- Maintainer : darcs-devel@darcs.net --- Stability : experimental --- Portability : portable - -module Darcs.Repository.Ssh - ( - copySSH - , SSHCmd(..) - , getSSH - , environmentHelpSsh - , environmentHelpScp - , environmentHelpSshPort - , remoteDarcs - ) where - - -import Prelude hiding ( lookup, catch ) - -import System.Environment ( getEnv ) -import System.Exit ( ExitCode(..) ) - -import Control.Exception ( throwIO ) -import Control.Monad ( unless, (>=>) ) -import Control.Monad.IO.Class ( liftIO ) - -import qualified Data.ByteString as B (ByteString, hGet, writeFile ) - -import Data.Map ( Map, empty, insert, lookup ) -import Data.IORef ( IORef, newIORef, readIORef, modifyIORef ) - -import System.IO ( Handle, hSetBinaryMode, hPutStrLn, hGetLine, hFlush ) -import System.IO.Unsafe ( unsafePerformIO ) -import System.Process ( runInteractiveProcess ) - -import Darcs.Util.SignalHandler ( catchNonSignal ) -import Darcs.Repository.Flags( RemoteDarcs(..) ) -import Darcs.Util.Ssh ( defaultSsh, SshSettings) -import Darcs.Util.URL (SshFilePath(..), urlOf) -import Darcs.Util.Text ( breakCommand ) -import Darcs.Util.Exception ( prettyException, catchall ) -import Darcs.Util.Exec ( readInteractiveProcess, ExecException(..), Redirect(AsIs) ) -import Darcs.Util.Progress ( withoutProgress, debugMessage, debugFail ) - -import qualified Darcs.Util.Ssh as Settings -import qualified Darcs.Util.Ratified as Ratified ( hGetContents ) - -sshConnections :: IORef (Map String (Maybe Connection)) -sshConnections = unsafePerformIO $ newIORef empty -{-# NOINLINE sshConnections #-} - - -data Connection = C - { inp :: !Handle - , out :: !Handle - , err :: !Handle - , deb :: String - } - - --- | @withSSHConnection rdarcs repoid withconnection withoutconnection@ --- performs an action on a remote host. If we are already connected to @repoid @, --- then it does @withconnection@, else @withoutconnection@. -withSSHConnection :: String -- ^ rdarcs - -> SshFilePath -- ^ Destination repo id - -> (Connection -> IO a) -- ^ withconnection - -> IO a -- ^ withoutconnection - -> IO a -withSSHConnection rdarcs repoid withconnection withoutconnection = - withoutProgress $ - do cs <- liftIO $ readIORef sshConnections - case lookup (sshUhost repoid) (cs :: Map String (Maybe Connection)) of - Just Nothing -> withoutconnection - Just (Just c) -> withconnection c - Nothing -> - do mc <- do (ssh,sshargs_) <- liftIO $ getSSH SSH - let sshargs = sshargs_ ++ [sshUhost repoid, rdarcs, - "transfer-mode","--repodir",sshRepo repoid] - liftIO $ debugMessage $ unwords (ssh : sshargs) - (i,o,e,_) <- liftIO $ runInteractiveProcess ssh sshargs Nothing Nothing - liftIO $ (do - hSetBinaryMode i True - hSetBinaryMode o True - l <- hGetLine o - unless (l == "Hello user, I am darcs transfer mode") $ - debugFail "Couldn't start darcs transfer-mode on server" - let c = C { inp = i, out = o, err = e, - deb = "with ssh (transfer-mode) " ++ sshUhost repoid } - modifyIORef sshConnections (insert (sshUhost repoid) (Just c)) - return $ Just c) `catchNonSignal` - \exn -> do - debugMessage $ "Failed to start ssh connection:\n "++ - prettyException exn - severSSHConnection repoid - debugMessage $ unlines - [ "NOTE: the server may be running a version of darcs prior to 2.0.0." - , "" - , "Installing darcs 2 on the server will speed up ssh-based commands." - ] - return Nothing - maybe withoutconnection withconnection mc - -severSSHConnection :: SshFilePath - -> IO () -severSSHConnection x = do - debugMessage $ "Severing ssh failed connection to " ++ sshUhost x - modifyIORef sshConnections (insert (urlOf x) Nothing) - - -grabSSH :: SshFilePath -> Connection -> IO B.ByteString -grabSSH dest c = do - debugMessage $ "grabSSH dest=" ++ urlOf dest - let failwith e = do severSSHConnection dest - -- hGetContents is ok here because we're - -- only grabbing stderr, and we're also - -- about to throw the contents. - eee <- Ratified.hGetContents (err c) - debugFail $ e ++ " grabbing ssh file "++ - urlOf dest++"/"++ file ++"\n"++eee - file = sshFile dest - debugMessage (deb c ++ " get "++ file) - hPutStrLn (inp c) $ "get " ++ file - hFlush (inp c) - l2 <- hGetLine (out c) - if l2 == "got "++file - then do showlen <- hGetLine (out c) - case reads showlen of - [(len,"")] -> B.hGet (out c) len - _ -> failwith "Couldn't get length" - else if l2 == "error "++file - then do e <- hGetLine (out c) - case reads e of - (msg,_):_ -> debugFail $ "Error reading file remotely:\n"++msg - [] -> failwith "An error occurred" - else failwith "Error" - -remoteDarcs :: RemoteDarcs - -> String -remoteDarcs DefaultRemoteDarcs = "darcs" -remoteDarcs (RemoteDarcs x) = x - - -copySSH :: RemoteDarcs - -> SshFilePath - -> FilePath - -> IO () -copySSH remote dest to | rdarcs <- remoteDarcs remote = do - debugMessage $ "copySSH file: " ++ urlOf dest - withSSHConnection rdarcs dest (grabSSH dest >=> B.writeFile to) $ do - let u = escape_dollar $ urlOf dest - (scp, args) <- getSSH SCP - let scp_args = filter (/="-q") args ++ [u, to] - (r, scp_err) <- readInteractiveProcess scp scp_args - unless (r == ExitSuccess) $ - throwIO $ ExecException scp scp_args (AsIs,AsIs,AsIs) scp_err - where - -- '$' in filenames is troublesome for scp, for some reason. - escape_dollar :: String -> String - escape_dollar = concatMap tr - where - tr '$' = "\\$" - tr c = [c] - - --- --------------------------------------------------------------------- --- older ssh helper functions --- --------------------------------------------------------------------- - -data SSHCmd = SSH - | SCP - | SFTP - - -fromSshCmd :: SshSettings - -> SSHCmd - -> String -fromSshCmd s SSH = Settings.ssh s -fromSshCmd s SCP = Settings.scp s -fromSshCmd s SFTP = Settings.sftp s - - --- | Return the command and arguments needed to run an ssh command --- First try the appropriate darcs environment variable and SSH_PORT --- defaulting to "ssh" and no specified port. -getSSH :: SSHCmd - -> IO (String, [String]) -getSSH cmd = do - port <- (portFlag cmd `fmap` getEnv "SSH_PORT") `catchall` return [] - let (ssh, ssh_args) = breakCommand command - return (ssh, ssh_args ++ port) - where - command = fromSshCmd defaultSsh cmd - portFlag SSH x = ["-p", x] - portFlag SCP x = ["-P", x] - portFlag SFTP x = ["-oPort=" ++ x] - - -environmentHelpSsh :: ([String], [String]) -environmentHelpSsh = (["DARCS_SSH"], [ - "Repositories of the form [user@]host:[dir] are taken to be remote", - "repositories, which Darcs accesses with the external program ssh(1).", - "", - "The environment variable $DARCS_SSH can be used to specify an", - "alternative SSH client. Arguments may be included, separated by", - "whitespace. The value is not interpreted by a shell, so shell", - "constructs cannot be used; in particular, it is not possible for the", - "program name to contain whitespace by using quoting or escaping."]) - - -environmentHelpScp :: ([String], [String]) -environmentHelpScp = (["DARCS_SCP", "DARCS_SFTP"], [ - "When reading from a remote repository, Darcs will attempt to run", - "`darcs transfer-mode` on the remote host. This will fail if the", - "remote host only has Darcs 1 installed, doesn't have Darcs installed", - "at all, or only allows SFTP.", - "", - "If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).", - "The commands invoked can be customized with the environment variables", - "$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.", - "If the remote end allows only sftp, try setting DARCS_SCP=sftp."]) - - -environmentHelpSshPort :: ([String], [String]) -environmentHelpSshPort = (["SSH_PORT"], [ - "If this environment variable is set, it will be used as the port", - "number for all SSH calls made by Darcs (when accessing remote", - "repositories over SSH). This is useful if your SSH server does not", - "run on the default port, and your SSH client does not support", - "ssh_config(5). OpenSSH users will probably prefer to put something", - "like `Host *.example.net Port 443` into their ~/.ssh/config file."]) diff --git a/src/Darcs/Repository/State.hs b/src/Darcs/Repository/State.hs --- a/src/Darcs/Repository/State.hs +++ b/src/Darcs/Repository/State.hs @@ -1,7 +1,5 @@ -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-} -{-# LANGUAGE CPP #-} - -- Copyright (C) 2009 Petr Rockai +-- (C) 2012 José Neder -- -- Permission is hereby granted, free of charge, to any person -- obtaining a copy of this software and associated documentation @@ -25,68 +23,81 @@ module Darcs.Repository.State ( restrictSubpaths, restrictBoring, TreeFilter(..), restrictDarcsdir - -- * Diffs. + , maybeRestrictSubpaths + -- * Diffs , unrecordedChanges, unrecordedChangesWithPatches, readPending - -- * Trees. + -- * Trees , readRecorded, readUnrecorded, readRecordedAndPending, readWorking - , readPendingAndWorking - -- * Index. + , readPendingAndWorking, readUnrecordedFiltered + -- * Index , readIndex, updateIndex, invalidateIndex, UseIndex(..), ScanKnown(..) -- * Utilities , filterOutConflicts - -- * Patches - , repoXor ) where + -- * Detection of changes + , getMovesPs, getReplaces + ) where -import Prelude hiding ( filter, catch ) -import Control.Monad( when ) -import Control.Applicative( (<$>) ) +import Prelude () +import Darcs.Prelude + +import Control.Monad( when, foldM ) import Control.Exception ( catch, IOException ) -import Data.Maybe( isJust ) -import Data.List( union, foldl' ) +import Data.Maybe ( isJust, fromJust ) +import Data.Ord ( comparing ) +import Data.List ( sortBy, union, delete ) import Text.Regex( matchRegex ) import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile ) import System.FilePath ( () ) -import qualified Data.ByteString as BS - ( readFile, drop, writeFile, empty ) -import qualified Data.ByteString.Char8 as BSC - ( pack, split ) +import qualified Data.ByteString as B + ( readFile, drop, writeFile, empty, concat ) +import qualified Data.ByteString.Char8 as BC + ( pack, unpack, split ) +import qualified Data.ByteString.Lazy as BL ( toChunks ) -import Darcs.Patch ( RepoPatch, PrimOf, sortCoalesceFL, fromPrim, fromPrims - , effect, anonymous ) +import Darcs.Patch ( effect, RepoPatch, PrimOf, sortCoalesceFL, fromPrim, fromPrims + , PrimPatch, primIsHunk, maybeApplyToTree + , tokreplace, forceTokReplace, move ) +import Darcs.Patch.Named.Wrapped ( anonymous ) import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnFilePaths ) import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), (+>+), mapFL_FL - , (:>)(..), mapRL ) + , (:>)(..), reverseRL, reverseFL + , mapFL, concatFL, toFL ) import Darcs.Patch.Witnesses.Eq ( EqCheck(IsEq, NotEq) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft, mapSeal ) +import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft, mapSeal + , freeGap, emptyGap, joinGap, FreeLeft, Gap(..) ) import Darcs.Patch.Commute ( selfCommuter ) import Darcs.Patch.CommuteFn ( commuterIdRL ) -import Darcs.Patch.Permutations ( partitionConflictingFL ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, info ) -import Darcs.Patch.Info ( makePatchname ) -import Darcs.Patch.Set ( newset2RL ) +import Darcs.Patch.Permutations ( partitionConflictingFL, partitionRL ) +import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia ) +import Darcs.Patch.Prim.V1 () -- instances Commute Prim and PrimPatch Prim +import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk ), Prim(..) ) +import Darcs.Patch.Prim.Class ( PrimConstruct, PrimCanonize ) +import Darcs.Patch.TokenReplace ( breakToTokens, defaultToks ) import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(..) ) import Darcs.Util.Global ( darcsdir ) -import Darcs.Util.Crypt.SHA1 ( SHA1, sha1Xor, zero ) import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Repository.Format(formatHas, RepoProperty(NoWorkingDir)) -import qualified Darcs.Repository.LowLevel as LowLevel +import qualified Darcs.Repository.Pending as Pending import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps ) import Darcs.Repository.Diff ( treeDiff ) -import Darcs.Repository.Read ( readRepo ) import Darcs.Util.Path( AnchoredPath(..), anchorPath, floatPath, Name(..), fn2fp, - SubPath, sp2fn, filterPaths ) -import Storage.Hashed.Tree( Tree, restrict, FilterTree, expand, filter, emptyTree, overlay, find ) -import Storage.Hashed.Plain( readPlainTree ) -import Storage.Hashed.Darcs( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize ) -import Storage.Hashed.Hash( Hash( NoHash ) ) -import qualified Storage.Hashed.Index as I -import qualified Storage.Hashed.Tree as Tree - + SubPath, sp2fn, filterPaths + , parents, replacePrefixPath, anchoredRoot + , toFilePath, simpleSubPath, normPath, floatSubPath ) +import Darcs.Util.Hash( Hash( NoHash ) ) +import Darcs.Util.Tree( Tree, restrict, FilterTree, expand, emptyTree, overlay, find + , ItemType(..), itemType, readBlob, modifyTree, findFile, TreeItem(..) + , makeBlobBS, expandPath ) +import Darcs.Util.Tree.Plain( readPlainTree ) +import Darcs.Util.Tree.Hashed( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize ) +import qualified Darcs.Util.Index as I +import qualified Darcs.Util.Tree as Tree +import Darcs.Util.Index ( listFileIDs, getFileID ) newtype TreeFilter m = TreeFilter { applyTreeFilter :: forall tr . FilterTree tr m => tr m -> tr m } @@ -95,15 +106,15 @@ -- constraint everywhere. When we have GHC 7.2 as a minimum requirement, we can -- lift this constraint into RepoPatch superclass context and remove this hack. readPendingLL :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> IO (Sealed ((FL p) wT)) -readPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` LowLevel.readPending repo + => Repository rt p wR wU wT -> IO (Sealed ((FL p) wT)) +readPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` Pending.readPending repo -- | From a repository and a list of SubPath's, construct a filter that can be -- used on a Tree (recorded or unrecorded state) of this repository. This -- constructed filter will take pending into account, so the subpaths will be -- translated correctly relative to pending move patches. -restrictSubpaths :: forall p m wR wU wT. (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> [SubPath] +restrictSubpaths :: forall rt p m wR wU wT. (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> [SubPath] -> IO (TreeFilter m) restrictSubpaths repo subpaths = do Sealed pending <- readPendingLL repo @@ -111,12 +122,18 @@ paths' = paths `union` effectOnFilePaths pending paths anchored = map floatPath paths' restrictPaths :: FilterTree tree m => tree m -> tree m - restrictPaths = filter (filterPaths anchored) + restrictPaths = Tree.filter (filterPaths anchored) return (TreeFilter restrictPaths) +maybeRestrictSubpaths :: forall rt p m wR wU wT. (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> Maybe [SubPath] + -> IO (TreeFilter m) +maybeRestrictSubpaths repo = maybe (return $ TreeFilter id) (restrictSubpaths repo) + -- |Is the given path in (or equal to) the _darcs metadata directory? inDarcsDir :: AnchoredPath -> Bool -inDarcsDir (AnchoredPath (Name x:_)) | x == BSC.pack darcsdir = True +inDarcsDir (AnchoredPath (Name x:_)) | x == BC.pack darcsdir = True inDarcsDir _ = False -- | Construct a Tree filter that removes any boring files the Tree might have @@ -128,8 +145,7 @@ -- -- This function is most useful when you have a plain Tree corresponding to the -- full working copy of the repository, including untracked --- files. Cf. whatsnew, record --look-for-adds. NB. Assumes that our CWD is --- the repository root. +-- files. Cf. whatsnew, record --look-for-adds. restrictBoring :: forall m . Tree m -> IO (TreeFilter m) restrictBoring guide = do boring <- boringRegexps @@ -137,15 +153,15 @@ boring' p = not $ any (\rx -> isJust $ matchRegex rx p') boring where p' = anchorPath "" p restrictTree :: FilterTree t m => t m -> t m - restrictTree = filter $ \p _ -> case find guide p of - Nothing -> boring' p - _ -> True + restrictTree = Tree.filter $ \p _ -> case find guide p of + Nothing -> boring' p + _ -> True return (TreeFilter restrictTree) -- | Construct a Tree filter that removes any darcs metadata files the -- Tree might have contained. restrictDarcsdir :: forall m . TreeFilter m -restrictDarcsdir = TreeFilter $ filter $ \p _ -> not (inDarcsDir p) +restrictDarcsdir = TreeFilter $ Tree.filter $ \p _ -> not (inDarcsDir p) -- | For a repository and an optional list of paths (when Nothing, take -- everything) compute a (forward) list of prims (i.e. a patch) going from the @@ -167,98 +183,82 @@ -- is very inefficient, although in extremely rare cases, the index could go -- out of sync (file is modified, index is updated and file is modified again -- within a single second). -unrecordedChanges :: forall p wR wU wT . (RepoPatch p, ApplyState p ~ Tree) - => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT +unrecordedChanges :: forall rt p wR wU wT . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository rt p wR wU wT -> Maybe [SubPath] -> IO (FL (PrimOf p) wT wU) -unrecordedChanges opts r paths = do - (pending :> working) <- readPendingAndWorking opts r paths - return $ sortCoalesceFL (pending +>+ working) +unrecordedChanges = unrecordedChangesWithPatches NilFL NilFL -unrecordedChangesWithPatches :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT - -> Maybe [SubPath] - -> FL (PrimOf p) wX wT -- look-for-moves patches +unrecordedChangesWithPatches :: forall rt p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => FL (PrimOf p) wX wT -- look-for-moves patches -> FL (PrimOf p) wT wT -- look-for-replaces patches + -> (UseIndex, ScanKnown, DiffAlgorithm) -> Repository rt p wR wU wT + -> Maybe [SubPath] -> IO (FL (PrimOf p) wT wU) -unrecordedChangesWithPatches opts r paths movesPs replacesPs = do - (pending :> working) <- readPendingAndWorkingWithPatches opts r paths movesPs replacesPs - return $ sortCoalesceFL (pending +>+ unsafeCoerceP (movesPs +>+ replacesPs) +>+ working) +unrecordedChangesWithPatches movPs replPs opts r paths = do + (pending :> working) <- readPendingAndWorkingWithPatches movPs replPs opts r paths + return $ sortCoalesceFL (pending +>+ unsafeCoerceP (movPs +>+ replPs) +>+ working) -- | Mostly a helper function to 'unrecordedChangesWithPatches', returning the pending -- patch plus `patches` and the subsequent diff from working as two different patches -readPendingAndWorkingWithPatches :: forall p wR wU wT wZ. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => (UseIndex, ScanKnown, DiffAlgorithm) - -> Repository p wR wU wT - -> Maybe [SubPath] - -> FL (PrimOf p) wZ wT -- look-for-moves patches +readPendingAndWorkingWithPatches :: forall rt p wR wU wT wZ. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => FL (PrimOf p) wZ wT -- look-for-moves patches -> FL (PrimOf p) wT wT -- look-for-replaces patches + -> (UseIndex, ScanKnown, DiffAlgorithm) + -> Repository rt p wR wU wT + -> Maybe [SubPath] -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU) -readPendingAndWorkingWithPatches _ r@(Repo _ rf _ _) _ _ _ | (formatHas NoWorkingDir rf) = do +readPendingAndWorkingWithPatches _ _ _ r@(Repo _ rf _ _) _ | formatHas NoWorkingDir rf = do IsEq <- return $ workDirLessRepoWitness r return (NilFL :> NilFL) -readPendingAndWorkingWithPatches (useidx', scan, dflag) repo mbpaths movesPs replacesPs = do - let allPatches = movesPs +>+ replacesPs +readPendingAndWorkingWithPatches movPs replPs (useidx', scan, dflag) repo mbpaths = do + let allPatches = movPs +>+ replPs let useidx = case allPatches of NilFL -> useidx' _ -> IgnoreIndex (all_current, Sealed (pending :: FL p wT wX)) <- readPending repo all_current_with_patches <- applyToTree allPatches all_current - relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) mbpaths - let getIndex = applyToTree movesPs =<< I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo) + relevant <- maybeRestrictSubpaths repo mbpaths + let getIndex = applyToTree movPs =<< I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo) current = applyTreeFilter relevant all_current_with_patches - index <- getIndex - working <- applyTreeFilter restrictDarcsdir <$> case scan of - ScanKnown -> case useidx of - UseIndex -> getIndex - IgnoreIndex -> do - guide <- expand current - applyTreeFilter relevant <$> restrict guide <$> readPlainTree "." - ScanAll -> do - nonboring <- restrictBoring index - plain <- applyTreeFilter relevant <$> applyTreeFilter nonboring <$> readPlainTree "." - return $ case useidx of - UseIndex -> plain `overlay` index - IgnoreIndex -> plain - ScanBoring -> do - plain <- applyTreeFilter relevant <$> readPlainTree "." - return $ case useidx of - UseIndex -> plain `overlay` index - IgnoreIndex -> plain - + working <- filteredWorking useidx scan relevant getIndex current ft <- filetypeFunction Sealed (diff :: FL (PrimOf p) wX wY) <- (unFreeLeft `fmap` treeDiff dflag ft current working) :: IO (Sealed (FL (PrimOf p) wX)) IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck wY wU) return (effect pending :> diff) --- | Mostly a helper function to 'unrecordedChanges', returning the pending --- patch and the subsequent diff from working as two different patches -readPendingAndWorking :: forall p wR wU wT . (RepoPatch p, ApplyState p ~ Tree) +readPendingAndWorking :: forall rt p wR wU wT . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => (UseIndex, ScanKnown, DiffAlgorithm) - -> Repository p wR wU wT + -> Repository rt p wR wU wT -> Maybe [SubPath] -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU) -readPendingAndWorking _ r@(Repo _ rf _ _) _ | (formatHas NoWorkingDir rf) = do - IsEq <- return $ workDirLessRepoWitness r - return (NilFL :> NilFL) -readPendingAndWorking (useidx, scan, dflag) repo mbpaths = do - (all_current, Sealed (pending :: FL p wT wX)) <- readPending repo +readPendingAndWorking = readPendingAndWorkingWithPatches NilFL NilFL - relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) mbpaths - let getIndex = I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo) - current = applyTreeFilter relevant all_current +-- | @filteredWorking useidx scan relevant getIndex pending_tree@ reads the +-- working tree and filters it according to options and @relevant@ file paths. +-- The @pending_tree@ is understood to have @relevant@ already applied and is +-- used (only) if @useidx == 'IgnoreIndex'@ and @scan == 'ScanKnown'@ to act as +-- a guide for filtering the working tree. +-- TODO: untangle the arguments and make this more orthogonal +filteredWorking :: UseIndex + -> ScanKnown + -> TreeFilter IO + -> IO (Tree IO) + -> Tree IO + -> IO (Tree IO) +filteredWorking useidx scan relevant getIndex pending_tree = do index <- getIndex - working <- applyTreeFilter restrictDarcsdir <$> case scan of + applyTreeFilter restrictDarcsdir <$> case scan of ScanKnown -> case useidx of UseIndex -> getIndex IgnoreIndex -> do - guide <- expand current - applyTreeFilter relevant <$> restrict guide <$> readPlainTree "." + guide <- expand pending_tree + applyTreeFilter relevant . restrict guide <$> readPlainTree "." ScanAll -> do nonboring <- restrictBoring index - plain <- applyTreeFilter relevant <$> applyTreeFilter nonboring <$> readPlainTree "." + plain <- applyTreeFilter relevant . applyTreeFilter nonboring <$> readPlainTree "." return $ case useidx of UseIndex -> plain `overlay` index IgnoreIndex -> plain @@ -268,14 +268,9 @@ UseIndex -> plain `overlay` index IgnoreIndex -> plain - ft <- filetypeFunction - Sealed (diff :: FL (PrimOf p) wX wY) <- (unFreeLeft `fmap` treeDiff dflag ft current working) :: IO (Sealed (FL (PrimOf p) wX)) - IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck wY wU) - return (effect pending :> diff) - -- | Witnesses the fact that in the absence of a working directory, we -- pretend that the working dir updates magically to the tentative state. -workDirLessRepoWitness :: Repository p wR wU wT -> EqCheck wU wT +workDirLessRepoWitness :: Repository rt p wR wU wT -> EqCheck wU wT workDirLessRepoWitness (Repo _ rf _ _) | formatHas NoWorkingDir rf = unsafeCoerceP IsEq | otherwise = NotEq @@ -283,23 +278,18 @@ -- | Obtains a Tree corresponding to the "recorded" state of the repository: -- this is the same as the pristine cache, which is the same as the result of -- applying all the repository's patches to an empty directory. --- --- Handles the plain and hashed pristine cases. Currently does not handle the --- no-pristine case, as that requires replaying patches. Cf. 'readDarcsHashed' --- and 'readPlainTree' in hashed-storage that are used to do the actual 'Tree' --- construction. -readRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (Tree IO) +readRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO (Tree IO) readRecorded _repo = do let h_inventory = darcsdir "hashed_inventory" hashed <- doesFileExist h_inventory if hashed - then do inv <- BS.readFile h_inventory - let linesInv = BSC.split '\n' inv + then do inv <- B.readFile h_inventory + let linesInv = BC.split '\n' inv case linesInv of [] -> return emptyTree (pris_line:_) -> do - let hash = decodeDarcsHash $ BS.drop 9 pris_line - size = decodeDarcsSize $ BS.drop 9 pris_line + let hash = decodeDarcsHash $ B.drop 9 pris_line + size = decodeDarcsSize $ B.drop 9 pris_line when (hash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line readDarcsHashed (darcsdir "pristine.hashed") (size, hash) else do have_pristine <- doesDirectoryExist $ darcsdir "pristine" @@ -310,32 +300,56 @@ (_, _) -> fail "No pristine tree is available!" -- | Obtains a Tree corresponding to the "unrecorded" state of the repository: --- the working tree plus the "pending" patch. The optional list of paths allows --- to restrict the query to a subtree. +-- the modified files of the working tree plus the "pending" patch. +-- The optional list of paths allows to restrict the query to a subtree. -- -- Limiting the query may be more efficient, since hashes on the uninteresting -- parts of the index do not need to go through an up-to-date check (which -- involves a relatively expensive lstat(2) per file. readUnrecorded :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> Maybe [SubPath] -> IO (Tree IO) + => Repository rt p wR wU wT -> Maybe [SubPath] -> IO (Tree IO) readUnrecorded repo mbpaths = do - relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) mbpaths + relevant <- maybeRestrictSubpaths repo mbpaths readIndex repo >>= I.updateIndex . applyTreeFilter relevant --- | Obtains a Tree corresponding to the working copy of the --- repository. NB. Almost always, using readUnrecorded is the right --- choice. This function is only useful in not-completely-constructed --- repositories. +-- | A variant of 'readUnrecorded' that takes the UseIndex and ScanKnown +-- options into account, similar to 'readPendingAndWorking'. We are only +-- interested in the resulting tree, not the patch, so the 'DiffAlgorithm' option +-- is irrelevant. +readUnrecordedFiltered :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> UseIndex + -> ScanKnown + -> Maybe [SubPath] -> IO (Tree IO) +readUnrecordedFiltered repo useidx scan mbpaths = do + (all_current, _) <- readPending repo -- we have no need for the pending patch + relevant <- maybeRestrictSubpaths repo mbpaths + let getIndex = I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo) + current = applyTreeFilter relevant all_current + filteredWorking useidx scan relevant getIndex current + +-- | Obtains a Tree corresponding to the complete working copy of the +-- repository (modified and non-modified files). readWorking :: IO (Tree IO) readWorking = expand =<< (nodarcs `fmap` readPlainTree ".") - where nodarcs = Tree.filter (\(AnchoredPath (Name x:_)) _ -> x /= BSC.pack darcsdir) + where nodarcs = Tree.filter (\(AnchoredPath (Name x:_)) _ -> x /= BC.pack darcsdir) +-- | Obtains the same Tree as 'readRecorded' would but with the additional side +-- effect of reading/checking the pending patch. readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> IO (Tree IO) + => Repository rt p wR wU wT -> IO (Tree IO) readRecordedAndPending repo = fst `fmap` readPending repo +-- | Obtains a Tree corresponding to the recorded state of the repository +-- and a pending patch to go with it. The pending patch should start at the +-- recorded state (we even verify that it applies, and degrade to +-- renaming pending and starting afresh if it doesn't), but we've set to +-- say it starts at the tentative state. +-- +-- Question (Eric Kow) Is this a bug? Darcs.Repository.Pending.readPending +-- says it is readPending :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> IO (Tree IO, Sealed (FL p wT)) + => Repository rt p wR wU wT -> IO (Tree IO, Sealed (FL p wT)) readPending repo = do Sealed pending <- readPendingLL repo pristine <- readRecorded repo @@ -352,21 +366,16 @@ -- pristine: changes to file content in either pristine or working are handled -- transparently by the index reading code.) invalidateIndex :: t -> IO () -invalidateIndex _ = BS.writeFile (darcsdir "index_invalid") BS.empty +invalidateIndex _ = B.writeFile (darcsdir "index_invalid") B.empty -readIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO I.Index +readIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO I.Index readIndex repo = do invalid <- doesFileExist $ darcsdir "index_invalid" exists <- doesFileExist $ darcsdir "index" formatValid <- if exists then I.indexFormatValid $ darcsdir "index" else return True - when (exists && not formatValid) $ -#if mingw32_HOST_OS - renameFile (darcsdir "index") (darcsdir "index.old") -#else - removeFile $ darcsdir "index" -#endif + when (exists && not formatValid) $ removeFile $ darcsdir "index" if not exists || invalid || not formatValid then do pris <- readRecordedAndPending repo idx <- I.updateIndexFrom (darcsdir "index") darcsTreeHash pris @@ -374,50 +383,178 @@ return idx else I.readIndex (darcsdir "index") darcsTreeHash -updateIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () +updateIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO () updateIndex repo = do invalid <- doesFileExist $ darcsdir "index_invalid" exists <- doesFileExist $ darcsdir "index" formatValid <- if exists then I.indexFormatValid $ darcsdir "index" else return True - when (exists && not formatValid) $ -#if mingw32_HOST_OS - renameFile (darcsdir "index") (darcsdir "index.old") -#else - removeFile $ darcsdir "index" -#endif + when (exists && not formatValid) $ removeFile $ darcsdir "index" pris <- readRecordedAndPending repo _ <- I.updateIndexFrom (darcsdir "index") darcsTreeHash pris when invalid $ removeFile $ darcsdir "index_invalid" -- |Remove any patches (+dependencies) from a sequence that -- conflict with the recorded or unrecorded changes in a repo -filterOutConflicts :: (RepoPatch p, ApplyState p ~ Tree) - => RL (PatchInfoAnd p) wX wT -- ^Recorded patches from repository, starting from +filterOutConflicts :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => RL (PatchInfoAnd rt p) wX wT -- ^Recorded patches from repository, starting from -- same context as the patches to filter - -> Repository p wR wU wT -- ^Repository itself, used for grabbing unrecorded changes - -> FL (PatchInfoAnd p) wX wZ -- ^Patches to filter - -> IO (Bool, Sealed (FL (PatchInfoAnd p) wX)) -- ^(True iff any patches were removed, possibly filtered patches) + -> Repository rt p wR wU wT -- ^Repository itself, used for grabbing unrecorded changes + -> FL (PatchInfoAnd rt p) wX wZ -- ^Patches to filter + -> IO (Bool, Sealed (FL (PatchInfoAnd rt p) wX)) -- ^(True iff any patches were removed, possibly filtered patches) filterOutConflicts us repository them = do let commuter = commuterIdRL selfCommuter unrec <- fmap n2pia . anonymous . fromPrims =<< unrecordedChanges (UseIndex, ScanKnown, MyersDiff) repository Nothing - them' :> rest <- return $ partitionConflictingFL commuter them (unrec :<: us) + them' :> rest <- return $ partitionConflictingFL commuter them (us :<: unrec) return (check rest, Sealed them') where check :: FL p wA wB -> Bool check NilFL = False check _ = True --- | XOR of all hashes of the patches' metadata. --- It enables to quickly see whether two repositories --- have the same patches, independently of their order. --- It relies on the assumption that the same patch cannot --- be present twice in a repository. --- This checksum is not cryptographically secure, --- see http://robotics.stanford.edu/~xb/crypto06b/ . -repoXor :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wR -> IO SHA1 -repoXor repo = do - hashes <- mapRL (makePatchname . info) . newset2RL <$> readRepo repo - return $ foldl' sha1Xor zero hashes +-- |Automatically detect file moves using the index +getMovesPs :: forall rt p wR wU wB prim. + (PrimConstruct prim, PrimCanonize prim, RepoPatch p, + ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => Repository rt p wR wU wR + -> Maybe [SubPath] + -> IO (FL prim wB wB) +getMovesPs repository files = mkMovesFL <$> getMovedFiles repository files + where + mkMovesFL [] = NilFL + mkMovesFL ((a,b,_):xs) = move (anchorPath "" a) (anchorPath "" b) :>: mkMovesFL xs + + getMovedFiles :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => Repository rt p wR wU wR + -> Maybe [SubPath] + -> IO [(AnchoredPath, AnchoredPath, ItemType)] + getMovedFiles repo fs = do + old <- sortBy (comparing snd) <$> (listFileIDs =<< readIndex repo) + nonboring <- restrictBoring emptyTree + let addIDs = foldM (\xs (p, it)-> do mfid <- getFileID p + return $ case mfid of + Nothing -> xs + Just fid -> ((p, it), fid):xs) [] + new <- sortBy (comparing snd) <$> + (addIDs . map (\(a,b) -> (a, itemType b)) . Tree.list =<< + expand =<< applyTreeFilter nonboring <$> readPlainTree ".") + let match (x:xs) (y:ys) | snd x > snd y = match (x:xs) ys + | snd x < snd y = match xs (y:ys) + | snd (fst x) /= snd (fst y) = match xs ys + | otherwise = (fst (fst x), fst (fst y), snd (fst x)):match xs ys + match _ _ = [] + movedfiles = match old new + fmovedfiles = case fs of + Nothing -> movedfiles + Just subpath -> filter (\(f1,f2,_) -> any (`elem` selfiles) [f1,f2]) movedfiles + where selfiles = map (floatPath . toFilePath) subpath + return (resolve fmovedfiles) + + resolve :: [(AnchoredPath, AnchoredPath, ItemType)] -> [(AnchoredPath, AnchoredPath, ItemType)] + resolve xs = fixPaths $ sortMoves $ deleteCycles xs + where + -- Input relation is left-and-right-unique. Makes cycle detection easier. + deleteCycles [] = [] + deleteCycles whole@( x@(start,_,_):rest) + = if hasCycle start whole start + then deleteCycles (deleteFrom start whole []) + else x:deleteCycles rest + where hasCycle current ((a',b',_):rest') first + | a' == current = b' == first || hasCycle b' whole first + | otherwise = hasCycle current rest' first + hasCycle _ [] _ = False + deleteFrom a (y@(a',b',_):ys) seen + | a == a' = deleteFrom b' (seen++ys) [] + | otherwise = deleteFrom a ys (y:seen) + deleteFrom _ [] seen = seen + + sortMoves [] = [] + sortMoves whole@(current@(_,dest,_):_) = + smallest:sortMoves (delete smallest whole) + where + smallest = follow dest whole current + follow prevDest (y@(s,d,_):ys) currentSmallest + -- destination is source of another move + | prevDest == s = follow d whole y + -- parent of destination is also destination of a move + | d `elem` parents prevDest = follow d whole y + | otherwise = follow prevDest ys currentSmallest + follow _ [] currentSmallest = currentSmallest + + -- rewrite [d/ -> e/, .., d/f -> e/h] to [d/ -> e/, .., e/f -> e/h] + fixPaths [] = [] + fixPaths (y@(f1,f2,t):ys) + | f1 == f2 = fixPaths ys + | TreeType <- t = y:fixPaths (map replacepp ys) + | otherwise = y:fixPaths ys + where replacepp i@(if1,if2,it) | nfst == anchoredRoot = i + | otherwise = (nfst, if2, it) + where nfst = replacePrefixPath f1 f2 if1 + +-- | Search for possible replaces between the recordedAndPending state +-- and the unrecorded (or working) state. Return a Sealed FL list of +-- replace patches to be applied to the recordedAndPending state. +getReplaces :: forall rt p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree, + ApplyState (PrimOf p) ~ Tree, wX ~ wR) + => (UseIndex, ScanKnown, DiffAlgorithm) + -> Repository rt p wR wU wT + -> Maybe [SubPath] + -> IO (Sealed (FL (PrimOf p) wX)) +getReplaces (useindex, scan, dopts) repo files = do + relevant <- maybeRestrictSubpaths repo files + working <- readUnrecordedFiltered repo useindex scan files + pending <- applyTreeFilter relevant <$> readRecordedAndPending repo + ftf <- filetypeFunction + + Sealed changes <- unFreeLeft <$> treeDiff dopts ftf pending working + _ :> hunks <- return $ partitionRL primIsHunk $ reverseFL changes + let allModifiedTokens = concat $ mapFL modifiedTokens (reverseRL hunks) + replaces = rmInvalidReplaces allModifiedTokens + mapSeal concatFL . toFL <$> + mapM (\(f,a,b) -> doReplace defaultToks pending + (fromJust $ simpleSubPath $ fn2fp $ normPath f) + (BC.unpack a) (BC.unpack b)) replaces + where -- get individual tokens that have been modified + modifiedTokens (FP f (Hunk _ old new)) = -- old and new are list of lines (= 1 bytestring per line) + map (\(a,b) -> (f, a, b)) (concatMap checkModified $ + filter (\(a,b) -> length a == length b) -- only keep lines with same number of tokens + $ zip (map breakToTokens old) (map breakToTokens new)) + modifiedTokens _ = error "modifiedTokens: Not Hunk patch" + + -- from a pair of token lists, create a pair of modified token lists + checkModified = filter (\(a,b) -> a/=b) . uncurry zip + + rmInvalidReplaces [] = [] + rmInvalidReplaces ((f,old,new):rs) + | any (\(f',a,b) -> f' == f && old == a && b /= new) rs = -- inconsistency detected + rmInvalidReplaces $ filter (\(f'',a',_) -> f'' /= f || a' /= old) rs + rmInvalidReplaces (r:rs) = r:rmInvalidReplaces (filter (/=r) rs) + + doReplace toks pend f old new = do + let maybeReplace p = isJust <$> maybeApplyToTree replacePatch p + pendReplaced <- maybeReplace pend + if pendReplaced + then return $ joinGap (:>:) (freeGap replacePatch) (emptyGap NilFL) + else getForceReplace f toks pend old new + where + replacePatch = tokreplace (toFilePath f) toks old new + + getForceReplace :: PrimPatch prim => SubPath -> String -> Tree IO -> String -> String + -> IO (FreeLeft (FL prim)) + getForceReplace f toks tree old new = do + let path = floatSubPath f + -- It would be nice if we could fuse the two traversals here, that is, + -- expandPath and findFile. OTOH it is debatable whether adding a new + -- effectful version of findFile to Darcs.Util.Tree is justified. + expandedTree <- expandPath tree path + content <- case findFile expandedTree path of + Just blob -> readBlob blob + Nothing -> error $ "getForceReplace: not in tree: " ++ show path + let newcontent = forceTokReplace toks (BC.pack new) (BC.pack old) + (B.concat $ BL.toChunks content) + tree' = modifyTree expandedTree path . Just . File $ makeBlobBS newcontent + ftf <- filetypeFunction + normaliseNewTokPatch <- treeDiff dopts ftf expandedTree tree' + return . joinGap (+>+) normaliseNewTokPatch $ freeGap $ + tokreplace (toFilePath f) toks old new :>: NilFL diff --git a/src/Darcs/Repository/Test.hs b/src/Darcs/Repository/Test.hs --- a/src/Darcs/Repository/Test.hs +++ b/src/Darcs/Repository/Test.hs @@ -23,6 +23,9 @@ ) where +import Prelude () +import Darcs.Prelude + import System.Exit ( ExitCode(..) ) import System.Process ( system ) import System.IO ( hPutStrLn, stderr ) @@ -48,12 +51,12 @@ import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Util.Progress ( debugMessage ) -import Darcs.Repository.Lock +import Darcs.Util.Lock ( withTempDir , withPermDir ) import Darcs.Patch.Apply ( ApplyState ) -import Storage.Hashed.Tree ( Tree ) +import Darcs.Util.Tree ( Tree ) getTest :: Verbosity -> IO (IO ExitCode) @@ -119,7 +122,7 @@ return ec testTentative :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT + => Repository rt p wR wU wT -> RunTest -> LeaveTestDir -> SetScriptsExecutable @@ -137,11 +140,11 @@ testAny :: RepoPatch p - => (Repository p wR wU wT + => (Repository rt p wR wU wT -> ((AbsolutePath -> IO ExitCode) -> IO ExitCode) -> (AbsolutePath -> IO ExitCode) -> IO ExitCode ) - -> Repository p wR wU wT + -> Repository rt p wR wU wT -> RunTest -> LeaveTestDir -> SetScriptsExecutable diff --git a/src/Darcs/Repository/Util.hs b/src/Darcs/Repository/Util.hs deleted file mode 100644 --- a/src/Darcs/Repository/Util.hs +++ /dev/null @@ -1,340 +0,0 @@ --- Copyright (C) 2013 Jose Neder --- --- Permission is hereby granted, free of charge, to any person --- obtaining a copy of this software and associated documentation --- files (the "Software"), to deal in the Software without --- restriction, including without limitation the rights to use, copy, --- modify, merge, publish, distribute, sublicense, and/or sell copies --- of the Software, and to permit persons to whom the Software is --- furnished to do so, subject to the following conditions: --- --- The above copyright notice and this permission notice shall be --- included in all copies or substantial portions of the Software. --- --- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, --- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF --- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND --- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS --- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN --- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN --- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE --- SOFTWARE. - -{-# LANGUAGE CPP #-} -module Darcs.Repository.Util - ( getReplaces - , floatSubPath - , maybeApplyToTree - , defaultToks - , getMovesPs - , patchSetfMap - , getRecursiveDarcsRepos - ) where - -import Prelude hiding ( catch ) -import Control.Applicative ( (<$>) ) -import Control.Monad ( foldM, forM ) -import Control.Exception ( catch, IOException ) -import qualified Data.ByteString as B ( null, concat ) -import qualified Data.ByteString.Char8 as BC ( unpack, pack ) -import qualified Data.ByteString.Lazy as BL ( toChunks ) -import Data.Maybe ( isJust, fromJust, catMaybes ) -import Data.Ord ( comparing ) -import Data.List ( sortBy ) -#ifdef USE_LOCAL_DATA_MAP_STRICT -import qualified Darcs.Data.Map.Strict as M ( Map, lookup, fromList, insert, map, - empty, assocs, size, findWithDefault, delete ) -#else -import qualified Data.Map.Strict as M ( Map, lookup, fromList, insert, map, - empty, assocs, size, findWithDefault, delete ) -#endif - -import Storage.Hashed( floatPath, readPlainTree ) -import Storage.Hashed.Tree ( Tree, emptyTree, expand, ItemType(..), itemType, - readBlob, modifyTree, findFile, TreeItem(..), - makeBlobBS, expandPath ) -import Storage.Hashed.AnchoredPath ( AnchoredPath, anchorPath, parents, - replacePrefixPath, anchoredRoot ) -import qualified Storage.Hashed.Tree as T ( list ) -import Storage.Hashed.Index ( listFileIDs, getFileID ) -import System.Posix.Types ( FileID ) -import System.Directory ( getDirectoryContents, doesDirectoryExist ) -import System.FilePath.Posix ( () ) -import Darcs.Patch ( RepoPatch, PrimPatch, PrimOf, primIsHunk, applyToTree, - tokreplace, forceTokReplace, move ) -import Darcs.Patch.Set ( newset2RL, PatchSet(..) ) -import Darcs.Patch.Apply ( ApplyState ) -import Darcs.Patch.Patchy ( Apply ) -import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk ), Prim(..) ) -import Darcs.Patch.Prim.Class ( PrimConstruct, PrimCanonize ) -import Darcs.Patch.Permutations ( partitionRL ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd ) -import Darcs.Patch.TokenReplace ( breakOutToken ) -import Darcs.Patch.Witnesses.Ordered ( FL(..), reverseRL, reverseFL, (:>)(..), - foldlFL, concatFL, toFL, (+>+), mapRL ) -import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft, mapSeal, freeGap, - emptyGap, joinGap, FreeLeft, Gap(..) ) -import Darcs.Repository - ( Repository - , readUnrecorded - , readRecordedAndPending - , maybeIdentifyRepository - ) -import Darcs.Repository.Internal ( IdentifyRepo(..) ) -import Darcs.Repository.InternalTypes ( Repository(..), Pristine(..) ) -import Darcs.Repository.Diff( treeDiff ) -import Darcs.Repository.Flags ( UseIndex(..), ScanKnown, DiffAlgorithm(..), UseCache(..) ) -import Darcs.Repository.Prefs ( filetypeFunction ) -import Darcs.Repository.State ( TreeFilter(..), applyTreeFilter, - restrictSubpaths, readWorking, restrictBoring, - readIndex ) -import Darcs.Util.Path( fn2fp, SubPath, toFilePath, simpleSubPath, normPath, - floatSubPath ) - -getMovesPs :: forall p wR wU wB prim. - (PrimConstruct prim, PrimCanonize prim, RepoPatch p, - ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => Repository p wR wU wR - -> Maybe [SubPath] - -> IO (FL prim wB wB) -getMovesPs repository files = mkMovesFL <$> getMovedFiles repository files - where - mkMovesFL [] = NilFL - mkMovesFL ((a,b,_):xs) = move (anchorPath "" a) (anchorPath "" b) :>: mkMovesFL xs - - getMovedFiles :: (RepoPatch p, ApplyState p ~ Tree, - ApplyState (PrimOf p) ~ Tree) => - Repository p wR wU wR -> - Maybe [SubPath] -> - IO [(AnchoredPath, AnchoredPath, ItemType)] - getMovedFiles repo fs = do - old <- sortBy (comparing snd) <$> (listFileIDs =<< readIndex repo) - nonboring <- restrictBoring emptyTree - new <- sortBy (comparing snd) <$> - (addFileIDs . (map (\(a,b) -> (a, itemType b)) . T.list) =<< - expand =<< - applyTreeFilter nonboring <$> readPlainTree ".") - let movedfiles = matchFileLists old new - fmovedfiles = case fs of - Nothing -> movedfiles - Just subpath -> filter (\(old',new',_) -> old' `elem` selfiles - || new' `elem` selfiles) movedfiles - where selfiles = map (floatPath . toFilePath) subpath - return (resolveMoves fmovedfiles) - - resolveMoves :: [(AnchoredPath, AnchoredPath, ItemType)] - -> [(AnchoredPath, AnchoredPath, ItemType)] - resolveMoves xs = changePaths $ resolveDeps 0 (M.size movesMap) visited movesMap movesDepsMap - where - changePaths [] = [] - changePaths (y:ys) | fst' y == snd' y = changePaths $ map replacepp ys - | isPath y = y:changePaths (map replacepp ys) - | otherwise = y:changePaths ys - where replacepp i | nfst == anchoredRoot = i - | otherwise = (nfst, snd' i, thd' i) - where nfst = replacePrefixPath (fst' y) (snd' y) (fst' i) - - -- sort and index moves - movesMap = M.fromList $ zip [0..] $ sortBy (comparing thd') xs - - movesIDMap :: M.Map (AnchoredPath,AnchoredPath,ItemType) Int - movesIDMap = M.fromList $ zip (sortBy (comparing thd') $ xs) [0..] - - -- establish a relation of dependencies between moves (destination or parent of destination is moved again) - movesDepsMap :: M.Map Int [Int] - movesDepsMap = M.map (getMoveDeps (M.fromList (map (\x -> (fst' x,x)) xs)) - (M.fromList (map (\x -> (snd' x,x)) xs))) movesMap - - getMoveDeps :: M.Map AnchoredPath (AnchoredPath, AnchoredPath, ItemType) -- source to move - -> M.Map AnchoredPath (AnchoredPath, AnchoredPath, ItemType) -- destin to move - -> (AnchoredPath, AnchoredPath, ItemType) -- some move - -> [Int] - getMoveDeps am bm y = catMaybes $ - map (`M.lookup` movesIDMap) $ -- retrieve mode ID of deps - catMaybes $ - byname ++ map (`M.lookup` bm) (parents $ snd' y) -- see if current move is moved to moved dir - where byname | fst' y == snd' y = [] - | otherwise = [M.lookup (snd' y) am] -- see if current move is moved again - - fst' (a,_,_) = a - snd' (_,a,_) = a - thd' (_,_,a) = a - - resolveDeps :: Int -> Int -> M.Map Int (Int,Bool) - -> M.Map Int (AnchoredPath, AnchoredPath, ItemType) - -> M.Map Int [Int] - -> [(AnchoredPath, AnchoredPath, ItemType)] - resolveDeps n end v mm mdm - | n == end = reverse $ - catMaybes $ - map (flip M.lookup mm . abs) $ - getMoves (map fst (filter (\(_,(_,f)) -> f) $ - sortBy (comparing (fst . snd)) (M.assocs v))) mdm - | M.lookup n v /= Nothing = resolveDeps (n+1) end v mm mdm - | otherwise = resolveDeps (n+1) end nv nmm nmdm - where (nv, nmm, nmdm) = walk True n n v mm mdm - - getMoves [] _ = [] - getMoves (r:roots) mdm = [r]++bds r++getMoves roots mdm - where bds r' = lookupList r' mdm ++ concatMap bds (map abs $ lookupList r' mdm) - - lookupList x mdm = M.findWithDefault [] x mdm - - walk b n x v mm mdm - | x < 0 = (v, mm, mdm) - | Just n == (fst <$> M.lookup x v) = resolveClashName n x v mm mdm - | otherwise = foldl (\(v',mm', mdm') dep -> - walk False n dep v' mm' mdm') - (M.insert x (n,b) v, mm, mdm) - (lookupList x mdm) - - -- Ignore swap moves - -- Currently, handling them would involve introducing intermediate file names. - -- When darcs has swapmove primitive hunk we may fix this. - resolveClashName n x v mm mdm = (v', mm', mdm') - where v' = M.insert x (n,False) $ - foldl addvisited v (lookupList x mdm) - mm' = M.delete x mm -- forget about x - mdm' = M.insert x [] mdm -- remove dependencies for x - addvisited nv k | (fst <$> M.lookup k nv) /= Just n = foldl addvisited (M.insert k (n, False) nv) (lookupList k mdm) - | otherwise = nv - - visited = M.empty :: M.Map Int (Int, Bool) - - isPath (_, _, TreeType) = True - isPath _ = False - - addFileIDs :: [(AnchoredPath, ItemType)] -> IO [((AnchoredPath, ItemType),FileID)] - addFileIDs = foldM (\xs (apath, it)-> do fid <- getFileID apath - return $ case fid of - Nothing -> xs - Just fileid -> ((apath, it), fileid):xs) [] - - matchFileLists :: [((AnchoredPath, ItemType),FileID)] - -> [((AnchoredPath, ItemType),FileID)] - -> [(AnchoredPath, AnchoredPath, ItemType)] - matchFileLists [] _ = [] - matchFileLists _ [] = [] - matchFileLists (x:xs) (y:ys) | snd x > snd y = matchFileLists (x:xs) ys - | snd x < snd y = matchFileLists xs (y:ys) - | snd (fst x) /= snd (fst y) = matchFileLists xs ys - | otherwise = (fst (fst x), fst (fst y), snd (fst x)):matchFileLists xs ys - - --- | Search for possible replaces between the recordedAndPending state --- and the unrecorded (or working) state. Return a Sealed FL list of --- replace patches to be applied to the recordedAndPending state. -getReplaces :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree, - ApplyState (PrimOf p) ~ Tree, wX ~ wR) - => (UseIndex, ScanKnown, DiffAlgorithm) - -> Repository p wR wU wT - -> Maybe [SubPath] - -> IO (Sealed (FL (PrimOf p) wX)) -getReplaces (useindex, _, dopts) repo files = do - relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) files - working <- applyTreeFilter relevant <$> case useindex of - UseIndex -> readUnrecorded repo Nothing - IgnoreIndex -> readWorking - pending <- applyTreeFilter relevant <$> readRecordedAndPending repo - ftf <- filetypeFunction - - Sealed changes <- unFreeLeft <$> treeDiff dopts ftf pending working - _ :> hunks <- return $ partitionRL primIsHunk $ reverseFL changes - let unfilteredReplaces = foldlFL modifiedTokens [] (reverseRL hunks) - replaces = filterInvalidReplaces unfilteredReplaces - mapSeal concatFL . toFL <$> - mapM (\(f,a,b) -> doReplace defaultToks pending - (fromJust $ simpleSubPath $ fn2fp $ normPath f) - (BC.unpack a) (BC.unpack b)) replaces - where -- get individual tokens that have been modified - modifiedTokens xs (FP f (Hunk _ old new)) = - (map (\(a,b) -> (f, a, b)) $ concatMap checkForReplaces $ - filter (\(a,b) -> length a == length b) - $ zip (map breakToTokens old) (map breakToTokens new)) ++xs - modifiedTokens _ _ = error "modifiedTokens: Not Hunk patch" - - -- from a pair of token lists, create a pair of modified token lists - checkForReplaces ([],[]) = [] - checkForReplaces ((a:as),(b:bs)) | a == b = checkForReplaces (as,bs) - | otherwise = (a,b):checkForReplaces (as,bs) - checkForReplaces _ = error "checkForReplaces: Lists are not of the same length" - - -- keep tokens that have been consistently replaced - filterInvalidReplaces [] = [] - filterInvalidReplaces ((f,old,new):rs) - | any (\(f',a,b) -> f' == f && old == a && b /= new) rs = - filterInvalidReplaces $ filter (\(f'',a',_) -> f'' == f && a' /= old) rs - filterInvalidReplaces (r:rs) = r:filterInvalidReplaces (filter (/=r) rs) - - -- break a single bytestring into tokens - breakToTokens input | B.null input = [] - breakToTokens input = - let (_, tok, remaining) = breakOutToken defaultToks input in - tok : breakToTokens remaining - - doReplace toks pend f old new = do - let maybeReplace p = isJust <$> maybeApplyToTree replacePatch p - pendReplaced <- maybeReplace pend - if pendReplaced - then return $ joinGap (:>:) (freeGap replacePatch) gapNilFL - else getForceReplace f toks pend old new - where - gapNilFL = emptyGap NilFL - fp = toFilePath f - replacePatch = tokreplace fp toks old new - - getForceReplace :: PrimPatch prim => SubPath -> String -> Tree IO -> String -> String - -> IO (FreeLeft (FL prim)) - getForceReplace f toks tree old new = do - let path = floatSubPath f - -- It would be nice if we could fuse the two traversals here, that is, - -- expandPath and findFile. OTOH it is debatable whether adding a new - -- effectful version of findFile to Storage.Hashed.Tree is justified. - expandedTree <- expandPath tree path - content <- case findFile expandedTree path of - Just blob -> readBlob blob - Nothing -> do - error $ "getForceReplace: not in tree: " ++ show path - let newcontent = forceTokReplace toks (BC.pack new) (BC.pack old) - (B.concat $ BL.toChunks content) - tree' = modifyTree expandedTree path . Just . File $ makeBlobBS newcontent - ftf <- filetypeFunction - normaliseNewTokPatch <- treeDiff dopts ftf expandedTree tree' - return . joinGap (+>+) normaliseNewTokPatch $ freeGap $ - tokreplace (toFilePath f) toks old new :>: NilFL - - -maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Tree IO - -> IO (Maybe (Tree IO)) -maybeApplyToTree patch tree = - (Just `fmap` applyToTree patch tree) `catch` (\(_ :: IOException) -> return Nothing) - -patchSetfMap:: (forall wW wZ . PatchInfoAnd p wW wZ -> IO a) -> PatchSet p wW' wZ' -> IO [a] -patchSetfMap f = sequence . mapRL f . newset2RL - -defaultToks :: String -defaultToks = "A-Za-z_0-9" - --- |getRecursiveDarcsRepos returns all paths to repositories under topdir. -getRecursiveDarcsRepos :: FilePath -> IO [FilePath] -getRecursiveDarcsRepos topdir = do - isDir <- doesDirectoryExist topdir - if isDir - then do - status <- maybeIdentifyRepository NoUseCache topdir - case status of - GoodRepository (Repo _ _ pris _) -> - case pris of - HashedPristine -> return [topdir] - _ -> return [] -- old fashioned or broken repo - _ -> getRecursiveDarcsRepos' topdir - else return [] - - where - getRecursiveDarcsRepos' d = do - names <- getDirectoryContents d - let properNames = filter (\x -> head x /= '.') names - paths <- forM properNames $ \name -> do - let path = d name - getRecursiveDarcsRepos path - return (concat paths) diff --git a/src/Darcs/UI/ApplyPatches.hs b/src/Darcs/UI/ApplyPatches.hs --- a/src/Darcs/UI/ApplyPatches.hs +++ b/src/Darcs/UI/ApplyPatches.hs @@ -3,8 +3,10 @@ , StandardPatchApplier(..) ) where +import Prelude () +import Darcs.Prelude + import System.Exit ( ExitCode ( ExitSuccess ), exitSuccess ) -import Prelude hiding ( catch ) import System.IO ( hClose, stdout, stderr ) import Control.Exception ( catch, fromException, SomeException, throwIO ) @@ -36,59 +38,62 @@ , setScriptsExecutablePatches ) import Darcs.Repository.Job ( RepoJob(RepoJob) ) -import Darcs.Patch ( RepoPatch, description, PrimOf ) +import Darcs.Patch ( RepoPatch, RepoType, IsRepoType, description, PrimOf ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Witnesses.Ordered ( FL, mapFL, nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.UI.External ( sendEmail ) -import Darcs.Repository.Lock ( withStdoutTemp, readBinFile ) +import Darcs.Util.Lock ( withStdoutTemp, readBinFile ) import Darcs.Util.Printer ( vcat, text ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) +import GHC.Exts ( Constraint ) + data PatchProxy (p :: * -> * -> *) = PatchProxy -- |This class is a hack to abstract over pull/apply and rebase pull/apply. class PatchApplier pa where - -- |'CarrierType pa p' resolves to either 'p' or 'Rebasing p' - type CarrierType pa (p :: * -> * -> *) :: * -> * -> * + type ApplierRepoTypeConstraint pa (rt :: RepoType) :: Constraint repoJob :: pa -> [DarcsFlag] - -> (forall p wR wU - . ( RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree - , RepoPatch (CarrierType pa p), ApplyState (CarrierType pa p) ~ Tree - , ApplyState (PrimOf (CarrierType pa p)) ~ Tree + -> (forall rt p wR wU + . ( IsRepoType rt, ApplierRepoTypeConstraint pa rt + , RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree ) - => (PatchProxy p -> Repository (CarrierType pa p) wR wU wR -> IO ())) + => (PatchProxy p -> Repository rt p wR wU wR -> IO ())) -> RepoJob () applyPatches - :: forall p wR wU wT wX wZ - . (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) + :: forall rt p wR wU wT wX wZ + . ( ApplierRepoTypeConstraint pa rt, IsRepoType rt + , RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree + ) => pa -> PatchProxy p -> String -> [DarcsFlag] -> String - -> Repository (CarrierType pa p) wR wU wT - -> FL (PatchInfoAnd (CarrierType pa p)) wX wT - -> FL (PatchInfoAnd (CarrierType pa p)) wX wZ -> IO () + -> Repository rt p wR wU wT + -> FL (PatchInfoAnd rt p) wX wT + -> FL (PatchInfoAnd rt p) wX wZ -> IO () data StandardPatchApplier = StandardPatchApplier instance PatchApplier StandardPatchApplier where - type CarrierType StandardPatchApplier p = p + type ApplierRepoTypeConstraint StandardPatchApplier rt = () repoJob StandardPatchApplier _opts f = RepoJob (f PatchProxy) applyPatches StandardPatchApplier PatchProxy = standardApplyPatches standardApplyPatches - :: forall p wR wU wT wX wZ . (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) - => String -> [DarcsFlag] -> String -> Repository p wR wU wT - -> FL (PatchInfoAnd p) wX wT -> FL (PatchInfoAnd p) wX wZ -> IO () + :: forall rt p wR wU wT wX wZ + . (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) + => String -> [DarcsFlag] -> String -> Repository rt p wR wU wT + -> FL (PatchInfoAnd rt p) wX wT -> FL (PatchInfoAnd rt p) wX wZ -> IO () standardApplyPatches cmdName opts from_whom repository us' to_be_applied = do printDryRunMessageAndExit cmdName (verbosity opts) diff --git a/src/Darcs/UI/Commands.hs b/src/Darcs/UI/Commands.hs --- a/src/Darcs/UI/Commands.hs +++ b/src/Darcs/UI/Commands.hs @@ -49,7 +49,6 @@ , printDryRunMessageAndExit , setEnvDarcsPatches , setEnvDarcsFiles - , formatPath , defaultRepo , amInHashedRepository , amInRepository @@ -57,11 +56,14 @@ , findRepository ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^) ) import Control.Monad ( when, unless ) import Data.List ( sort, isPrefixOf ) import Data.Maybe ( catMaybes ) -import Storage.Hashed.Tree ( Tree ) +import Darcs.Util.Tree ( Tree ) import System.Console.GetOpt ( OptDescr ) import System.Exit ( exitSuccess ) import System.IO ( stderr ) @@ -397,7 +399,7 @@ => String -> Verbosity -> Summary -> DryRun -> XmlOutput -> Bool -- interactive - -> FL (PatchInfoAnd p) wX wY + -> FL (PatchInfoAnd rt p) wX wY -> IO () printDryRunMessageAndExit action v s d x interactive patches = do when (d == YesDryRun) $ do @@ -437,7 +439,7 @@ -- | Set the DARCS_PATCHES and DARCS_PATCHES_XML environment variables with -- info about the given patches, for use in post-hooks. setEnvDarcsPatches :: (RepoPatch p, ApplyState p ~ Tree) - => FL (PatchInfoAnd p) wX wY -> IO () + => FL (PatchInfoAnd rt p) wX wY -> IO () #ifndef WIN32 setEnvDarcsPatches ps = do let k = "Defining set of chosen patches" @@ -461,6 +463,7 @@ | toobig (10 * 1024) v = return () | otherwise = setEnv e v True where + -- note: not using (length v) because we want to be more lazy than that toobig :: Int -> [a] -> Bool toobig 0 _ = True toobig _ [] = False @@ -478,17 +481,6 @@ #else setEnvDarcsFiles _ = return () #endif - --- | Format a path for screen output, so that the user sees where the path --- begins and ends. Could (should?) also warn about unprintable characters --- here. -formatPath :: String -> String -formatPath path = "\"" ++ quote path ++ "\"" - where - quote "" = "" - quote (c:cs) = if c `elem` ['\\', '"'] - then '\\' : c : quote cs - else c : quote cs defaultRepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] defaultRepo fs = defaultrepo (remoteRepos fs) diff --git a/src/Darcs/UI/Commands/Add.hs b/src/Darcs/UI/Commands/Add.hs --- a/src/Darcs/UI/Commands/Add.hs +++ b/src/Darcs/UI/Commands/Add.hs @@ -30,10 +30,12 @@ , expandDirs ) where +import Prelude () +import Darcs.Prelude #include "impossible.h" -import Prelude hiding ( (^), catch ) +import Prelude hiding ( (^) ) import Control.Exception ( catch, IOException ) import Control.Monad ( when, unless, liftM ) @@ -41,7 +43,7 @@ import Data.List.Ordered ( nubSort ) import Data.Maybe ( isNothing, maybeToList ) import Darcs.Util.Printer ( text ) -import Storage.Hashed.Tree ( Tree, findTree, expand ) +import Darcs.Util.Tree ( Tree, findTree, expand ) import Darcs.Util.Path ( floatPath, anchorPath, parents, SubPath, toFilePath, simpleSubPath, toPath, AbsolutePath ) import System.FilePath.Posix ( takeDirectory, () ) @@ -80,12 +82,12 @@ addDescription :: String -addDescription = "Add one or more new files or directories." +addDescription = "Add new files to version control." addHelp :: String addHelp = - "Generally a repository contains both files that should be version\n" ++ + "Generally the working tree contains both files that should be version\n" ++ "controlled (such as source code) and files that Darcs should ignore\n" ++ "(such as executables compiled from the source code). The `darcs add`\n" ++ "command is used to tell Darcs which files to version control.\n" ++ @@ -110,7 +112,7 @@ "unusable on those systems!\n\n" addBasicOpts :: DarcsOption a - (Bool -> Bool -> Bool -> Bool -> Maybe String -> O.DryRun -> a) + (O.IncludeBoring -> Bool -> Bool -> Bool -> Maybe String -> O.DryRun -> a) addBasicOpts = O.includeBoring ^ O.allowProblematicFilenames ^ O.recursive @@ -121,7 +123,7 @@ addAdvancedOpts = O.umask addOpts :: DarcsOption a - (Bool + (O.IncludeBoring -> Bool -> Bool -> Bool diff --git a/src/Darcs/UI/Commands/Amend.hs b/src/Darcs/UI/Commands/Amend.hs --- a/src/Darcs/UI/Commands/Amend.hs +++ b/src/Darcs/UI/Commands/Amend.hs @@ -26,15 +26,13 @@ ( amend , amendrecord - , updatePatchHeader ) where -import Prelude hiding ( (^) ) +import Prelude () +import Darcs.Prelude import Data.Maybe ( isNothing, isJust ) -import Control.Applicative ( (<$>) ) -import Control.Monad ( unless, when ) -import System.Exit ( exitSuccess ) +import Control.Monad ( when ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts @@ -44,24 +42,21 @@ , setEnvDarcsPatches , amInHashedRepository ) -import Darcs.UI.Commands.Record ( getLog ) import Darcs.UI.Commands.Util ( announceFiles, testTentativeAndMaybeExit ) -import Darcs.UI.Flags - ( DarcsFlag - , diffOpts, fixSubPaths, getEasyAuthor, promptAuthor, getDate ) +import Darcs.UI.Flags ( DarcsFlag, diffOpts, fixSubPaths ) import Darcs.UI.Options ( DarcsOption, (^), oparse, odesc, ocheck, defaultFlags ) import qualified Darcs.UI.Options.All as O +import Darcs.UI.PatchHeader ( updatePatchHeader, AskAboutDeps(..) + , HijackOptions(..) + , runHijackT ) import Darcs.Repository.Flags ( UpdateWorking(..), DryRun(NoDryRun) ) -import Darcs.Patch ( RepoPatch, description, PrimOf, fromPrims, - infopatch, getdeps, adddeps, effect, invert, invertFL +import Darcs.Patch ( IsRepoType, RepoPatch, description, PrimOf + , effect, invert, invertFL ) import Darcs.Patch.Apply ( ApplyState ) -import Darcs.Patch.Info ( piAuthor, piName, piLog, piDateString, - patchinfo, isInverted, isTag, invertName, - ) -import Darcs.Patch.Prim ( canonizeFL ) +import Darcs.Patch.Info ( isTag ) import Darcs.Patch.Split ( primSplitter ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully, info, patchDesc ) +import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, patchDesc ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) ) import Darcs.Patch.Rebase.Name ( RebaseName(..) ) import Darcs.Util.Path ( toFilePath, SubPath(), AbsolutePath ) @@ -69,6 +64,7 @@ ( Repository , withRepoLock , RepoJob(..) + , RebaseJobFlags(..) , tentativelyRemovePatches , tentativelyAddPatch , withManualRebaseUpdate @@ -79,27 +75,24 @@ , listRegisteredFiles ) import Darcs.Repository.Prefs ( globalPrefsDirDoc ) -import Darcs.Repository.Util ( getMovesPs, getReplaces ) +import Darcs.Repository.State ( getMovesPs, getReplaces ) import Darcs.UI.SelectChanges - ( selectChanges - , WhichChanges(..) + ( WhichChanges(..) , selectionContextPrim , runSelection , withSelectedPatchFromRepo - , askAboutDepends ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) import Darcs.Util.Exception ( clarifyErrors ) -import Darcs.Util.Prompt ( askUser ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), (+>+), nullFL, reverseRL, mapFL_FL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.Printer ( putDocLn ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) import Darcs.Repository.Internal ( tentativelyRemoveFromPending ) @@ -270,10 +263,11 @@ doAmend :: AmendConfig -> Maybe [SubPath] -> IO () doAmend cfg files = + let rebaseJobFlags = RebaseJobFlags (compress cfg) (verbosity cfg) YesUpdateWorking in withRepoLock NoDryRun (useCache cfg) YesUpdateWorking (umask cfg) $ - RebaseAwareJob (compress cfg) (verbosity cfg) YesUpdateWorking $ \(repository :: Repository p wR wU wR) -> + RebaseAwareJob rebaseJobFlags $ \(repository :: Repository rt p wR wU wR) -> withSelectedPatchFromRepo "amend" repository (patchSelOpts cfg) $ \ (_ :> oldp) -> do - announceFiles files "Amending changes in" + announceFiles (verbosity cfg) files "Amending changes in" -- auxiliary function needed because the witness types differ for the isTag case pristine <- readRecorded repository let go :: forall wU1 . FL (PrimOf p) wR wU1 -> IO () @@ -282,22 +276,21 @@ do let context = selectionContextPrim First "record" (patchSelOpts cfg) --([All,Unified] `intersect` opts) - (Just primSplitter) + (Just (primSplitter (diffAlgorithm cfg))) (map toFilePath <$> files) (Just pristine) - (chosenPatches :> _) <- runSelection (selectChanges ch) context + (chosenPatches :> _) <- runSelection ch context addChangesToPatch cfg repository oldp chosenPatches if not (isTag (info oldp)) -- amending a normal patch then if amendUnrecord cfg - then do let sel = selectChanges (effect oldp) - context = selectionContextPrim Last "unrecord" + then do let context = selectionContextPrim Last "unrecord" (patchSelOpts cfg) -- ([All,Unified] `intersect` opts) - (Just primSplitter) + (Just (primSplitter (diffAlgorithm cfg))) (map toFilePath <$> files) (Just pristine) - (_ :> chosenPrims) <- runSelection sel context + (_ :> chosenPrims) <- runSelection (effect oldp) context let invPrims = reverseRL (invertFL chosenPrims) addChangesToPatch cfg repository oldp invPrims else do Sealed replacePs <- if O.replaces (lookfor cfg) == O.YesLookForReplaces @@ -306,8 +299,9 @@ movesPs <- if O.moves (lookfor cfg) == O.YesLookForMoves then getMovesPs repository files else return NilFL - go =<< unrecordedChangesWithPatches (diffingOpts cfg) repository files - movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR) + go =<< unrecordedChangesWithPatches + movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR) + (diffingOpts cfg) repository files -- amending a tag else if hasEditMetadata cfg && isNothing files -- the user is not trying to add new changes to the tag so there is @@ -323,13 +317,15 @@ go NilFL -addChangesToPatch :: forall p wR wU wT wX wY . (RepoPatch p, ApplyState p ~ Tree) +addChangesToPatch :: forall rt p wR wU wT wX wY + . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => AmendConfig - -> Repository p wR wU wT - -> PatchInfoAnd p wX wT + -> Repository rt p wR wU wT + -> PatchInfoAnd rt p wX wT -> FL (PrimOf p) wT wY -> IO () addChangesToPatch cfg repository oldp chs = + let rebaseJobFlags = RebaseJobFlags (compress cfg) (verbosity cfg) YesUpdateWorking in if nullFL chs && not (hasEditMetadata cfg) then putStrLn "You don't want to record anything!" else do @@ -344,18 +340,19 @@ -- -- We can also signal that any explicit dependencies of the old patch should be rewritten -- for the new patch using a 'NameFixup'. - (repository''', (mlogf, newp)) <- withManualRebaseUpdate (compress cfg) (verbosity cfg) YesUpdateWorking repository $ \repository' -> do + (repository''', (mlogf, newp)) <- withManualRebaseUpdate rebaseJobFlags repository $ \repository' -> do repository'' <- tentativelyRemovePatches repository' (compress cfg) YesUpdateWorking (oldp :>: NilFL) - (mlogf, newp) <- updatePatchHeader - (askDeps cfg) + (mlogf, newp) <- runHijackT AlwaysRequestHijackPermission $ updatePatchHeader "amend" + (if askDeps cfg then AskAboutDeps repository'' else NoAskAboutDeps) (patchSelOpts cfg) + (diffAlgorithm cfg) (keepDate cfg) (selectAuthor cfg) (author cfg) (patchname cfg) (askLongComment cfg) - repository'' oldp chs + oldp chs let fixups = mapFL_FL PrimFixup (invert chs) +>+ NameFixup (Rename (info newp) (info oldp)) :>: @@ -364,7 +361,7 @@ repository''' <- tentativelyAddPatch repository'' (compress cfg) (verbosity cfg) YesUpdateWorking newp return (repository''', fixups, (mlogf, newp)) let failmsg = maybe "" (\lf -> "\nLogfile left in "++lf++".") mlogf - testTentativeAndMaybeExit repository''' (verbosity cfg) (testChanges cfg) (sse cfg) (isInteractive True cfg) + testTentativeAndMaybeExit repository''' (verbosity cfg) (testChanges cfg) (sse cfg) (isInteractive cfg) ("you have a bad patch: '" ++ patchDesc newp ++ "'") "amend it" (Just failmsg) when (O.moves (lookfor cfg) == O.YesLookForMoves || O.replaces (lookfor cfg) == O.YesLookForReplaces) @@ -375,56 +372,6 @@ setEnvDarcsPatches (newp :>: NilFL) -updatePatchHeader :: forall p wX wY wR wU wT . (RepoPatch p, ApplyState p ~ Tree) - => Bool -- askDeps - -> S.PatchSelectionOptions - -> Bool -- keepDate - -> Bool -- selectAuthor - -> Maybe String -- author - -> Maybe String -- patchname - -> Maybe O.AskLongComment - -> Repository p wR wU wT - -> PatchInfoAnd p wT wX - -> FL (PrimOf p) wX wY - -> IO (Maybe String, PatchInfoAnd p wT wY) -updatePatchHeader ask_deps pSelOpts nKeepDate nSelectAuthor nAuthor nPatchname nAskLongComment repository oldp chs = do - - let newchs = canonizeFL (S.diffAlgorithm pSelOpts) (effect oldp +>+ chs) - - let old_pdeps = getdeps $ hopefully oldp - newdeps <- if ask_deps - then askAboutDepends repository newchs pSelOpts old_pdeps - else return old_pdeps - - let old_pinf = info oldp - prior = (piName old_pinf, piLog old_pinf) - old_author = piAuthor old_pinf - date <- if nKeepDate then return (piDateString old_pinf) else getDate False - (new_author,edit_author) <- getAuthor nSelectAuthor nAuthor old_author - warnIfHijacking old_author edit_author - (new_name, new_log, mlogf) <- getLog - nPatchname False (O.Logfile Nothing False) nAskLongComment (Just prior) chs - let maybe_invert = if isInverted old_pinf then invertName else id - new_pinf <- maybe_invert `fmap` patchinfo date new_name - new_author new_log - - let newp = n2pia (adddeps (infopatch new_pinf (fromPrims newchs)) newdeps) - - return (mlogf, newp) - - -warnIfHijacking :: String -- Original author - -> Bool -- Author change requested by options - -> IO () -warnIfHijacking old_author edit_author = do - authors_here <- getEasyAuthor - unless (edit_author || old_author `elem` authors_here) $ do - yorn <- askUser $ - "You're not " ++ old_author ++"! Amend anyway? " - case yorn of ('y':_) -> return () - _ -> exitSuccess - - hasEditMetadata :: AmendConfig -> Bool hasEditMetadata cfg = isJust (author cfg) || selectAuthor cfg @@ -444,33 +391,18 @@ -- hasEditMetadata (_:fs) = hasEditMetadata fs -getAuthor :: Bool -> Maybe String -> String -> IO (String,Bool) -getAuthor True _ _ = do - a <- promptAuthor False True - return (a,True) -getAuthor False (Just a) _ = return (a,True) -getAuthor False Nothing old = return (old,False) - --- getAuthor (SelectAuthor:_) _ = do --- a <- promptAuthor False True --- return (a,True) --- getAuthor (Author a:_) _ = return (a,True) --- getAuthor (_:as) old = getAuthor as old --- getAuthor [] old = return (old,False) - patchSelOpts :: AmendConfig -> S.PatchSelectionOptions patchSelOpts cfg = S.PatchSelectionOptions { S.verbosity = verbosity cfg , S.matchFlags = matchFlags cfg - , S.diffAlgorithm = diffAlgorithm cfg - , S.interactive = isInteractive True cfg + , S.interactive = isInteractive cfg , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default , S.withContext = withContext cfg } diffingOpts :: AmendConfig -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) -diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) False (diffAlgorithm cfg) +diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) O.NoIncludeBoring (diffAlgorithm cfg) -isInteractive :: Bool -> AmendConfig -> Bool -isInteractive def = maybe def id . interactive +isInteractive :: AmendConfig -> Bool +isInteractive = maybe True id . interactive diff --git a/src/Darcs/UI/Commands/Annotate.hs b/src/Darcs/UI/Commands/Annotate.hs --- a/src/Darcs/UI/Commands/Annotate.hs +++ b/src/Darcs/UI/Commands/Annotate.hs @@ -18,17 +18,19 @@ module Darcs.UI.Commands.Annotate ( annotate ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^) ) import Control.Arrow ( first ) import Control.Monad ( unless ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) -import Darcs.UI.Flags ( DarcsFlag(NoPatchIndexFlag), isUnified, useCache, fixSubPaths, hasSummary, umask ) +import Darcs.UI.Flags ( DarcsFlag(NoPatchIndexFlag), useCache, fixSubPaths, umask ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise , defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O -import Storage.Hashed.Plain( readPlainTree ) import Darcs.Repository.State ( readRecorded ) import Darcs.Repository ( withRepository @@ -41,26 +43,19 @@ import Darcs.Repository.Flags ( UpdateWorking(..) ) import Darcs.Repository.PatchIndex ( attemptCreatePatchIndex ) import Darcs.Patch.Set ( newset2RL ) -import Darcs.Patch ( RepoPatch, Named, patch2patchinfo, invertRL ) -import qualified Darcs.Patch ( summary ) -import Darcs.Patch.Type ( PatchType(..) ) -import Darcs.Patch.Dummy ( DummyPatch ) +import Darcs.Patch ( invertRL ) import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate ) import Data.ByteString.Lazy ( toChunks ) -import Darcs.UI.PrintPatch ( printPatch, contextualPrintPatch ) import Darcs.Patch.ApplyMonad( withFileNames ) import System.FilePath.Posix ( () ) -import Darcs.Patch.Info ( showPatchInfoUI, showPatchInfo ) -import Darcs.Patch.Match ( matchPatch, haveNonrangeMatch, getNonrangeMatchS ) -import Darcs.Repository.Match ( getFirstMatch, getOnePatchset ) -import Darcs.Repository.Lock ( withTempDir ) +import Darcs.Patch.Match ( haveNonrangeMatch, getNonrangeMatchS ) +import Darcs.Repository.Match ( getOnePatchset ) import Darcs.Repository.PatchIndex ( getRelevantSubsequence, canUsePatchIndex ) -import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal ) +import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal ) import qualified Darcs.Patch.Annotate as A -import Darcs.Util.Printer ( putDocLn, Doc ) -import Storage.Hashed.Tree( TreeItem(..), readBlob, list, expand ) -import Storage.Hashed.Monad( findM, virtualTreeIO ) +import Darcs.Util.Tree( TreeItem(..), readBlob, list, expand ) +import Darcs.Util.Tree.Monad( findM, virtualTreeIO ) import Darcs.Util.Path( floatPath, anchorPath, fp2fn, toFilePath , AbsolutePath ) import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) ) @@ -68,42 +63,31 @@ #include "impossible.h" annotateDescription :: String -annotateDescription = "Display which patch last modified something." +annotateDescription = "Annotate lines of a file with the last patch that modified it." annotateHelp :: String annotateHelp = unlines - [ "The `darcs annotate` command provides two unrelated operations. When" - , "called on a file, it will find the patch that last modified each line" - , "in that file. When called on a patch (e.g. using `--patch`), it will" - , "print the internal representation of that patch." - , "" - , "The `--summary` option will result in a summarized patch annotation," - , "similar to `darcs whatsnew`. It has no effect on file annotations." + [ "When `darcs annotate` is called on a file, it will find the patch that" + , "last modified each line in that file. This also works on directories." , "" - , "By default, output is in a human-readable format. The `--machine-readable`" - , "option can be used to generate output for machine postprocessing." + , "The `--machine-readable` option can be used to generate output for" + , "machine postprocessing." ] annotateBasicOpts :: DarcsOption a - (Maybe O.Summary - -> O.WithContext - -> Bool + (Bool -> [O.MatchFlag] -> Maybe String -> a) -annotateBasicOpts = O.summary - ^ O.withContext - ^ O.machineReadable - ^ O.matchOne +annotateBasicOpts = O.machineReadable + ^ O.matchUpToOne ^ O.workingRepoDir annotateAdvancedOpts :: DarcsOption a (O.WithPatchIndex -> a) annotateAdvancedOpts = O.patchIndexYes annotateOpts :: DarcsOption a - (Maybe O.Summary - -> O.WithContext - -> Bool + ( Bool -> [O.MatchFlag] -> Maybe String -> Maybe O.StdCmdAction @@ -126,8 +110,8 @@ , commandName = "annotate" , commandHelp = annotateHelp , commandDescription = annotateDescription - , commandExtraArgs = -1 - , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] + , commandExtraArgs = 1 + , commandExtraArgHelp = ["[FILE or DIRECTORY]"] , commandCommand = annotateCmd , commandPrereq = amInHashedRepository , commandGetArgPossibilities = listRegisteredFiles @@ -140,39 +124,12 @@ } annotateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -annotateCmd fps opts [""] = annotate' fps opts [] -- when does that happen? -annotateCmd fps opts [] = do - let matchFlags = parseFlags O.matchOne opts - unless (haveNonrangeMatch (PatchType :: PatchType DummyPatch) matchFlags) $ - fail $ "Annotate requires either a patch pattern or a " ++ - "file or directory argument." - annotate' fps opts [] -annotateCmd fps opts args = annotate' fps opts args - -annotate' :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -annotate' _ opts [] = -- annotating a patch (ie, showing its contents) - withRepository (useCache opts) $ RepoJob $ \repository -> do - let matchFlags = parseFlags O.matchOne opts - Sealed2 p <- matchPatch matchFlags `fmap` readRepo repository - if hasSummary O.NoSummary opts == O.YesSummary - then do putDocLn $ showpi $ patch2patchinfo p - putDocLn $ show_summary p - else if isUnified opts == O.YesContext - then withTempDir "context" $ \_ -> - do getFirstMatch repository matchFlags - c <- readPlainTree "." - contextualPrintPatch c p - else printPatch p - where showpi | parseFlags O.machineReadable opts = showPatchInfo - | otherwise = showPatchInfoUI - show_summary :: RepoPatch p => Named p wX wY -> Doc - show_summary = Darcs.Patch.summary - -annotate' fps opts args@[_] = do -- annotating a file or a directory +annotateCmd _ _ [""] = fail "No filename argument given to annotate!" +annotateCmd fps opts args = do + let matchFlags = parseFlags O.matchUpToOne opts unless (NoPatchIndexFlag `elem` opts) $ withRepoLockCanFail (useCache opts) YesUpdateWorking (umask opts) $ RepoJob attemptCreatePatchIndex withRepository (useCache opts) $ RepoJob $ \repository -> do - let matchFlags = parseFlags O.matchOne opts r <- readRepo repository (origpath:_) <- fixSubPaths fps args recorded <- readRecorded repository @@ -214,5 +171,3 @@ con <- BC.concat `fmap` toChunks `fmap` readBlob b putStrLn $ fmt con $ A.annotate D.MyersDiff (invertRL ans_patches) (fp2fn path) con Just (Stub _ _) -> impossible - -annotate' _ _ _ = fail "annotate accepts at most one argument" diff --git a/src/Darcs/UI/Commands/Apply.hs b/src/Darcs/UI/Commands/Apply.hs --- a/src/Darcs/UI/Commands/Apply.hs +++ b/src/Darcs/UI/Commands/Apply.hs @@ -15,15 +15,18 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, PatternGuards #-} +{-# LANGUAGE CPP #-} module Darcs.UI.Commands.Apply ( apply, applyCmd , getPatchBundle -- used by darcsden ) where +import Prelude () +import Darcs.Prelude + import System.Exit ( exitSuccess ) -import Prelude hiding ( (^), catch ) +import Prelude hiding ( (^) ) import Control.Monad ( when ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefullyM, info ) @@ -37,7 +40,7 @@ , doHappyForwarding, doReverse, verbosity, useCache, dryRun , reorder, umask , fixUrl, getCc, getSendmailCmd - , diffAlgorithm, isUnified, getReply + , isUnified, getReply ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O @@ -51,7 +54,7 @@ , filterOutConflicts ) import Darcs.Patch.Set ( Origin, newset2RL ) -import Darcs.Patch ( RepoPatch, PrimOf ) +import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Info ( PatchInfo, showPatchInfoUI ) import Darcs.Patch.Witnesses.Ordered @@ -64,7 +67,7 @@ import qualified Data.ByteString.Char8 as BC (unpack, last, pack) import Darcs.Util.Download ( Cachable(Uncachable) ) -import Darcs.Repository.External ( gzFetchFilePS ) +import Darcs.Util.External ( gzFetchFilePS ) import Darcs.UI.External ( sendEmailDoc , resendEmail @@ -74,8 +77,7 @@ import Darcs.Patch.Depends ( findUncommon, findCommonWithThem ) import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..), PatchProxy ) import Darcs.UI.SelectChanges - ( selectChanges - , WhichChanges(..) + ( WhichChanges(..) , runSelection , selectionContext ) @@ -85,7 +87,7 @@ ( packedString, vcat, text, empty , renderString, RenderMode(..) ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) #include "impossible.h" @@ -264,15 +266,15 @@ applyCmd _ _ _ _ = impossible applyCmdCommon - :: forall pa p wR wU + :: forall rt pa p wR wU . ( PatchApplier pa, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree - , RepoPatch (CarrierType pa p), ApplyState (CarrierType pa p) ~ Tree + , ApplierRepoTypeConstraint pa rt, IsRepoType rt ) => pa -> PatchProxy p -> [DarcsFlag] -> B.ByteString - -> Repository (CarrierType pa p) wR wU wR + -> Repository rt p wR wU wR -> IO () applyCmdCommon patchApplier patchProxy opts bundle repository = do let from_whom = getFrom bundle @@ -291,8 +293,8 @@ let common_i = mapRL info $ newset2RL common them_i = mapRL info $ newset2RL them required = them_i \\ common_i -- FIXME quadratic? - check :: RL (PatchInfoAnd (CarrierType pa p)) wX wY -> [PatchInfo] -> IO () - check (p :<: ps') bad = case hopefullyM p of + check :: RL (PatchInfoAnd rt p) wX wY -> [PatchInfo] -> IO () + check (ps' :<: p) bad = case hopefullyM p of Nothing | info p `elem` required -> check ps' (info p : bad) _ -> check ps' bad check NilRL [] = return () @@ -316,7 +318,7 @@ let direction = if doReverse opts then FirstReversed else First context = selectionContext direction "apply" (patchSelOpts opts) Nothing Nothing - (to_be_applied :> _) <- runSelection (selectChanges their_ps) context + (to_be_applied :> _) <- runSelection their_ps context applyPatches patchApplier patchProxy "apply" opts from_whom repository us' to_be_applied -- see the default (False) for the option -- where fixed_opts = if Interactive `elem` opts @@ -324,7 +326,7 @@ -- else All : opts getPatchBundle :: RepoPatch p => [DarcsFlag] -> B.ByteString - -> IO (Either String (SealedPatchSet p Origin)) + -> IO (Either String (SealedPatchSet rt p Origin)) getPatchBundle opts fps = do let opt_verify = parseFlags O.verify opts mps <- verifyPS opt_verify $ readEmail fps @@ -421,7 +423,6 @@ patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveral flags - , S.diffAlgorithm = diffAlgorithm flags , S.interactive = maybeIsInteractive flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default diff --git a/src/Darcs/UI/Commands/Clone.hs b/src/Darcs/UI/Commands/Clone.hs --- a/src/Darcs/UI/Commands/Clone.hs +++ b/src/Darcs/UI/Commands/Clone.hs @@ -25,8 +25,11 @@ , cloneToSSH ) where -import Prelude hiding ( (^), catch ) +import Prelude () +import Darcs.Prelude +import Prelude hiding ( (^) ) + import System.Directory ( doesDirectoryExist, doesFileExist , setCurrentDirectory ) import System.Exit ( ExitCode(..) ) @@ -60,8 +63,8 @@ ) , formatHas ) -import Darcs.Repository.Lock ( withTempDir ) -import Darcs.Repository.Ssh ( getSSH, SSHCmd(SCP) ) +import Darcs.Util.Lock ( withTempDir ) +import Darcs.Util.Ssh ( getSSH, SSHCmd(SCP) ) import Darcs.Repository.Flags ( CloneKind(CompleteClone), SetDefault(NoSetDefault), ForgetParent(..) ) import Darcs.Patch.Bundle ( scanContextFile ) @@ -86,10 +89,8 @@ , "if omitted, it is inferred from the source location." , "" , "By default Darcs will copy every patch from the original repository." - , "This means the copy is completely independent of the original; you can" - , "operate on the new repository even when the original is inaccessible." , "If you expect the original repository to remain accessible, you can" - , "use `--lazy` to avoid copying patches until they are needed (`copy on" + , "use `--lazy` to avoid copying patches until they are needed ('copy on" , "demand'). This is particularly useful when copying a remote" , "repository with a long history that you don't care about." , "" @@ -103,8 +104,8 @@ , "" , "When cloning from a remote location, Darcs will look for and attempt" , "to use packs created by `darcs optimize http` in the remote repository." - , "Packs are single big files that can be downloaded instead of many" - , "little files, which makes cloning faster over HTTP." + , "Packs are single big files that can be downloaded faster than many" + , "little files." , "" , "Darcs clone will not copy unrecorded changes to the source repository's" , "working tree." @@ -234,7 +235,6 @@ (withWorkingDir opts) (runPatchIndex opts) (usePacks opts) - (not $ null [p | UpToPattern p <- opts] ) -- --to-match given YesForgetParent setCurrentDirectory currentDir (scp, args) <- getSSH SCP @@ -253,7 +253,6 @@ (withWorkingDir opts) (runPatchIndex opts) (usePacks opts) - (not $ null [p | UpToPattern p <- opts] ) -- --to-match given NoForgetParent putInfo opts $ text "Finished cloning." @@ -302,7 +301,7 @@ , "`--to-match` options, which exclude patches *after* the first matching" , "patch. Because these options treat the set of patches as an ordered" , "sequence, you may get different results after reordering with `darcs" - , "optimize`, so tagging is preferred." + , "optimize reorder`." , "" ] @@ -323,7 +322,7 @@ exists <- doesFileExist ctxFilePath if exists then do - (ps :: PatchSet DummyPatch Origin wX) <- + (ps :: PatchSet rt DummyPatch Origin wX) <- scanContextFile ctxFilePath (ps `seq` return $ Right ()) `catch` \(_ :: SomeException) -> return . Left $ "File " ++ ctxFilePath diff --git a/src/Darcs/UI/Commands/Convert.hs b/src/Darcs/UI/Commands/Convert.hs --- a/src/Darcs/UI/Commands/Convert.hs +++ b/src/Darcs/UI/Commands/Convert.hs @@ -15,11 +15,12 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, MagicHash, OverloadedStrings, DeriveDataTypeable #-} +{-# LANGUAGE CPP, MagicHash, OverloadedStrings #-} module Darcs.UI.Commands.Convert ( convert ) where -import Prelude hiding ( (^), readFile, log, lex ) +import Prelude ( lookup ) +import Darcs.Prelude hiding ( readFile, lex ) import System.FilePath.Posix ( () ) import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist, @@ -27,12 +28,12 @@ import System.IO ( stdin ) import Data.IORef ( newIORef, modifyIORef, readIORef ) import Data.Char ( isSpace ) -import Control.Arrow ( (&&&) ) +import Control.Arrow ( second, (&&&) ) import Control.Monad ( when, unless, void, forM_ ) import Control.Monad.Trans ( liftIO ) import Control.Monad.State.Strict ( gets, modify ) import Control.Exception ( finally ) -import Control.Applicative ( (<|>), (<$>) ) +import Control.Applicative ( (<|>) ) import GHC.Base ( unsafeCoerce# ) import System.Time ( toClockTime ) @@ -48,21 +49,21 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Attoparsec.ByteString.Char8( () ) -import qualified Storage.Hashed.Tree as T -import qualified Storage.Hashed.Monad as TM -import Storage.Hashed.Monad hiding ( createDirectory, exists, rename ) -import Storage.Hashed.Darcs ( hashedTreeIO, darcsAddMissingHashes ) -import Storage.Hashed.Tree( Tree, treeHash, readBlob, TreeItem(..) - , emptyTree, listImmediate, findTree ) -import Storage.Hashed.AnchoredPath( anchorPath, appendPath, floatPath - , parent, anchoredRoot - , AnchoredPath(..), Name(..) ) -import Storage.Hashed.Hash( encodeBase16, sha256, Hash(..) ) +import qualified Darcs.Util.Tree as T +import qualified Darcs.Util.Tree.Monad as TM +import Darcs.Util.Tree.Monad hiding ( createDirectory, exists, rename ) +import Darcs.Util.Tree.Hashed ( hashedTreeIO, darcsAddMissingHashes ) +import Darcs.Util.Tree( Tree, treeHash, readBlob, TreeItem(..) + , emptyTree, listImmediate, findTree ) +import Darcs.Util.Path( anchorPath, appendPath, floatPath + , parent, anchoredRoot + , AnchoredPath(..), Name(..) + , ioAbsoluteOrRemote, toPath, AbsolutePath ) +import Darcs.Util.Hash( encodeBase16, sha256, Hash(..) ) import Darcs.Util.DateTime ( formatDateTime, fromClockTime, parseDateTime, startOfTime ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.File ( withCurrentDirectory ) -import Darcs.Util.Path ( ioAbsoluteOrRemote, toPath, AbsolutePath ) import Darcs.Util.Exception ( clarifyErrors ) import Darcs.Util.Prompt ( askUser ) import Darcs.Util.Printer ( text, ($$) ) @@ -71,35 +72,45 @@ import Darcs.Patch.Depends ( getUncovered ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, info, hopefully ) -import Darcs.Patch ( Named, showPatch, patch2patchinfo, fromPrim, fromPrims, - infopatch, adddeps, getdeps, effect, patchcontents, - RepoPatch, apply, listTouchedFiles ) +import Darcs.Patch ( IsRepoType, showPatch, fromPrim, fromPrims, + effect, + RepoPatch, apply, listTouchedFiles + , move ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Effect ( Effect ) +import Darcs.Patch.Named + ( patch2patchinfo + , infopatch, adddeps, getdeps, patchcontents + ) +import Darcs.Patch.Named.Wrapped ( WrappedNamed(..) ) +import qualified Darcs.Patch.Named.Wrapped as Wrapped ( getdeps ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..), (=/\=) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapFL_FL, - concatFL, mapRL, nullFL, (+>+) ) + concatFL, mapRL, nullFL, (+>+), (+<+) + , reverseRL, reverseFL ) import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), Sealed(..), unFreeLeft , flipSeal, unsafeUnsealFlipped ) import Darcs.Patch.Info ( piRename, piTag, isTag, PatchInfo, patchinfo, piName, piLog, piDate, piAuthor, makePatchname ) -import Darcs.Patch.V1 ( Patch ) -import Darcs.Patch.V2 ( RealPatch ) +import Darcs.Patch.V1 ( RepoPatchV1 ) +import Darcs.Patch.V2 ( RepoPatchV2 ) import Darcs.Patch.V1.Commute ( publicUnravel ) -import Darcs.Patch.V1.Core ( Patch(PP), isMerger ) -import Darcs.Patch.V2.Real ( mergeUnravelled ) +import Darcs.Patch.V1.Core ( RepoPatchV1(PP), isMerger ) +import Darcs.Patch.V2.RepoPatch ( mergeUnravelled ) import Darcs.Patch.Prim ( sortCoalesceFL ) +import Darcs.Patch.Prim.Class ( PrimOf ) import Darcs.Patch.Prim.V1 ( Prim ) +import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), newset2RL, newset2FL ) import Darcs.Patch.Progress ( progressFL ) import Darcs.Repository.Flags ( UpdateWorking(..), Reorder (..), UseIndex(..), ScanKnown(..) - , AllowConflicts(..), ExternalMerge(..), WantGuiPause(..) + , AllowConflicts(..), ExternalMerge(..), WantGuiPause(..), PatchFormat(..) , Compression(..), DryRun(NoDryRun), DiffAlgorithm(MyersDiff, PatienceDiff) ) import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), withRepositoryDirectory, createRepository, invalidateIndex, - tentativelyMergePatches, patchSetToPatches, + tentativelyMergePatches, createPristineDirectoryTree, revertRepositoryChanges, finalizeRepositoryChanges, applyToWorking @@ -113,8 +124,8 @@ import Darcs.Repository.Prefs( FileType(..) ) import Darcs.Repository.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2)) import Darcs.Repository.Motd ( showMotd ) -import Darcs.Repository.Lock ( writeBinFile ) -import Darcs.Repository.External ( fetchFilePS, Cachable(Uncachable) ) +import Darcs.Util.Lock ( writeBinFile ) +import Darcs.Util.External ( fetchFilePS, Cachable(Uncachable) ) import Darcs.Repository.Diff( treeDiff ) @@ -126,6 +137,7 @@ ) import Darcs.UI.Commands ( DarcsCommand(..), amInRepository, nodefaults, putInfo , normalCommand, withStdOpts ) +import Darcs.UI.Commands.Util.Tree ( treeHasDir, treeHasFile ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O @@ -191,7 +203,7 @@ , "Further options are accepted (see `darcs help init`)." , "" , "To convert a git repo to a new darcs one you may run:" - , " $ (cd gitrepo && git fast-export --all) | darcs convert import darcsmirror" + , " $ (cd gitrepo && git fast-export --all -M) | darcs convert import darcsmirror" , "" , "WARNING: git repositories with branches will produce weird results," , " use at your own risks." @@ -377,20 +389,20 @@ mysimplename <- makeRepoName opts repodir createDirectory mysimplename setCurrentDirectory mysimplename - createRepository False (withWorkingDir opts) (runPatchIndex opts) + createRepository PatchFormat2 (withWorkingDir opts) (runPatchIndex opts) writeBinFile (darcsdir++"/hashed_inventory") "" withRepoLock NoDryRun (useCache opts) NoUpdateWorking (umask opts) $ V2Job $ \repository -> withRepositoryDirectory (useCache opts) repodir $ V1Job $ \themrepo -> do theirstuff <- readRepo themrepo - let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff + let patches = mapFL_FL (convertNamed . hopefully) $ newset2FL theirstuff outOfOrderTags = catMaybes $ mapRL oot $ newset2RL theirstuff where oot t = if isTag (info t) && info t `notElem` inOrderTags theirstuff - then Just (info t, getdeps $ hopefully t) + then Just (info t, Wrapped.getdeps $ hopefully t) else Nothing fixDep p = case lookup p outOfOrderTags of Just d -> p : concatMap fixDep d Nothing -> [p] - convertOne :: Patch Prim wX wY -> FL (RealPatch Prim) wX wY + convertOne :: RepoPatchV1 Prim wX wY -> FL (RepoPatchV2 Prim) wX wY convertOne x | isMerger x = case mergeUnravelled $ publicUnravel x of Just (FlippedSeal y) -> case effect y =/\= effect x of @@ -405,10 +417,12 @@ fromPrims (effect x) convertOne (PP x) = fromPrim x :>: NilFL convertOne _ = impossible - convertFL :: FL (Patch Prim) wX wY -> FL (RealPatch Prim) wX wY + convertFL :: FL (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY convertFL = concatFL . mapFL_FL convertOne - convertNamed :: Named (Patch Prim) wX wY -> PatchInfoAnd (RealPatch Prim) wX wY - convertNamed n = n2pia $ + convertNamed :: WrappedNamed ('RepoType 'NoRebase) (RepoPatchV1 Prim) wX wY + -> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY + convertNamed (NormalP n) + = n2pia $ NormalP $ adddeps (infopatch (convertInfo $ patch2patchinfo n) $ convertFL $ patchcontents n) (map convertInfo $ concatMap fixDep $ getdeps n) @@ -417,7 +431,7 @@ applySome xs = do -- TODO this unsafeCoerce hack is because we don't keep track of the repository state properly -- Really sequence_ $ mapFL applySome below should instead be a repeated add operation - -- there doesn't seem to be any reason we need to do a merge here. - let repository2 = unsafeCoerce# repository :: Repository (RealPatch Prim) wA wB wA + let repository2 = unsafeCoerce# repository :: Repository ('RepoType 'NoRebase) (RepoPatchV2 Prim) wA wB wA Sealed pw <- tentativelyMergePatches repository2 "convert" YesAllowConflicts NoUpdateWorking NoExternalMerge NoWantGuiPause @@ -494,27 +508,28 @@ Nothing -> return () Just f -> writeMarks f newMarks -fastExport' :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u r -> Marks -> IO Marks +fastExport' :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p r u r -> Marks -> IO Marks fastExport' repo marks = do putStrLn "progress (reading repository)" patchset <- readRepo repo marksref <- newIORef marks let patches = newset2FL patchset tags = inOrderTags patchset - mark :: (PatchInfoAnd p) x y -> Int -> TreeIO () + mark :: (PatchInfoAnd rt p) x y -> Int -> TreeIO () mark p n = liftIO $ do putStrLn $ "mark :" ++ show n modifyIORef marksref $ \m -> addMark m n (patchHash p) -- apply a single patch to build the working tree of the last exported version checkOne :: (RepoPatch p, ApplyState p ~ Tree) - => Int -> (PatchInfoAnd p) x y -> TreeIO () + => Int -> (PatchInfoAnd rt p) x y -> TreeIO () checkOne n p = do apply p unless (inOrderTag tags p || (getMark marks n == Just (patchHash p))) $ fail $ "FATAL: Marks do not correspond: expected " ++ - (show $ getMark marks n) ++ ", got " ++ (BC.unpack $ patchHash p) + show (getMark marks n) ++ ", got " ++ BC.unpack (patchHash p) -- build the working tree of the last version exported by convert --export check :: (RepoPatch p, ApplyState p ~ Tree) - => Int -> FL (PatchInfoAnd p) x y -> TreeIO (Int, FlippedSeal( FL (PatchInfoAnd p)) y) + => Int -> FL (PatchInfoAnd rt p) x y -> TreeIO (Int, FlippedSeal( FL (PatchInfoAnd rt p)) y) check _ NilFL = return (1, flipSeal NilFL) check n allps@(p:>:ps) | n <= lastMark marks = checkOne n p >> check (next tags n p) ps @@ -533,8 +548,8 @@ dumpPatches :: (RepoPatch p, ApplyState p ~ Tree) => [PatchInfo] - -> (forall p0 x0 y0 . (PatchInfoAnd p0) x0 y0 -> Int -> TreeIO ()) - -> Int -> FL (PatchInfoAnd p) x y -> TreeIO () + -> (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ()) + -> Int -> FL (PatchInfoAnd rt p) x y -> TreeIO () dumpPatches _ _ _ NilFL = liftIO $ putStrLn "progress (patches converted)" dumpPatches tags mark n (p:>:ps) = do apply p @@ -544,7 +559,7 @@ dumpFiles $ map floatPath $ listTouchedFiles p dumpPatches tags mark (next tags n p) ps -dumpTag :: (PatchInfoAnd p) x y -> Int -> TreeIO () +dumpTag :: (PatchInfoAnd rt p) x y -> Int -> TreeIO () dumpTag p n = dumpBits [ BLU.fromString $ "progress TAG " ++ cleanTagName p , BLU.fromString $ "tag " ++ cleanTagName p -- FIXME is this valid? @@ -604,8 +619,8 @@ _ -> ([c], False) -dumpPatch :: (forall p0 x0 y0 . (PatchInfoAnd p0) x0 y0 -> Int -> TreeIO ()) - -> (PatchInfoAnd p) x y -> Int +dumpPatch :: (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ()) + -> (PatchInfoAnd rt p) x y -> Int -> TreeIO () dumpPatch mark p n = do dumpBits [ BLC.pack $ "progress " ++ show n ++ ": " ++ piName (info p) @@ -627,7 +642,7 @@ -- john -> john -- john john -- -> john -patchAuthor :: (PatchInfoAnd p) x y -> String +patchAuthor :: (PatchInfoAnd rt p) x y -> String patchAuthor p | null author = unknownEmail "unknown" | otherwise = case span (/='<') author of @@ -652,11 +667,11 @@ emailPad email = "<" ++ email ++ ">" mkAuthor name email = name ++ " " ++ email -patchDate :: (PatchInfoAnd p) x y -> String +patchDate :: (PatchInfoAnd rt p) x y -> String patchDate = formatDateTime "%s +0000" . fromClockTime . toClockTime . piDate . info -patchMessage :: (PatchInfoAnd p) x y -> BLU.ByteString +patchMessage :: (PatchInfoAnd rt p) x y -> BLU.ByteString patchMessage p = BL.concat [ BLU.fromString (piName $ info p) , case unlines . piLog $ info p of "" -> BL.empty @@ -672,12 +687,21 @@ data RefId = MarkId Int | HashId B.ByteString | Inline deriving Show +-- Newish (> 1.7.6.1) Git either quotes filenames or has two +-- non-special-char-containing paths. Older git doesn't do any quoting, so +-- we'll have to manually try and find the correct paths, when we use the +-- paths. +data CopyRenameNames = Quoted B.ByteString B.ByteString + | Unquoted B.ByteString deriving Show + data Object = Blob (Maybe Int) Content | Reset Branch (Maybe RefId) | Commit Branch Marked AuthorInfo Message | Tag Int AuthorInfo Message | Modify (Either Int Content) B.ByteString -- (mark or content), filename | Gitlink B.ByteString + | Copy CopyRenameNames + | Rename CopyRenameNames | Delete B.ByteString -- filename | From Int | Merge Int @@ -686,20 +710,21 @@ deriving Show type Ancestors = (Marked, [Int]) -data State = Toplevel Marked Branch - | InCommit Marked Ancestors Branch (Tree IO) PatchInfo - | Done +data State p where + Toplevel :: Marked -> Branch -> State p + InCommit :: Marked -> Ancestors -> Branch -> Tree IO -> RL (PrimOf p) cX cY -> PatchInfo -> State p + Done :: State p -instance Show State where - show (Toplevel _ _) = "Toplevel" - show (InCommit _ _ _ _ _) = "InCommit" +instance Show (State p) where + show Toplevel {} = "Toplevel" + show InCommit {} = "InCommit" show Done = "Done" fastImport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () fastImport _ opts [outrepo] = do createDirectory outrepo withCurrentDirectory outrepo $ do - createRepository (patchFormat opts == O.PatchFormat1) (withWorkingDir opts) (runPatchIndex opts) + createRepository (patchFormat opts) (withWorkingDir opts) (runPatchIndex opts) withRepoLock NoDryRun (useCache opts) NoUpdateWorking (umask opts) $ RepoJob $ \repo -> do -- TODO implement --dry-run, which would be read-only? marks <- fastImport' repo emptyMarks @@ -707,14 +732,14 @@ return marks fastImport _ _ _ = fail "I need exactly one output repository." -fastImport' :: forall p r u . (RepoPatch p, ApplyState p ~ Tree) => - Repository p r u r -> Marks -> IO () +fastImport' :: forall rt p r u . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => + Repository rt p r u r -> Marks -> IO () fastImport' repo marks = do pristine <- readRecorded repo marksref <- newIORef marks let initial = Toplevel Nothing $ BC.pack "refs/branches/master" - go :: State -> B.ByteString -> TreeIO () + go :: State p -> B.ByteString -> TreeIO () go state rest = do (rest', item) <- parseObject rest state' <- process state item case state' of @@ -734,9 +759,7 @@ (author'', date'') = span (/='>') $ BC.unpack author date' = dropWhile (`notElem` ("0123456789" :: String)) date'' author' = author'' ++ ">" - date = formatDateTime "%Y%m%d%H%M%S" $ case (parseDateTime "%s %z" date') of - Just x -> x - Nothing -> startOfTime + date = formatDateTime "%Y%m%d%H%M%S" $ fromMaybe startOfTime (parseDateTime "%s %z" date') liftIO $ patchinfo date (if tag then "TAG " ++ name else name) author' log addtag author msg = @@ -744,14 +767,14 @@ gotany <- liftIO $ doesFileExist $ darcsdir "tentative_hashed_pristine" deps <- if gotany then liftIO $ getUncovered `fmap` readTentativeRepo repo else return [] - let ident = NilFL :: FL (RealPatch Prim) cX cX - patch = adddeps (infopatch info_ ident) deps + let ident = NilFL :: FL (RepoPatchV2 Prim) cX cX + patch = NormalP (adddeps (infopatch info_ ident) deps) void $ liftIO $ addToTentativeInventory (extractCache repo) GzipCompression (n2pia patch) -- processing items updateHashes = do - let nodarcs = (\(AnchoredPath (Name x:_)) _ -> x /= BC.pack darcsdir) + let nodarcs = \(AnchoredPath (Name x:_)) _ -> x /= BC.pack darcsdir hashblobs (File blob@(T.Blob con NoHash)) = do hash <- sha256 `fmap` readBlob blob return $ File (T.Blob con hash) @@ -774,7 +797,17 @@ -- Either missing (not possible) or non-empty. _ -> return () - process :: State -> Object -> TreeIO State + -- generate a Hunk primitive patch from diffing + diffCurrent :: State p -> TreeIO (State p) + diffCurrent (InCommit mark ancestors branch start ps info_) = do + current <- updateHashes + Sealed diff <- unFreeLeft `fmap` + liftIO (treeDiff PatienceDiff (const TextFile) start current) + let newps = ps +<+ reverseFL diff + return $ InCommit mark ancestors branch current newps info_ + diffCurrent _ = error "This is never valid outside of a commit." + + process :: State p -> Object -> TreeIO (State p) process s (Progress p) = do liftIO $ putStrLn ("progress " ++ BC.unpack p) return s @@ -784,7 +817,7 @@ modify $ \s -> s { tree = tree' } -- lets dump the right tree, without _darcs let root = encodeBase16 $ treeHash tree' liftIO $ do - putStrLn $ "\\o/ It seems we survived. Enjoy your new repo." + putStrLn "\\o/ It seems we survived. Enjoy your new repo." B.writeFile (darcsdir "tentative_pristine") $ BC.concat [BC.pack "pristine:", root] return Done @@ -793,7 +826,7 @@ if Just what == n then addtag author msg else liftIO $ putStrLn $ "WARNING: Ignoring out-of-order tag " ++ - (head $ lines $ BC.unpack msg) + head (lines $ BC.unpack msg) return (Toplevel n b) process (Toplevel n _) (Reset branch from) = @@ -805,7 +838,7 @@ return $ Toplevel n branch process (Toplevel n b) (Blob (Just m) bits) = do - TM.writeFile (markpath m) $ (BLC.fromChunks [bits]) + TM.writeFile (markpath m) (BLC.fromChunks [bits]) return $ Toplevel n b process x (Gitlink link) = do @@ -818,29 +851,61 @@ addtag author pbranch info_ <- makeinfo author message False startstate <- updateHashes - return $ InCommit mark (previous, []) branch startstate info_ + return $ InCommit mark (previous, []) branch startstate NilRL info_ - process s@(InCommit _ _ _ _ _) (Modify (Left m) path) = do + process s@InCommit {} (Modify (Left m) path) = do TM.copy (markpath m) (floatPath $ BC.unpack path) - return s + diffCurrent s - process s@(InCommit _ _ _ _ _) (Modify (Right bits) path) = do + process s@InCommit {} (Modify (Right bits) path) = do TM.writeFile (floatPath $ BC.unpack path) (BLC.fromChunks [bits]) - return s + diffCurrent s - process s@(InCommit _ _ _ _ _) (Delete path) = do - let floatedPath = floatPath . BC.unpack $ path + process s@InCommit {} (Delete path) = do + let floatedPath = floatPath $ BC.unpack path TM.unlink floatedPath deleteEmptyParents floatedPath - return s + diffCurrent s - process (InCommit mark (prev, current) branch start info_) (From from) = do - return $ InCommit mark (prev, from:current) branch start info_ + process (InCommit mark (prev, current) branch start ps info_) (From from) = + return $ InCommit mark (prev, from:current) branch start ps info_ - process (InCommit mark (prev, current) branch start info_) (Merge from) = do - return $ InCommit mark (prev, from:current) branch start info_ + process (InCommit mark (prev, current) branch start ps info_) (Merge from) = + return $ InCommit mark (prev, from:current) branch start ps info_ - process (InCommit mark ancestors branch start info_) x = do + process s@InCommit {} (Copy names) = do + (from, to) <- extractNames names + TM.copy (floatPath $ BC.unpack from) (floatPath $ BC.unpack to) + -- We can't tell Darcs that a file has been copied, so it'll + -- show as an addfile. + diffCurrent s + + process s@(InCommit mark ancestors branch start _ info_) (Rename names) = do + (from, to) <- extractNames names + let uFrom = BC.unpack from + uTo = BC.unpack to + parentDir = parent $ floatPath uTo + targetDirExists <- liftIO $ treeHasDir start uTo + targetFileExists <- liftIO $ treeHasFile start uTo + parentDirExists <- + liftIO $ treeHasDir start (anchorPath "" parentDir) + -- If the target exists, remove it; if it doesn't, add all + -- its parent directories. + if targetDirExists || targetFileExists + then TM.unlink $ floatPath uTo + else unless parentDirExists $ TM.createDirectory parentDir + (InCommit _ _ _ _ newPs _) <- diffCurrent s + TM.rename (floatPath uFrom) (floatPath uTo) + let ps' = newPs :<: move uFrom uTo + current <- updateHashes + -- ensure empty dirs get deleted + deleteEmptyParents (floatPath uFrom) + -- run diffCurrent to add the dir deletions prims + diffCurrent (InCommit mark ancestors branch current ps' info_) + + -- When we leave the commit, create a patch for the cumulated + -- prims. + process (InCommit mark ancestors branch _ ps info_) x = do case ancestors of (_, []) -> return () -- OK, previous commit is the ancestor (Just n, list) @@ -851,11 +916,9 @@ (Nothing, list) -> liftIO $ putStrLn $ "WARNING: Linearising non-linear ancestry " ++ show list - current <- updateHashes - Sealed diff - <- unFreeLeft `fmap` (liftIO $ treeDiff PatienceDiff (const TextFile) start current) - prims <- return $ fromPrims $ sortCoalesceFL diff - let patch = infopatch info_ ((NilFL :: FL p cX cX) +>+ prims) + {- current <- updateHashes -} -- why not? + (prims :: FL p cX cY) <- return $ fromPrims $ sortCoalesceFL $ reverseRL ps + let patch = NormalP (infopatch info_ ((NilFL :: FL p cX cX) +>+ prims)) void $ liftIO $ addToTentativeInventory (extractCache repo) GzipCompression (n2pia patch) case mark of @@ -869,6 +932,36 @@ liftIO $ print obj fail $ "Unexpected object in state " ++ show state + extractNames :: CopyRenameNames + -> TreeIO (BC.ByteString, BC.ByteString) + extractNames names = case names of + Quoted f t -> return (f, t) + Unquoted uqNames -> do + let spaceIndices = BC.elemIndices ' ' uqNames + splitStr = second (BC.drop 1) . flip BC.splitAt uqNames + -- Reverse the components, so we find the longest + -- prefix existing name. + spaceComponents = reverse $ map splitStr spaceIndices + componentCount = length spaceComponents + if componentCount == 1 + then return $ head spaceComponents + else do + let dieMessage = unwords + [ "Couldn't determine move/rename" + , "source/destination filenames, with the" + , "data produced by this (old) version of" + , "git, since it uses unquoted, but" + , "special-character-containing paths." + ] + floatUnpack = floatPath . BC.unpack + lPathExists (l,_) = + TM.fileExists $ floatUnpack l + finder [] = error dieMessage + finder (x : rest) = do + xExists <- lPathExists x + if xExists then return x else finder rest + finder spaceComponents + void $ hashedTreeIO (go initial B.empty) pristine $ darcsdir "pristine.hashed" finalizeRepositoryChanges repo YesUpdateWorking GzipCompression cleanRepository repo @@ -891,6 +984,8 @@ <|> p_commit <|> p_tag <|> p_modify + <|> p_rename + <|> p_copy <|> p_from <|> p_merge <|> p_delete @@ -942,6 +1037,12 @@ p_from = lexString "from" >> From `fmap` p_marked p_merge = lexString "merge" >> Merge `fmap` p_marked p_delete = lexString "D" >> Delete `fmap` p_maybeQuotedName + p_rename = do lexString "R" + names <- p_maybeQuotedCopyRenameNames + return $ Rename names + p_copy = do lexString "C" + names <- p_maybeQuotedCopyRenameNames + return $ Copy names p_modify = do lexString "M" mode <- lex $ A.takeWhile (A.inClass "01234567890") mark <- p_refid @@ -952,6 +1053,12 @@ MarkId n -> return $ Modify (Left n) path Inline -> do bits <- p_data return $ Modify (Right bits) path + p_maybeQuotedCopyRenameNames = + p_lexTwoQuotedNames <|> Unquoted `fmap` line + p_lexTwoQuotedNames = do + n1 <- lex p_quotedName + n2 <- lex p_quotedName + return $ Quoted n1 n2 p_maybeQuotedName = lex (p_quotedName <|> line) p_quotedName = do _ <- A.char '"' @@ -979,19 +1086,19 @@ fail $ "Error parsing stream. " ++ err ++ "\nContext: " ++ show ctx -patchHash :: PatchInfoAnd p cX cY -> BC.ByteString +patchHash :: PatchInfoAnd rt p cX cY -> BC.ByteString patchHash p = BC.pack $ show $ makePatchname (info p) -inOrderTag :: (Effect p) => [PatchInfo] -> PatchInfoAnd p wX wZ -> Bool +inOrderTag :: (Effect p) => [PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool inOrderTag tags p = isTag (info p) && info p `elem` tags && nullFL (effect p) -next :: (Effect p) => [PatchInfo] -> Int -> PatchInfoAnd p x y -> Int +next :: (Effect p) => [PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int next tags n p = if inOrderTag tags p then n else n + 1 -inOrderTags :: PatchSet p wS wX -> [PatchInfo] -inOrderTags (PatchSet _ ts) = go ts - where go :: RL(Tagged t1) wT wY -> [PatchInfo] - go (Tagged t _ _ :<: ts') = info t : go ts' +inOrderTags :: PatchSet rt p wS wX -> [PatchInfo] +inOrderTags (PatchSet ts _) = go ts + where go :: RL(Tagged rt t1) wT wY -> [PatchInfo] + go (ts' :<: Tagged t _ _) = info t : go ts' go NilRL = [] type Marks = M.IntMap BC.ByteString @@ -1012,7 +1119,7 @@ readMarks p = do lines' <- BC.split '\n' `fmap` BC.readFile p return $ foldl merge M.empty lines' `catchall` return emptyMarks - where merge set line = case (BC.split ':' line) of + where merge set line = case BC.split ':' line of [i, hash] -> M.insert (read $ BC.unpack i) (BC.dropWhile (== ' ') hash) set _ -> set -- ignore, although it is maybe not such a great idea... diff --git a/src/Darcs/UI/Commands/Diff.hs b/src/Darcs/UI/Commands/Diff.hs --- a/src/Darcs/UI/Commands/Diff.hs +++ b/src/Darcs/UI/Commands/Diff.hs @@ -19,15 +19,17 @@ module Darcs.UI.Commands.Diff ( diffCommand, getDiffDoc ) where -import Prelude hiding ( (^), all ) +import Prelude () +import Darcs.Prelude hiding ( all ) + import System.FilePath.Posix ( takeFileName, () ) import Darcs.Util.Workaround ( getCurrentDirectory ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Prompt ( askEnter ) import Control.Monad ( when ) import Data.List ( (\\) ) -import Storage.Hashed.Plain( writePlainTree ) -import Storage.Hashed.Darcs( hashedTreeIO ) +import Darcs.Util.Tree.Plain( writePlainTree ) +import Darcs.Util.Tree.Hashed( hashedTreeIO ) import Data.Maybe ( isJust ) import System.Directory ( findExecutable ) @@ -59,11 +61,12 @@ import Darcs.Patch.Witnesses.Ordered ( mapRL, (:>)(..), (+>+), RL(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd ) import Darcs.Patch.Witnesses.Sealed ( unseal, Sealed(..), seal ) -import Darcs.Patch ( RepoPatch, apply, listTouchedFiles, invert, fromPrims, anonymous ) +import Darcs.Patch ( RepoPatch, IsRepoType, apply, listTouchedFiles, invert, fromPrims ) import Darcs.Patch.Depends ( findCommonWithThem ) +import Darcs.Patch.Named.Wrapped ( anonymous ) import Darcs.Patch.Set ( PatchSet(..), newset2RL ) import Darcs.Patch.Info ( PatchInfo, showPatchInfoUI ) -import Darcs.Repository.Lock ( withTempDir ) +import Darcs.Util.Lock ( withTempDir ) import Darcs.Util.Printer ( Doc, putDoc, vcat, empty, RenderMode(..), ($$) ) #include "impossible.h" @@ -91,18 +94,21 @@ "The associated tag and match options are also understood, e.g. `darcs\n" ++ "diff --from-tag 1.0 --to-tag 1.1`. All these options assume an\n" ++ "ordering of the patch set, so results may be affected by operations\n" ++ - "such as `darcs optimize --reorder`.\n" ++ + "such as `darcs optimize reorder`.\n" ++ "\n" ++ "diff(1) is called with the arguments `-rN`. The `--unified` option causes\n" ++ "`-u` to be passed to diff(1). An additional argument can be passed\n" ++ "using `--diff-opts`, such as `--diff-opts=-ud` or `--diff-opts=-wU9`.\n" ++ "\n" ++ "The `--diff-command` option can be used to specify an alternative\n" ++ - "utility, such as meld (GNOME) or opendiff (OS X). Arguments may be\n" ++ - "included, separated by whitespace. The value is not interpreted by a\n" ++ - "shell, so shell constructs cannot be used. The arguments %1 and %2\n" ++ - "MUST be included, these are substituted for the two working trees\n" ++ - "being compared. If this option is used, `--diff-opts` is ignored.\n" + "utility. Arguments may be included, separated by whitespace. The value\n" ++ + "is not interpreted by a shell, so shell constructs cannot be used. The\n" ++ + "arguments %1 and %2 MUST be included, these are substituted for the two\n" ++ + "working trees being compared. For instance:\n" ++ + "\n" ++ + " darcs diff -p . --diff-command \"meld %1 %2\"\n" ++ + "\n" ++ + "If this option is used, `--diff-opts` is ignored.\n" diffBasicOpts :: DarcsOption a ([O.MatchFlag] @@ -209,7 +215,7 @@ let matchFlags = parseFlags O.matchRange opts Sealed all <- return $ case (secondMatch matchFlags, patchset) of (True, _) -> seal patchset - (False, PatchSet untagged tagged) -> seal $ PatchSet (unrecorded' :<: untagged) tagged + (False, PatchSet tagged untagged) -> seal $ PatchSet tagged (untagged :<: unrecorded') Sealed ctx <- return $ if firstMatch matchFlags then matchFirstPatchset matchFlags patchset @@ -269,7 +275,7 @@ askEnter "Hit return to move on..." return output -getDiffInfo :: RepoPatch p => [DarcsFlag] -> PatchSet p wStart wX -> [PatchInfo] +getDiffInfo :: (IsRepoType rt, RepoPatch p) => [DarcsFlag] -> PatchSet rt p wStart wX -> [PatchInfo] getDiffInfo opts ps = let matchFlags = parseFlags O.matchRange opts infos = mapRL info . newset2RL diff --git a/src/Darcs/UI/Commands/Dist.hs b/src/Darcs/UI/Commands/Dist.hs --- a/src/Darcs/UI/Commands/Dist.hs +++ b/src/Darcs/UI/Commands/Dist.hs @@ -30,7 +30,8 @@ , doFastZip' ) where -import Prelude hiding ( (^), writeFile ) +import Prelude () +import Darcs.Prelude hiding ( writeFile ) import Data.ByteString.Lazy ( writeFile ) import Data.Char ( isAlphaNum ) @@ -46,7 +47,7 @@ import Codec.Compression.GZip ( compress ) import Codec.Archive.Zip ( emptyArchive, fromArchive, addEntryToArchive, toEntry ) -import Darcs.Repository.External ( fetchFilePS, Cachable( Uncachable ) ) +import Darcs.Util.External ( fetchFilePS, Cachable( Uncachable ) ) import Darcs.Util.Global ( darcsdir ) import Darcs.Repository.HashedRepo ( inv2pris ) import Darcs.Repository.HashedIO ( pathsAndContents ) @@ -62,15 +63,9 @@ import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) -import Darcs.Repository.Lock ( withTempDir ) -import Darcs.Patch.Match - ( haveNonrangeMatch - , firstMatch - ) -import Darcs.Repository.Match - ( getFirstMatch - , getNonrangeMatch - ) +import Darcs.Util.Lock ( withTempDir ) +import Darcs.Patch.Match ( haveNonrangeMatch ) +import Darcs.Repository.Match ( getNonrangeMatch ) import Darcs.Repository ( withRepository, withRepositoryDirectory, RepoJob(..), setScriptsExecutable, repoPatchType, createPartialsPristineDirectoryTree ) @@ -116,7 +111,7 @@ = O.distname ^ O.distzip ^ O.workingRepoDir - ^ O.matchOne + ^ O.matchUpToOne ^ O.setScriptsExecutable ^ O.storeInMemory @@ -165,7 +160,7 @@ -> IO () distCmd _ opts _ | DistZip `elem` opts = doFastZip opts distCmd _ opts _ = withRepository (useCache opts) $ RepoJob $ \repository -> do - let matchFlags = parseFlags O.matchOne opts + let matchFlags = parseFlags O.matchUpToOne opts formerdir <- getCurrentDirectory let distname = getDistName formerdir [x | DistName x <- opts] predist <- getPrefval "predist" @@ -174,10 +169,7 @@ setCurrentDirectory formerdir withTempDir (toFilePath tempdir takeFileName distname) $ \ddir -> do if haveNonrangeMatch (repoPatchType repository) matchFlags - then - if firstMatch matchFlags - then withCurrentDirectory ddir $ getFirstMatch repository matchFlags - else withCurrentDirectory ddir $ getNonrangeMatch repository matchFlags + then withCurrentDirectory ddir $ getNonrangeMatch repository matchFlags else createPartialsPristineDirectoryTree repository [""] (toFilePath ddir) ec <- case predist of Nothing -> return ExitSuccess Just pd -> system pd diff --git a/src/Darcs/UI/Commands/GZCRCs.hs b/src/Darcs/UI/Commands/GZCRCs.hs --- a/src/Darcs/UI/Commands/GZCRCs.hs +++ b/src/Darcs/UI/Commands/GZCRCs.hs @@ -27,6 +27,9 @@ , doCRCWarnings ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^) ) import Control.Monad ( when, unless, forM_ ) import Control.Monad.Trans ( liftIO ) @@ -49,7 +52,7 @@ import Darcs.Repository.Cache ( Cache(..), writable, isThisRepo, hashedFilePath, allHashedDirs ) import Darcs.Repository.InternalTypes ( extractCache ) -import Darcs.Repository.Lock ( gzWriteAtomicFilePSs ) +import Darcs.Util.Lock ( gzWriteAtomicFilePSs ) import Darcs.Patch ( RepoPatch ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags ) @@ -153,7 +156,7 @@ withRepository (useCache opts) (RepoJob (gzcrcs' opts)) gzcrcsCmd _ _ _ = error "You must specify --check or --repair for gzcrcs" -gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p wR wU wT -> IO () +gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository rt p wR wU wT -> IO () gzcrcs' opts repo = do -- Somewhat ugly IORef use here because it's convenient, would be nicer to -- pre-filter the list of locs to check and then decide whether to print diff --git a/src/Darcs/UI/Commands/Help.hs b/src/Darcs/UI/Commands/Help.hs --- a/src/Darcs/UI/Commands/Help.hs +++ b/src/Darcs/UI/Commands/Help.hs @@ -21,6 +21,9 @@ printVersion, listAvailableCommands ) where +import Prelude () +import Darcs.Prelude + import Darcs.UI.Flags ( DarcsFlag , environmentHelpEmail @@ -41,12 +44,11 @@ , usage ) import Darcs.UI.External ( viewDoc ) -import Darcs.Repository.Lock ( environmentHelpTmpdir, environmentHelpKeepTmpdir - , environmentHelpLocks ) +import Darcs.Util.Lock ( environmentHelpTmpdir, environmentHelpKeepTmpdir + , environmentHelpLocks ) import Darcs.Patch.Match ( helpOnMatchers ) import Darcs.Repository.Prefs ( boringFileHelp, binariesFileHelp, environmentHelpHome ) -import Darcs.Repository.Ssh ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort ) -import Darcs.Repository.External ( environmentHelpProtocols ) +import Darcs.Util.Ssh ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Path ( AbsolutePath ) import Control.Arrow ( (***) ) @@ -202,7 +204,6 @@ environmentHelpSshPort, environmentHelpProxy, environmentHelpProxyPassword, - environmentHelpProtocols, environmentHelpTimeout] -- | This module is responsible for emitting a darcs "man-page", a @@ -405,8 +406,8 @@ environmentHelpPager :: ([String], [String]) environmentHelpPager = (["DARCS_PAGER", "PAGER"],[ - "Darcs will sometimes invoke a pager if it deems output to be too long", - "to fit onscreen. Darcs will use the pager specified by $DARCS_PAGER", + "Darcs will invoke a pager if the output of some command is longer", + "than 20 lines. Darcs will use the pager specified by $DARCS_PAGER", "or $PAGER. If neither are set, `less` will be used."]) environmentHelpTimeout :: ([String], [String]) diff --git a/src/Darcs/UI/Commands/Init.hs b/src/Darcs/UI/Commands/Init.hs --- a/src/Darcs/UI/Commands/Init.hs +++ b/src/Darcs/UI/Commands/Init.hs @@ -17,9 +17,12 @@ module Darcs.UI.Commands.Init ( initialize, initializeCmd ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^) ) import Darcs.UI.Commands - ( DarcsCommand(..), withStdOpts, nodefaults, amNotInRepository, putInfo, formatPath ) + ( DarcsCommand(..), withStdOpts, nodefaults, amNotInRepository, putInfo ) import Darcs.UI.Flags ( DarcsFlag( WorkRepoDir ), withWorkingDir, patchFormat, runPatchIndex ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O @@ -30,20 +33,20 @@ import Darcs.UI.Options.All ( ) import Darcs.Util.Printer ( text ) import Darcs.Util.Path ( AbsolutePath ) +import Darcs.Util.Text ( quote ) import Darcs.Repository ( createRepository ) initializeDescription :: String -initializeDescription = "Make the current directory or the specified directory a repository." +initializeDescription = "Create an empty repository." initializeHelp :: String initializeHelp = - "The `darcs initialize` command turns the current directory into a\n" ++ - "Darcs repository. Any existing files and subdirectories become\n" ++ - "UNSAVED changes: record them with `darcs record --look-for-adds`.\n" ++ + "The `darcs initialize` command creates an empty repository in the\n" ++ + "current directory. This repository lives in a new `_darcs` directory,\n"++ + "which stores version control metadata and settings.\n" ++ "\n" ++ - "This command creates the `_darcs` directory, which stores version\n" ++ - "control metadata. It also contains per-repository settings in\n" ++ - "`_darcs/prefs/`, which you can read about in the user manual.\n" ++ + "Any existing files and subdirectories become UNSAVED changes:\n" ++ + "record them with `darcs record --look-for-adds`.\n" ++ "\n" ++ "By default, patches of the new repository are in the darcs-2 semantics.\n" ++ "However it is possible to create a repository in darcs-1 semantics with\n" ++ @@ -102,9 +105,9 @@ initializeCmd _ opts [] = do location <- amNotInRepository opts case location of - Left msg -> fail $ "Unable to " ++ formatPath ("darcs " ++ commandName initialize) + Left msg -> fail $ "Unable to " ++ quote ("darcs " ++ commandName initialize) ++ " here.\n\n" ++ msg Right () -> do - createRepository (patchFormat opts == O.PatchFormat1) (withWorkingDir opts) (runPatchIndex opts) + createRepository (patchFormat opts) (withWorkingDir opts) (runPatchIndex opts) putInfo opts $ text "Repository initialized." initializeCmd _ _ _ = fail "You must provide 'initialize' with either zero or one argument." diff --git a/src/Darcs/UI/Commands/Log.hs b/src/Darcs/UI/Commands/Log.hs --- a/src/Darcs/UI/Commands/Log.hs +++ b/src/Darcs/UI/Commands/Log.hs @@ -23,7 +23,8 @@ , changelog, getLogInfo ) where -import Prelude hiding ( (^), log, catch ) +import Prelude () +import Darcs.Prelude import Unsafe.Coerce (unsafeCoerce) import Data.List ( intersect, sort, nub, find ) @@ -31,20 +32,19 @@ import Control.Arrow ( second ) import Control.Exception ( catch, IOException ) import Control.Monad.State.Strict -import Control.Applicative ((<$>)) import Darcs.UI.PrintPatch ( showFriendly ) import Darcs.Patch.PatchInfoAnd ( fmapFLPIAP, hopefullyM, info ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, findRepository ) import Darcs.UI.External ( viewDocWith ) import Darcs.UI.Flags - ( DarcsFlag(GenContext, HumanReadable, + ( DarcsFlag(GenContext, MachineReadable, Count, Interactive, NumberPatches, XMLOutput, Summary, Verbose, Debug, NoPatchIndexFlag) , doReverse, showChangesOnlyToFiles , useCache, maxCount, umask - , verbosity, isUnified, isInteractive, diffAlgorithm, hasSummary + , verbosity, isUnified, isInteractive, hasSummary , fixSubPaths, getRepourl ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O @@ -55,7 +55,7 @@ readRepo, unrecordedChanges, withRepoLockCanFail ) import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(MyersDiff), UpdateWorking(..) ) -import Darcs.Repository.Lock ( withTempDir ) +import Darcs.Util.Lock ( withTempDir ) import Darcs.Patch.Set ( PatchSet(..), newset2RL ) import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts ) import Darcs.Patch.Format ( PatchListFormat ) @@ -68,8 +68,9 @@ import Darcs.Patch.TouchesFiles ( lookTouch ) import Darcs.Patch.Type ( PatchType(PatchType) ) import Darcs.Patch.Apply ( Apply, ApplyState ) -import Darcs.Patch ( invert, xmlSummary, description, - effectOnFilePaths, listTouchedFiles ) +import Darcs.Patch ( IsRepoType, invert, xmlSummary, description, + effectOnFilePaths, listTouchedFiles, showPatch ) +import Darcs.Patch.Named.Wrapped ( (:~:)(..) ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(NilFL), RL(..), filterOutFLFL, filterRL, @@ -93,15 +94,16 @@ import Darcs.UI.SelectChanges ( viewChanges ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Repository.PatchIndex ( PatchFilter, maybeFilterPatches, attemptCreatePatchIndex ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) logHelp :: String -logHelp = - "The `darcs log` command lists the patches that constitute the\n" ++ - "current repository or, with `--repo`, a remote repository. Without\n" ++ - "options or arguments, ALL patches will be listed.\n" ++ - "\n" ++ logHelp' ++ - "\n" ++ logHelp'' +logHelp = unlines + [ "The `darcs log` command lists patches of the current repository or," + , "with `--repo`, a remote repository. Without options or arguments," + , "ALL patches will be listed." + , ""] + ++ logHelp' + ++ logHelp'' logBasicOpts :: DarcsOption a ([O.MatchFlag] @@ -251,33 +253,32 @@ then (reverse xs, b, c) else (xs, b, c) - --- FIXME: this prose is unreadable. --twb, 2009-08 logHelp' :: String -logHelp' = - "When given one or more files or directories as arguments, only\n" ++ - "patches which affect those files or directories are listed. This\n" ++ - "includes patches that happened to files before they were moved or\n" ++ - "renamed.\n" ++ - "\n" ++ - "When given a `--from-tag`, `--from-patch` or `--from-match`, only patches\n" ++ - "since that tag or patch are listed. Similarly, the `--to-tag`,\n" ++ - "`--to-patch` and `--to-match` options restrict the list to older patches.\n" ++ - "\n" ++ - "The `--last` and `--max-count` options both limit the number of patches\n" ++ - "listed. The former applies BEFORE other filters, whereas the latter\n" ++ - "applies AFTER other filters. For example `darcs log foo.c\n" ++ - "--max-count 3` will print the last three patches that affect foo.c,\n" ++ - "whereas `darcs log --last 3 foo.c` will, of the last three\n" ++ - "patches, print only those that affect foo.c.\n" +logHelp' = unlines + [ "When given files or directories paths as arguments, only patches which" + , "affect those paths are listed. This includes patches that happened to" + , "files before they were moved or renamed." + , "" + , "When given `--from-tag` or `--from-patch`, only patches since that tag" + , "or patch are listed. Similarly, the `--to-tag` and `--to-patch`" + , "options restrict the list to older patches." + , "" + , "The `--last` and `--max-count` options both limit the number of patches" + , "listed. The former applies BEFORE other filters, whereas the latter" + , "applies AFTER other filters. For example `darcs log foo.c" + , "--max-count 3` will print the last three patches that affect foo.c," + , "whereas `darcs log --last 3 foo.c` will, of the last three" + , "patches, print only those that affect foo.c." + , "" + ] -getLogInfo :: forall p wX wY - . (Matchable p, ApplyState p ~ Tree) +getLogInfo :: forall rt p wX wY + . (IsRepoType rt, Matchable p, ApplyState p ~ Tree) => Maybe Int -> [MatchFlag] -> Bool -> Maybe [FilePath] - -> PatchFilter p - -> PatchSet p wX wY - -> IO ( [(Sealed2 (PatchInfoAnd p), [FilePath])] + -> PatchFilter rt p + -> PatchSet rt p wX wY + -> IO ( [(Sealed2 (PatchInfoAnd rt p), [FilePath])] , [(FilePath, FilePath)] , Maybe Doc ) getLogInfo maxCountFlag matchFlags onlyToFilesFlag plain_fs patchFilter ps = @@ -300,7 +301,7 @@ sp2s = if secondMatch matchFlags then matchSecondPatchset matchFlags ps else Sealed ps - pf = if haveNonrangeMatch (PatchType :: PatchType p) matchFlags + pf = if haveNonrangeMatch (PatchType :: PatchType rt p) matchFlags then matchAPatchread matchFlags else \_ -> True @@ -309,7 +310,7 @@ | otherwise = (pfs, renames, doc) onlyRelated (Sealed2 p, fs) = - (Sealed2 $ fmapFLPIAP (filterOutFLFL (unrelated fs)) p, fs) + (Sealed2 $ fmapFLPIAP (filterOutFLFL (unrelated fs)) (\_ -> ReflPatch) p, fs) unrelated fs p -- If the change does not affect the patches we are looking at, @@ -325,12 +326,12 @@ -- "Just n" -- returns at most n patches touching the file (starting from the -- beginning of the patch list). filterPatchesByNames - :: forall p + :: forall rt p . (Matchable p, ApplyState p ~ Tree) => Maybe Int -- ^ maxcount -> [FilePath] -- ^ filenames - -> [Sealed2 (PatchInfoAnd p)] -- ^ patchlist - -> ([(Sealed2 (PatchInfoAnd p),[FilePath])], [(FilePath, FilePath)], Maybe Doc) + -> [Sealed2 (PatchInfoAnd rt p)] -- ^ patchlist + -> ([(Sealed2 (PatchInfoAnd rt p),[FilePath])], [(FilePath, FilePath)], Maybe Doc) filterPatchesByNames maxcount fns patches = removeNonRenames $ evalState (filterPatchesByNames' fns patches) (maxcount, initRenames) where removeNonRenames (ps, renames, doc) = (ps, removeIds renames, doc) @@ -372,18 +373,16 @@ (-:-) :: a -> ([a],b,c) -> ([a],b,c) x -:- ~(xs,y,z) = (x:xs,y,z) -changelog :: forall p wStart wX +changelog :: forall rt p wStart wX . ( Apply p, ApplyState p ~ Tree, ShowPatch p, IsHunk p , PrimPatchBase p, PatchListFormat p , Conflict p, CommuteNoConflicts p ) - => [DarcsFlag] -> PatchSet p wStart wX - -> ([(Sealed2 (PatchInfoAnd p), [FilePath])], [(FilePath, FilePath)], Maybe Doc) + => [DarcsFlag] -> PatchSet rt p wStart wX + -> ([(Sealed2 (PatchInfoAnd rt p), [FilePath])], [(FilePath, FilePath)], Maybe Doc) -> Doc changelog opts patchset (pis_and_fs, createdAsFs, mbErr) | Count `elem` opts = text $ show $ length pis_and_fs - | MachineReadable `elem` opts = - maybe (vsep $ map (unseal2 (showPatchInfo.info)) pis) errorDoc mbErr | XMLOutput `elem` opts = text "" $$ vcat created_as_xml @@ -393,9 +392,11 @@ mbAppendErr $ vsep (map (number_patch change_with_summary) pis) | otherwise = mbAppendErr $ vsep (map (number_patch description') pis) where mbAppendErr = maybe id (\err -> ($$ err)) mbErr - change_with_summary :: Sealed2 (PatchInfoAnd p) -> Doc + change_with_summary :: Sealed2 (PatchInfoAnd rt p) -> Doc change_with_summary (Sealed2 hp) - | Just p <- hopefullyM hp = showFriendly (verbosity opts) (hasSummary O.NoSummary opts) p + | Just p <- hopefullyM hp = if MachineReadable `elem` opts + then showPatch p + else showFriendly (verbosity opts) (hasSummary O.NoSummary opts) p | otherwise = description hp $$ indent (text "[this patch is unavailable]") @@ -426,46 +427,37 @@ Just n -> text (show n++":") <+> f x Nothing -> f x else f x - get_number :: Sealed2 (PatchInfoAnd p) -> Maybe Int + get_number :: Sealed2 (PatchInfoAnd re p) -> Maybe Int get_number (Sealed2 y) = gn 1 (newset2RL patchset) where iy = info y - gn :: Int -> RL (PatchInfoAnd p) wStart wY -> Maybe Int - gn n (b:<:bs) | seq n (info b) == iy = Just n + gn :: Int -> RL (PatchInfoAnd rt p) wStart wY -> Maybe Int + gn n (bs:<:b) | seq n (info b) == iy = Just n | otherwise = gn (n+1) bs gn _ NilRL = Nothing pis = map fst pis_and_fs description' = unseal2 description --- FIXME: this prose is unreadable. --twb, 2009-08 logHelp'' :: String -logHelp'' = - "Three output formats exist. The default is `--human-readable`. You can\n" ++ - "also select `--context`, which is the internal format (as seen in patch\n" ++ - "bundles) that can be re-read by Darcs (e.g. `darcs clone --context`).\n" ++ - "\n" ++ - "Finally, there is `--xml-output`, which emits valid XML... unless a the\n" ++ - "patch metadata (author, name or description) contains a non-ASCII\n" ++ - "character and was recorded in a non-UTF8 locale.\n" ++ - "\n" ++ - -- FIXME: can't we just disallow the following usage? - "Note that while the `--context` flag may be used in conjunction with\n" ++ - "`--xml-output` or `--human-readable`, in neither case will darcs clone be\n" ++ - "able to read the output. On the other hand, sufficient information\n" ++ - "WILL be output for a knowledgeable human to recreate the current state\n" ++ - "of the repository.\n" +logHelp'' = unlines + [ "Four output formats exist. The default is `--human-readable`. The slightly" + , "different `--machine-readable` format enables to see patch dependencies in" + , "non-interactive mode. You can also select `--context`, which is an internal" + , "format that can be re-read by Darcs (e.g. `darcs clone --context`)." + , "" + , "Finally, there is `--xml-output`, which emits valid XML... unless a the" + , "patch metadata (author, name or description) contains a non-ASCII" + , "character and was recorded in a non-UTF8 locale." + ] logContext :: [DarcsFlag] -> IO () logContext opts = do let repodir = fromMaybe "." $ getRepourl opts withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repository -> do (_ :> ps') <- contextPatches `fmap` readRepo repository - let ps = mapRL (\p -> (seal2 p, [])) ps' - let header = if fancy then empty else text "\nContext:\n" - let logOutput = changelog opts' emptyset (ps, [], Nothing) + let pis = mapRL seal2 ps' + let header = text "\nContext:\n" + let logOutput = maybe (vsep $ map (unseal2 (showPatchInfo.info)) pis) errorDoc Nothing viewDocWith simplePrinters Encode $ header $$ logOutput - where opts' = if fancy then opts else MachineReadable : opts - fancy = HumanReadable `elem` opts || XMLOutput `elem` opts - emptyset = PatchSet NilRL NilRL -- | changes is an alias for log changes :: DarcsCommand [DarcsFlag] @@ -485,7 +477,6 @@ logPatchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveralOrRange flags - , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive False flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = hasSummary O.NoSummary flags diff --git a/src/Darcs/UI/Commands/MarkConflicts.hs b/src/Darcs/UI/Commands/MarkConflicts.hs --- a/src/Darcs/UI/Commands/MarkConflicts.hs +++ b/src/Darcs/UI/Commands/MarkConflicts.hs @@ -19,8 +19,11 @@ module Darcs.UI.Commands.MarkConflicts ( markconflicts ) where -import Prelude hiding ( (^), catch ) +import Prelude () +import Darcs.Prelude +import Prelude hiding ( (^) ) + import System.Exit ( exitSuccess ) import Data.List.Ordered ( nubSort ) import Control.Monad ( when, unless ) @@ -133,7 +136,7 @@ } markconflictsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -markconflictsCmd _ opts [] = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(repository :: Repository p wR wU wR) -> do +markconflictsCmd _ opts [] = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do pend <- unrecordedChanges (diffingOpts opts) repository Nothing r <- readRepo repository Sealed res <- return $ patchsetConflictResolutions r @@ -144,7 +147,7 @@ when (dryRun opts == O.YesDryRun) $ do putDocLn $ text "Conflicts will not be marked: this is a dry run." exitSuccess - let undoUnrec :: FL (PrimOf p) wR wU -> IO (Repository p wR wR wR) + let undoUnrec :: FL (PrimOf p) wR wU -> IO (Repository rt p wR wR wR) undoUnrec NilFL = return repository undoUnrec pend' = do putStrLn ("This will trash any unrecorded changes"++ diff --git a/src/Darcs/UI/Commands/Move.hs b/src/Darcs/UI/Commands/Move.hs --- a/src/Darcs/UI/Commands/Move.hs +++ b/src/Darcs/UI/Commands/Move.hs @@ -20,9 +20,9 @@ module Darcs.UI.Commands.Move ( move, mv ) where -import Prelude hiding ( (^) ) +import Prelude () +import Darcs.Prelude -import Control.Applicative ( (<$>) ) import Control.Monad ( when, unless, forM_, forM ) import Data.Maybe ( fromMaybe ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) @@ -51,14 +51,14 @@ import Darcs.Patch.Witnesses.Sealed ( emptyGap, freeGap, joinGap, FreeLeft ) import Darcs.Util.Global ( debugMessage ) import qualified Darcs.Patch -import Darcs.Patch ( RepoPatch, PrimPatch ) +import Darcs.Patch ( RepoPatch, PrimPatch, PrimOf ) import Darcs.Patch.Apply( ApplyState ) import Data.List ( nub, sort ) import qualified System.FilePath.Windows as WindowsFilePath import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase, treeHasFile ) -import Storage.Hashed.Tree( Tree, modifyTree ) -import Storage.Hashed.Plain( readPlainTree ) +import Darcs.Util.Tree( Tree, modifyTree ) +import Darcs.Util.Tree.Plain( readPlainTree ) import Darcs.Util.Path ( floatPath , fp2fn @@ -137,11 +137,14 @@ | length args < 2 = fail "The `darcs move' command requires at least two arguments." | length args == 2 = do + -- NOTE: The extra case for two arguments is necessary because + -- in this case we allow file -> file moves. Whereas with 3 or + -- more arguments the last one (i.e. the target) must be a directory. xs <- maybeFixSubPaths fps args case xs of [Just from, Just to] - | from == to -> fail "Cannot rename a file or directory onto itself!" - | toFilePath from == "" -> fail "Cannot move the root of the repository" + | from == to -> fail "Cannot rename a file or directory onto itself." + | toFilePath from == "" -> fail "Cannot move the root of the repository." | otherwise -> moveFile opts from to _ -> fail "Both source and destination must be valid." | otherwise = let (froms, to) = (init args, last args) in do @@ -151,10 +154,14 @@ Just to' -> do xs <- nub . sort <$> fixSubPaths fps froms if to' `elem` xs - then fail "Cannot rename a file or directory onto itself!" + then fail "Cannot rename a file or directory onto itself." else case xs of [] -> fail "Nothing to move." - froms' -> moveFilesToDir opts froms' to' + froms' -> + if or (map (null . toFilePath) froms') then + fail "Cannot move the root of the repository." + else + moveFilesToDir opts froms' to' data FileKind = Dir | File deriving (Show, Eq) @@ -227,9 +234,9 @@ moveToDir repo opts cur work (map toFilePath froms) $ toFilePath to withRepoAndState :: [DarcsFlag] - -> (forall p wR wU . - (ApplyState p ~ Tree, RepoPatch p) => - (Repository p wR wU wR, Tree IO, Tree IO, Tree IO) + -> (forall rt p wR wU . + (ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, RepoPatch p) => + (Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO) -> IO ()) -> IO () withRepoAndState opts f = @@ -243,7 +250,8 @@ uc = useCache opts um = umask opts -simpleMove :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT +simpleMove :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => Repository rt p wR wU wT -> [DarcsFlag] -> Tree IO -> Tree IO -> FilePath -> FilePath -> IO () simpleMove repository opts cur work old_fp new_fp = do @@ -251,7 +259,8 @@ unless (Quiet `elem` opts) $ putStrLn $ unwords ["Moved:", old_fp, "to:", new_fp] -moveToDir :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT +moveToDir :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => Repository rt p wR wU wT -> [DarcsFlag] -> Tree IO -> Tree IO -> [FilePath] -> FilePath -> IO () moveToDir repository opts cur work moved finaldir = do @@ -261,7 +270,8 @@ unless (Quiet `elem` opts) $ putStrLn $ unwords $ ["Moved:"] ++ moved ++ ["to:", finaldir] -doMoves :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT +doMoves :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => Repository rt p wR wU wT -> [DarcsFlag] -> Tree IO -> Tree IO -> [(FilePath, FilePath)] -> IO () doMoves repository opts cur work moves = do diff --git a/src/Darcs/UI/Commands/Optimize.hs b/src/Darcs/UI/Commands/Optimize.hs --- a/src/Darcs/UI/Commands/Optimize.hs +++ b/src/Darcs/UI/Commands/Optimize.hs @@ -19,10 +19,11 @@ module Darcs.UI.Commands.Optimize ( optimize, doOptimizeHTTP ) where -import Prelude hiding ( (^) ) -import Control.Applicative ( (<$>) ) +import Prelude () +import Darcs.Prelude + import Control.Exception ( finally ) -import Control.Monad ( when, unless, forM_ ) +import Control.Monad ( when, unless, forM, forM_ ) import Data.Maybe ( isJust, fromJust ) import Data.List ( sort ) import Data.Set ( difference ) @@ -42,7 +43,8 @@ import Darcs.Patch.PatchInfoAnd ( extractHash ) -import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, amInRepository, putInfo +import Darcs.UI.Commands ( DarcsCommand(..), nodefaults + , amInHashedRepository, amInRepository, putInfo , normalCommand, withStdOpts ) import Darcs.Repository.Prefs ( getPreflist, getCaches, globalCacheDir, oldGlobalCacheDir ) import Darcs.Repository @@ -53,21 +55,22 @@ , reorderInventory , cleanRepository , replacePristine + , maybeIdentifyRepository ) +import Darcs.Repository.Internal ( IdentifyRepo(..) ) import Darcs.Repository.HashedRepo ( inventoriesDir, patchesDir, pristineDir, hashedInventory, filterDirContents, readHashedPristineRoot, listInventoriesRepoDir, listPatchesLocalBucketed, set, unset, inv2pris ) import Darcs.Repository.HashedIO ( getHashedFiles ) import Darcs.Repository.Old ( oldRepoFailMsg ) -import Darcs.Repository.InternalTypes ( Repository(..) ) -import Darcs.Repository.Util ( getRecursiveDarcsRepos ) +import Darcs.Repository.InternalTypes ( Repository(..), Pristine(..) ) import Darcs.Patch.Witnesses.Ordered ( mapFL , bunchFL , lengthRL ) -import Darcs.Patch ( RepoPatch ) +import Darcs.Patch ( IsRepoType, RepoPatch ) import Darcs.Patch.Set ( newset2RL , newset2FL @@ -76,7 +79,7 @@ import Darcs.Patch.Apply( ApplyState ) import Darcs.Util.ByteString ( gzReadFilePS ) import Darcs.Util.Printer ( text ) -import Darcs.Repository.Lock +import Darcs.Util.Lock ( maybeRelink , gzWriteAtomicFilePS , writeAtomicFilePS @@ -110,7 +113,7 @@ import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking (..), DryRun ( NoDryRun ), UseCache (..), UMask (..) - , WithWorkingDir(WithWorkingDir) ) + , WithWorkingDir(WithWorkingDir), PatchFormat(PatchFormat1) ) import Darcs.Patch.Progress ( progressFL ) import Darcs.Repository.Cache ( hashedDir, bucketFolder, HashedDir(HashedPristineDir) ) @@ -125,7 +128,7 @@ import qualified Darcs.Repository.HashedRepo as HashedRepo import Darcs.Repository.State ( readRecorded ) -import Storage.Hashed.Tree +import Darcs.Util.Tree ( Tree , TreeItem(..) , list @@ -133,8 +136,8 @@ , emptyTree ) import Darcs.Util.Path( anchorPath, toFilePath, AbsolutePath ) -import Storage.Hashed.Plain( readPlainTree ) -import Storage.Hashed.Darcs +import Darcs.Util.Tree.Plain( readPlainTree ) +import Darcs.Util.Tree.Hashed ( writeDarcsHashed , decodeDarcsSize ) @@ -197,7 +200,7 @@ { commandProgramName = "darcs" , commandExtraArgs = 0 , commandExtraArgHelp = [] - , commandPrereq = amInRepository + , commandPrereq = amInHashedRepository , commandArgdefaults = nodefaults , commandName = undefined , commandHelp = undefined @@ -221,7 +224,7 @@ } optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -optimizeCleanCmd _ opts _ = do +optimizeCleanCmd _ opts _ = withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories putInfo opts "Done cleaning repository!" @@ -231,6 +234,7 @@ { commandName = "upgrade" , commandHelp = "Convert old-fashioned repositories to the current default hashed format." , commandDescription = "upgrade repository to latest compatible format" + , commandPrereq = amInRepository , commandCommand = optimizeUpgradeCmd } @@ -243,7 +247,7 @@ } optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -optimizeHttpCmd _ opts _ = do +optimizeHttpCmd _ opts _ = withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories doOptimizeHTTP repository @@ -259,7 +263,7 @@ } optimizePristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -optimizePristineCmd _ opts _ = do +optimizePristineCmd _ opts _ = withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories doOptimizePristine opts repository @@ -282,14 +286,14 @@ } optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -optimizeCompressCmd _ opts _ = do +optimizeCompressCmd _ opts _ = withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories optimizeCompression [Compress] putInfo opts "Done optimizing by compression!" optimizeUncompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -optimizeUncompressCmd _ opts _ = do +optimizeUncompressCmd _ opts _ = withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories optimizeCompression [] @@ -331,13 +335,13 @@ } optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -optimizeEnablePatchIndexCmd _ opts _ = do +optimizeEnablePatchIndexCmd _ opts _ = withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do createOrUpdatePatchIndexDisk repository putInfo opts "Done enabling patch index!" optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -optimizeDisablePatchIndexCmd _ opts _ = do +optimizeDisablePatchIndexCmd _ opts _ = withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(Repo repodir _ _ _) -> do deletePatchIndex repodir putInfo opts "Done disabling patch index!" @@ -354,7 +358,7 @@ } optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -optimizeReorderCmd _ opts _ = do +optimizeReorderCmd _ opts _ = withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do reorderInventory repository (compression opts) YesUpdateWorking (verbosity opts) putInfo opts "Done reordering!" @@ -393,7 +397,7 @@ } optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -optimizeRelinkCmd _ opts _ = do +optimizeRelinkCmd _ opts _ = withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories doRelink opts @@ -430,10 +434,8 @@ "repository, or if you pulled the same patch from a remote repository\n" ++ "into multiple local repositories." -doOptimizePristine :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Repository p wR wU wT -> IO () +doOptimizePristine :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Repository rt p wR wU wT -> IO () doOptimizePristine opts repo = do - hashed <- doesFileExist $ darcsdir "hashed_inventory" - when hashed $ do inv <- BS.readFile (darcsdir "hashed_inventory") let linesInv = BS.split '\n' inv case linesInv of @@ -468,6 +470,7 @@ unless done $ maybeRelinkFile t f +-- Only 'optimize' commands that works on old-fashionned repositories optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () optimizeUpgradeCmd _ opts _ = do debugMessage "Upgrading to hashed..." @@ -479,7 +482,9 @@ withRepoLock NoDryRun YesUseCache YesUpdateWorking NoUMask $ RepoJob $ \repository -> actuallyUpgradeFormat repository -actuallyUpgradeFormat :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () +actuallyUpgradeFormat + :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> IO () actuallyUpgradeFormat repository = do -- convert patches/inventory patches <- readRepo repository @@ -500,7 +505,7 @@ sequence_ $ mapFL HashedRepo.applyToTentativePristine $ bunchFL 100 patchesToApply -- now make it official HashedRepo.finalizeTentativeChanges repository compr - writeRepoFormat (createRepoFormat True WithWorkingDir) (darcsdir "format") + writeRepoFormat (createRepoFormat PatchFormat1 WithWorkingDir) (darcsdir "format") -- clean out old-fashioned junk debugMessage "Cleaning out old-fashioned repository files..." removeFile $ darcsdir "inventory" @@ -517,7 +522,9 @@ gzs <- filter ((== ".gz") . takeExtension) `fmap` getDirectoryContents "." mapM_ removeFile gzs -doOptimizeHTTP :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO () +doOptimizeHTTP + :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> IO () doOptimizeHTTP repo = flip finally (mapM_ removeFileIfExists [ darcsdir "meta-filelist-inventories" , darcsdir "meta-filelist-pristine" @@ -525,6 +532,7 @@ , patchesTar <.> "part" ]) $ do rf <- identifyRepoFormat "." + -- function is exposed in API so could be called on non-hashed repo unless (formatHas HashedInventory rf) $ fail oldRepoFailMsg createDirectoryIfMissing False packsDir -- pristine hash @@ -535,6 +543,9 @@ is <- map ((darcsdir "inventories") ) <$> HashedRepo.listInventories writeFile (darcsdir "meta-filelist-inventories") . unlines $ map takeFileName is + -- tinkering with zlib's compression parameters does not make + -- any noticeable difference in generated archive size. + -- switching to bzip2 does OTOH (~25% size gain). BL.writeFile (patchesTar <.> "part") . compress . write =<< mapM fileEntry' ((darcsdir "meta-filelist-inventories") : ps ++ reverse is) @@ -557,7 +568,7 @@ tp <- either fail return $ toTarPath False x return $ fileEntry tp content dirContents d = map ((darcsdir d) ) <$> - (filterDirContents d $ const True) + filterDirContents d (const True) hashedPatchFileName x = case extractHash x of Left _ -> fail "unexpected unhashed patch" Right h -> darcsdir "patches" h @@ -672,7 +683,7 @@ createDirectoryIfMissing True gCachePristineDir remove listInventoriesRepoDir gCacheInvDir repoPaths - remove ((listPatchesLocalBucketed gCache) . ( darcsdir)) gCachePatchesDir repoPaths + remove (listPatchesLocalBucketed gCache . ( darcsdir)) gCachePatchesDir repoPaths remove getPristine gCachePristineDir repoPaths where @@ -682,13 +693,36 @@ remove' cacheSubDir s2 (concat s1) remove' :: String -> [String] -> [String] -> IO () - remove' dir s1 s2 = do + remove' dir s1 s2 = mapM_ (removeFileMayNotExist . (\hashedFile -> dir bucketFolder hashedFile hashedFile)) - (unset $ (set s1) `difference` (set s2)) + (unset $ set s1 `difference` set s2) getPristine :: String -> IO [String] getPristine darcsDir = do i <- gzReadFilePS (darcsDir darcsdir hashedInventory) - priss <- getHashedFiles (darcsDir darcsdir pristineDir) [inv2pris i] - return priss + getHashedFiles (darcsDir darcsdir pristineDir) [inv2pris i] + +-- |getRecursiveDarcsRepos returns all paths to repositories under topdir. +getRecursiveDarcsRepos :: FilePath -> IO [FilePath] +getRecursiveDarcsRepos topdir = do + isDir <- doesDirectoryExist topdir + if isDir + then do + status <- maybeIdentifyRepository NoUseCache topdir + case status of + GoodRepository (Repo _ _ pris _) -> + case pris of + HashedPristine -> return [topdir] + _ -> return [] -- old fashioned or broken repo + _ -> getRecursiveDarcsRepos' topdir + else return [] + + where + getRecursiveDarcsRepos' d = do + names <- getDirectoryContents d + let properNames = filter (\x -> head x /= '.') names + paths <- forM properNames $ \name -> do + let path = d name + getRecursiveDarcsRepos path + return (concat paths) diff --git a/src/Darcs/UI/Commands/Pull.hs b/src/Darcs/UI/Commands/Pull.hs --- a/src/Darcs/UI/Commands/Pull.hs +++ b/src/Darcs/UI/Commands/Pull.hs @@ -24,6 +24,9 @@ fetchPatches, revertable ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^) ) import System.Exit ( exitSuccess ) @@ -35,7 +38,6 @@ ( DarcsCommand(..), withStdOpts , putInfo , setEnvDarcsPatches - , formatPath , defaultRepo , amInHashedRepository ) @@ -57,7 +59,8 @@ , doReverse, verbosity, dryRun, umask, useCache, selectDeps , remoteRepos, reorder, setDefault , isUnified, hasSummary - , diffAlgorithm, isInteractive ) + , isInteractive + ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise , defaultFlags, parseFlags @@ -81,7 +84,7 @@ import qualified Darcs.Repository.Cache as DarcsCache import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefully, patchDesc ) -import Darcs.Patch ( RepoPatch, description ) +import Darcs.Patch ( IsRepoType, RepoPatch, description, PrimOf ) import Darcs.Patch.Bundle( makeBundleN, patchFilename ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Set ( Origin, PatchSet(..), SealedPatchSet ) @@ -97,18 +100,18 @@ newsetIntersection, newsetUnion ) import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..) ) import Darcs.UI.SelectChanges - ( selectChanges - , WhichChanges(..) + ( WhichChanges(..) , runSelection , selectionContext ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Util.Exception ( clarifyErrors ) import Darcs.Util.Printer ( putDocLn, vcat, ($$), text, putDoc ) -import Darcs.Repository.Lock ( writeDocBinFile ) +import Darcs.Util.Lock ( writeDocBinFile ) import Darcs.Util.Path ( useAbsoluteOrStd, stdOut, AbsolutePath ) import Darcs.Util.Workaround ( getCurrentDirectory ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Text ( quote ) +import Darcs.Util.Tree( Tree ) #include "impossible.h" @@ -124,11 +127,9 @@ pullHelp = unlines [ "Pull is used to bring patches made in another repository into the current" , "repository (that is, either the one in the current directory, or the one" - , "specified with the `--repodir` option). Pull allows you to bring over all or" - , "some of the patches that are in that repository but not in this one. Pull" - , "accepts arguments, which are URLs from which to pull, and when called" - , "without an argument, pull will use the repository from which you have most" - , "recently either pushed or pulled." + , "specified with the `--repodir` option). Pull accepts arguments, which are" + , "URLs from which to pull, and when called without an argument, pull will" + , "use the repository specified at `_darcs/prefs/defaultrepo`." , "" , "The default (`--union`) behavior is to pull any patches that are in any of" , "the specified repositories. If you specify the `--intersection` flag, darcs" @@ -370,11 +371,11 @@ withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ fetchPatches o opts repos "fetch" >=> makeBundle opts -fetchPatches :: forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) +fetchPatches :: forall rt p wR wU . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => AbsolutePath -> [DarcsFlag] -> [String] -> String - -> Repository p wR wU wR - -> IO (SealedPatchSet p Origin, - Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wR)) + -> Repository rt p wR wU wR + -> IO (SealedPatchSet rt p Origin, + Sealed ((FL (PatchInfoAnd rt p) :\/: FL (PatchInfoAnd rt p)) wR)) fetchPatches o opts unfixedrepodirs@(_:_) jobname repository = do here <- getCurrentDirectory repodirs <- (nub . filter (/= here)) `fmap` mapM (fixUrl o) unfixedrepodirs @@ -384,7 +385,7 @@ old_default <- getPreflist "defaultrepo" when (old_default == repodirs && XMLOutput `notElem` opts) $ let pulling = if DryRun `elem` opts then "Would pull" else "Pulling" - in putInfo opts $ text $ pulling++" from "++concatMap formatPath repodirs++"..." + in putInfo opts $ text $ pulling++" from "++concatMap quote repodirs++"..." (Sealed them, Sealed compl) <- readRepos repository opts repodirs addRepoSource (head repodirs) (dryRun opts) (remoteRepos opts) (setDefault False opts) mapM_ (addToPreflist "repos") repodirs @@ -415,16 +416,16 @@ when (reorder opts /= O.Reorder) exitSuccess let direction = if doReverse opts then FirstReversed else First context = selectionContext direction jobname (pullPatchSelOpts opts) Nothing Nothing - (to_be_pulled :> _) <- runSelection (selectChanges psFiltered) context + (to_be_pulled :> _) <- runSelection psFiltered context return (seal common, seal $ us' :\/: to_be_pulled) fetchPatches _ _ [] jobname _ = fail $ "No default repository to " ++ jobname ++ " from, please specify one" -makeBundle :: forall p wR . (RepoPatch p, ApplyState p ~ Tree) +makeBundle :: forall rt p wR . (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] - -> (SealedPatchSet p Origin, - Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wR)) + -> (SealedPatchSet rt p Origin, + Sealed ((FL (PatchInfoAnd rt p) :\/: FL (PatchInfoAnd rt p)) wR)) -> IO () makeBundle opts (Sealed common, Sealed (_ :\/: to_be_fetched)) = do @@ -463,9 +464,9 @@ the second patchset(s) to be complemented against Rc. -} -readRepos :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> [DarcsFlag] -> [String] - -> IO (SealedPatchSet p Origin,SealedPatchSet p Origin) +readRepos :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> [DarcsFlag] -> [String] + -> IO (SealedPatchSet rt p Origin,SealedPatchSet rt p Origin) readRepos _ _ [] = impossible readRepos to_repo opts us = do rs <- mapM (\u -> do r <- identifyRepositoryFor to_repo (useCache opts) u @@ -481,7 +482,6 @@ pullPatchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveral flags - , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags diff --git a/src/Darcs/UI/Commands/Push.hs b/src/Darcs/UI/Commands/Push.hs --- a/src/Darcs/UI/Commands/Push.hs +++ b/src/Darcs/UI/Commands/Push.hs @@ -19,12 +19,14 @@ module Darcs.UI.Commands.Push ( push ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^) ) import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ), exitSuccess ) import Control.Monad ( when, unless ) -import Data.Char ( toUpper ) -import Data.Maybe ( isJust, isNothing ) +import Data.Maybe ( isJust ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , putVerbose @@ -32,35 +34,36 @@ , abortRun , printDryRunMessageAndExit , setEnvDarcsPatches - , formatPath , defaultRepo , amInHashedRepository ) import Darcs.UI.Flags ( DarcsFlag - , isInteractive, verbosity, isUnified, hasSummary, diffAlgorithm - , hasXmlOutput, selectDeps, applyAs + , isInteractive, verbosity, isUnified, hasSummary + , hasXmlOutput, selectDeps, applyAs, remoteDarcs , doReverse, dryRun, useCache, remoteRepos, setDefault, fixUrl ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise , defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( DryRun (..) ) +import qualified Darcs.Repository.Flags as R ( remoteDarcs ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully ) import Darcs.Repository ( Repository, withRepository, RepoJob(..), identifyRepositoryFor, readRepo, checkUnrelatedRepos ) -import Darcs.Patch ( RepoPatch, description ) +import Darcs.Patch ( IsRepoType, RepoPatch, description ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Witnesses.Ordered ( (:>)(..), RL, FL, nullRL, nullFL, reverseFL, mapFL_FL, mapRL ) import Darcs.Repository.Prefs ( addRepoSource, getPreflist ) -import Darcs.UI.External ( maybeURLCmd, signString ) -import Darcs.Util.URL ( isHttpUrl, isValidLocalPath ) +import Darcs.UI.External ( signString, darcsProgram + , pipeDoc, pipeDocSSH ) +import Darcs.Util.URL ( isHttpUrl, isValidLocalPath + , isSshUrl, splitSshUrl, SshFilePath(..) ) import Darcs.Util.Path ( AbsolutePath ) import Darcs.UI.SelectChanges - ( selectChanges - , WhichChanges(..) + ( WhichChanges(..) , selectionContext , runSelection ) @@ -69,12 +72,12 @@ import Darcs.Patch.Bundle ( makeBundleN ) import Darcs.Patch.Patchy( ShowPatch ) import Darcs.Patch.Set ( PatchSet, Origin ) -import Darcs.Util.Printer ( Doc, vcat, empty, text, ($$) ) -import Darcs.UI.RemoteApply ( remoteApply ) +import Darcs.Util.Printer ( Doc, vcat, empty, text, ($$), RenderMode(..) ) import Darcs.UI.Email ( makeEmail ) import Darcs.Util.English (englishNum, Noun(..)) import Darcs.Util.Workaround ( getCurrentDirectory ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Text ( quote ) +import Darcs.Util.Tree( Tree ) #include "impossible.h" @@ -87,19 +90,17 @@ [ "Push is the opposite of pull. Push allows you to copy patches from the" , "current repository into another repository." , "" - , "If you give the `--apply-as` flag, darcs will use sudo to apply the" + , "If you give the `--apply-as` flag, darcs will use `sudo` to apply the" , "patches as a different user. This can be useful if you want to set up a" , "system where several users can modify the same repository, but you don't" , "want to allow them full write access. This isn't secure against skilled" , "malicious attackers, but at least can protect your repository from clumsy," , "inept or lazy users." , "" - , "Darcs push will by default compress the patch data before sending it to a" - , "remote location via ssh. This works as long as the remote darcs is not" - , "older than version 2.5. If you get errors that indicate a corrupt patch" - , "bundle, you should try again with the `--no-compress` option to send the" - , "data in un-compressed form (which is a lot slower for large patches, but" - , "should always work)." + , "`darcs push` will compress the patch data before sending it to a remote" + , "location via ssh. This works as long as the remote darcs is not older" + , "than version 2.5. If you get errors that indicate a corrupt patch bundle," + , "you should try again with the `--no-compress` option." ] pushBasicOpts :: DarcsOption a @@ -205,13 +206,13 @@ ExitSuccess -> putInfo opts $ text "Push successful." pushCmd _ _ _ = impossible -prepareBundle :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) - => [DarcsFlag] -> String -> Repository p wR wU wT -> IO Doc +prepareBundle :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => [DarcsFlag] -> String -> Repository rt p wR wU wT -> IO Doc prepareBundle opts repodir repository = do old_default <- getPreflist "defaultrepo" when (old_default == [repodir]) $ let pushing = if dryRun opts == YesDryRun then "Would push" else "Pushing" - in putInfo opts $ text $ pushing++" to "++formatPath repodir++"..." + in putInfo opts $ text $ pushing++" to "++quote repodir++"..." them <- identifyRepositoryFor repository (useCache opts) repodir >>= readRepo addRepoSource repodir (dryRun opts) (remoteRepos opts) (setDefault False opts) us <- readRepo repository @@ -219,12 +220,12 @@ prePushChatter opts us (reverseFL us') them let direction = if doReverse opts then FirstReversed else First context = selectionContext direction "push" (pushPatchSelOpts opts) Nothing Nothing - runSelection (selectChanges us') context + runSelection us' context >>= bundlePatches opts common -prePushChatter :: forall p a wX wY wT . (RepoPatch p, ShowPatch a) => - [DarcsFlag] -> PatchSet p Origin wX -> - RL a wT wX -> PatchSet p Origin wY -> IO () +prePushChatter :: forall rt p a wX wY wT . (RepoPatch p, ShowPatch a) => + [DarcsFlag] -> PatchSet rt p Origin wX -> + RL a wT wX -> PatchSet rt p Origin wY -> IO () prePushChatter opts us us' them = do checkUnrelatedRepos (parseFlags O.allowUnrelatedRepos opts) us them let num_to_pull = snd $ countUsThem us them @@ -237,9 +238,9 @@ when (nullRL us') $ do putInfo opts $ text "No recorded local patches to push!" exitSuccess -bundlePatches :: forall t p wZ wW wA. (RepoPatch p, ApplyState p ~ Tree) - => [DarcsFlag] -> PatchSet p wA wZ - -> (FL (PatchInfoAnd p) :> t) wZ wW +bundlePatches :: forall t rt p wZ wW wA. (RepoPatch p, ApplyState p ~ Tree) + => [DarcsFlag] -> PatchSet rt p wA wZ + -> (FL (PatchInfoAnd rt p) :> t) wZ wW -> IO Doc bundlePatches opts common (to_be_pushed :> _) = do @@ -262,14 +263,9 @@ if isHttpUrl repodir then do when (isJust $ applyAs opts) $ abortRun opts $ text "Cannot --apply-as when pushing to URLs" - maybeapply <- maybeURLCmd "APPLY" repodir - when (isNothing maybeapply) $ - let lprot = takeWhile (/= ':') repodir - prot = map toUpper lprot - msg = text ("Pushing to "++lprot++" URLs is not supported.\n"++ - "You may be able to hack this to work"++ - " using DARCS_APPLY_"++prot) in - abortRun opts msg + let lprot = takeWhile (/= ':') repodir + msg = text ("Pushing to "++lprot++" URLs is not supported.") + abortRun opts msg else when (parseFlags O.sign opts /= O.NoSign) $ abortRun opts $ text "Signing doesn't make sense for local repositories or when pushing over ssh." @@ -278,9 +274,43 @@ pushPatchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveral flags - , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags , S.withContext = isUnified flags } + +remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode +remoteApply opts repodir bundle + = case applyAs opts of + Nothing + | isSshUrl repodir -> applyViaSsh opts (splitSshUrl repodir) bundle + | otherwise -> applyViaLocal opts repodir bundle + Just un + | isSshUrl repodir -> applyViaSshAndSudo opts (splitSshUrl repodir) un bundle + | otherwise -> applyViaSudo un repodir bundle + +applyViaSudo :: String -> String -> Doc -> IO ExitCode +applyViaSudo user repo bundle = + darcsProgram >>= \darcs -> + pipeDoc Standard "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle + +applyViaLocal :: [DarcsFlag] -> String -> Doc -> IO ExitCode +applyViaLocal opts repo bundle = + darcsProgram >>= \darcs -> + pipeDoc Standard darcs ("apply":"--all":"--repodir":repo:applyopts opts) bundle + +applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode +applyViaSsh opts repo = + pipeDocSSH (parseFlags O.compress opts) Standard repo + [R.remoteDarcs (remoteDarcs opts) ++" apply --all "++unwords (applyopts opts)++ + " --repodir '"++sshRepo repo++"'"] + +applyViaSshAndSudo :: [DarcsFlag] -> SshFilePath -> String -> Doc -> IO ExitCode +applyViaSshAndSudo opts repo username = + pipeDocSSH (parseFlags O.compress opts) Standard repo + ["sudo -u "++username++" "++R.remoteDarcs (remoteDarcs opts)++ + " apply --all --repodir '"++sshRepo repo++"'"] + +applyopts :: [DarcsFlag] -> [String] +applyopts opts = if parseFlags O.debug opts then ["--debug"] else [] diff --git a/src/Darcs/UI/Commands/Rebase.hs b/src/Darcs/UI/Commands/Rebase.hs --- a/src/Darcs/UI/Commands/Rebase.hs +++ b/src/Darcs/UI/Commands/Rebase.hs @@ -6,7 +6,8 @@ module Darcs.UI.Commands.Rebase ( rebase ) where -import Prelude hiding ( (^), catch, log ) +import Prelude () +import Darcs.Prelude import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts @@ -18,7 +19,6 @@ , printDryRunMessageAndExit , amInHashedRepository ) -import Darcs.UI.Commands.Amend ( updatePatchHeader ) import Darcs.UI.Commands.Apply ( applyCmd ) import Darcs.UI.Commands.Log ( changelog, getLogInfo ) import Darcs.UI.Commands.Pull ( pullCmd, revertable ) @@ -46,8 +46,12 @@ , defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O +import Darcs.UI.PatchHeader ( HijackT, HijackOptions(..), runHijackT + , getAuthor + , updatePatchHeader, AskAboutDeps(..) ) import Darcs.Repository ( Repository, RepoJob(..), withRepoLock, withRepository + , RebaseJobFlags(..) , tentativelyAddPatch, finalizeRepositoryChanges , invalidateIndex , tentativelyRemovePatches, readRepo @@ -67,20 +71,14 @@ import Darcs.Patch.CommuteFn ( commuterIdFL ) import Darcs.Patch.Info ( showPatchInfo ) import Darcs.Patch.Match ( firstMatch, secondMatch, splitSecondFL ) -import Darcs.Patch.Named - ( patchcontents - , Named, fmapNamed, fmapFL_Named - , patch2patchinfo - ) +import Darcs.Patch.Named ( Named, fmapFL_Named, patchcontents, patch2patchinfo ) +import Darcs.Patch.Named.Wrapped ( mkRebase, toRebasing, fromRebasing ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, n2pia, hopefully ) import Darcs.Patch.Prim ( PrimOf, canonizeFL, fromPrim ) -import Darcs.Patch.Rebase - ( Rebasing(..), RebaseItem(..) - , mkSuspended - , simplifyPush, simplifyPushes - , takeHeadRebase, takeHeadRebaseFL - ) +import Darcs.Patch.Rebase ( takeHeadRebase, takeHeadRebaseFL ) +import Darcs.Patch.Rebase.Container ( Suspended(..) ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), flToNamesPrims ) +import Darcs.Patch.Rebase.Item ( RebaseItem(..), simplifyPush, simplifyPushes ) import Darcs.Patch.Rebase.Name ( RebaseName(..), commuteNameNamed ) import Darcs.Patch.Rebase.Viewing ( RebaseSelect(RSFwd), rsToPia @@ -91,12 +89,13 @@ ) import Darcs.Patch.Permutations ( partitionConflictingFL ) import Darcs.Patch.Progress ( progressFL ) +import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) import Darcs.Patch.Set ( PatchSet(..), appendPSFL ) import Darcs.Patch.Show ( showNicely ) import Darcs.Patch.Split ( primSplitter ) import Darcs.UI.ApplyPatches ( PatchApplier(..), PatchProxy(..) ) import Darcs.UI.SelectChanges - ( selectChanges, runSelection + ( runSelection , selectionContext, selectionContextGeneric, selectionContextPrim , WhichChanges(First, Last, LastReversed) , viewChanges @@ -125,11 +124,11 @@ import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Path ( AbsolutePath ) -import Storage.Hashed.Tree ( Tree ) +import Darcs.Util.Tree ( Tree ) -import Control.Applicative ( (<$>) ) import Control.Exception ( catch, IOException ) import Control.Monad ( when ) +import Control.Monad.Trans ( liftIO ) import System.Exit ( exitSuccess ) #include "impossible.h" @@ -223,9 +222,10 @@ suspendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () suspendCmd _ opts _args = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ - StartRebaseJob (compression opts) (verbosity opts) YesUpdateWorking $ \repository -> do + StartRebaseJob (RebaseJobFlags (compression opts) (verbosity opts) YesUpdateWorking) $ + \repository -> do allpatches <- readRepo repository - (rOld, Sealed qs, allpatches_tail) <- return $ takeHeadRebase allpatches + (rOld, suspended, allpatches_tail) <- return $ takeHeadRebase allpatches (_ :> patches) <- return $ if firstMatch (parseFlags O.matchSeveralOrLast opts) then getLastPatches (parseFlags O.matchSeveralOrLast opts) allpatches_tail @@ -234,25 +234,29 @@ patches_context = selectionContext direction "suspend" (patchSelOpts True opts) Nothing Nothing (_ :> psToSuspend) <- runSelection - (selectChanges patches) + patches patches_context when (nullFL psToSuspend) $ do putStrLn "No patches selected!" exitSuccess - repository' <- doSuspend opts repository qs rOld psToSuspend + -- test all patches for hijacking and abort if rejected + runHijackT RequestHijackPermission + $ mapM_ (getAuthor "suspend" False Nothing) + $ mapFL info psToSuspend + repository' <- doSuspend opts repository suspended rOld psToSuspend finalizeRepositoryChanges repository' YesUpdateWorking (compression opts) return () doSuspend - :: forall p wR wU wT wX wY + :: forall p wR wU wT wX . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => [DarcsFlag] - -> Repository (Rebasing p) wR wU wT - -> FL (RebaseItem p) wT wY - -> PatchInfoAnd (Rebasing p) wT wT - -> FL (PatchInfoAnd (Rebasing p)) wX wT - -> IO (Repository (Rebasing p) wR wU wX) -doSuspend opts repository qs rOld psToSuspend = do + -> Repository ('RepoType 'IsRebase) p wR wU wT + -> Suspended p wT wT + -> PatchInfoAnd ('RepoType 'IsRebase) p wT wT + -> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wT + -> IO (Repository ('RepoType 'IsRebase) p wR wU wX) +doSuspend opts repository (Items qs) rOld psToSuspend = do pend <- unrecordedChanges (diffingOpts opts) repository Nothing FlippedSeal psAfterPending <- let effectPsToSuspend = effect psToSuspend in @@ -273,7 +277,7 @@ fail $ "Can't suspend selected patches without reverting some unrecorded change. Use --verbose to see the details." - rNew <- mkSuspended (mapFL_FL (ToEdit . fmapNamed unNormal . hopefully) psToSuspend +>+ qs) + rNew <- mkRebase (Items (mapFL_FL (ToEdit . fromRebasing . hopefully) psToSuspend +>+ qs)) invalidateIndex repository repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (psToSuspend +>+ (rOld :>: NilFL)) tentativelyAddToPending repository' YesUpdateWorking $ invert $ effect psToSuspend @@ -281,9 +285,6 @@ _ <- applyToWorking repository'' (verbosity opts) (invert psAfterPending) `catch` \(e :: IOException) -> fail ("Couldn't undo patch in working dir.\n" ++ show e) return repository'' - where unNormal :: Rebasing p wA wB -> p wA wB - unNormal (Normal q) = q - unNormal (Suspended _) = error "Can't suspend a rebase patch" unsuspendBasicOpts :: DarcsOption a (Maybe O.AllowConflicts @@ -400,15 +401,15 @@ unsuspendCmd :: Bool -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () unsuspendCmd reifyFixups _ opts _args = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ - RebaseJob (compression opts) (verbosity opts) YesUpdateWorking $ - \(repository :: Repository (Rebasing p) wR wU wR) -> (do + RebaseJob (RebaseJobFlags (compression opts) (verbosity opts) YesUpdateWorking) $ + \(repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> (do patches <- readRepo repository pend <- unrecordedChanges (diffingOpts opts) repository Nothing let checkChanges :: FL (PrimOf p) wA wB -> IO (EqCheck wA wB) checkChanges NilFL = return IsEq checkChanges _ = error "can't unsuspend when there are unrecorded changes" IsEq <- checkChanges pend :: IO (EqCheck wR wU) - (rOld, Sealed ps, _) <- return $ takeHeadRebase patches + (rOld, Items ps, _) <- return $ takeHeadRebase patches let selects = toRebaseSelect ps @@ -432,7 +433,7 @@ warnSkip dontoffer let patches_context = selectionContextGeneric rsToPia First "unsuspend" (patchSelOpts True opts) Nothing - (chosen :> keep) <- runSelection (selectChanges offer) patches_context + (chosen :> keep) <- runSelection offer patches_context when (nullFL chosen) $ do putStrLn "No patches selected!" exitSuccess @@ -467,8 +468,9 @@ repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (rOld :>: NilFL) -- TODO should catch logfiles (fst value from updatePatchHeader) and clean them up as in AmendRecord tentativelyAddToPending repository' YesUpdateWorking effect_to_apply - (repository'', renames) <- doAdd repository' ps_to_unsuspend - rNew <- unseal mkSuspended . unseal (simplifyPushes da (mapFL_FL NameFixup renames)) $ ps_to_keep + -- we can just let hijack attempts through here because we already asked about them on suspend time + (repository'', renames) <- runHijackT IgnoreHijack $ doAdd repository' ps_to_unsuspend + rNew <- unseal (mkRebase . Items) . unseal (simplifyPushes da (mapFL_FL NameFixup renames)) $ ps_to_keep repository''' <- tentativelyAddPatch repository'' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew) finalizeRepositoryChanges repository''' YesUpdateWorking (compression opts) _ <- applyToWorking repository''' (verbosity opts) effect_to_apply `catch` \(e :: IOException) -> @@ -476,14 +478,14 @@ return () ) :: IO () where doAdd :: (RepoPatch p, ApplyState p ~ Tree) - => Repository (Rebasing p) wR wU wT + => Repository ('RepoType 'IsRebase) p wR wU wT -> FL (WDDNamed p) wT wT2 - -> IO (Repository (Rebasing p) wR wU wT2, FL (RebaseName p) wT2 wT2) + -> HijackT IO (Repository ('RepoType 'IsRebase) p wR wU wT2, FL (RebaseName p) wT2 wT2) doAdd repo NilFL = return (repo, NilFL) doAdd repo ((p :: WDDNamed p wT wU) :>:ps) = do case wddDependedOn p of [] -> return () - deps -> do + deps -> liftIO $ do -- It might make sense to only print out this message once, but we might find -- that the dropped dependencies are interspersed with other output, -- e.g. if running with --ask-deps @@ -499,16 +501,17 @@ putStr "\n" -- TODO should catch logfiles (fst value from updatePatchHeader) and clean them up as in AmendRecord - p' <- snd <$> updatePatchHeader - False -- askDeps + p' <- snd <$> updatePatchHeader "unsuspend" + NoAskAboutDeps (patchSelOpts True opts) + (diffAlgorithm opts) (parseFlags O.keepDate opts) (parseFlags O.selectAuthor opts) (parseFlags O.author opts) (parseFlags O.patchname opts) (parseFlags O.askLongComment opts) - repo (n2pia (fmapNamed Normal (wddPatch p))) NilFL - repo' <- tentativelyAddPatch repo (compression opts) (verbosity opts) YesUpdateWorking p' + (n2pia (toRebasing (wddPatch p))) NilFL + repo' <- liftIO $ tentativelyAddPatch repo (compression opts) (verbosity opts) YesUpdateWorking p' -- create a rename that undoes the change we just made, so the contexts match up let rename :: RebaseName p wU wU rename = Rename (info p') (patch2patchinfo (wddPatch p)) @@ -563,18 +566,18 @@ injectCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () injectCmd _ opts _args = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ - RebaseJob (compression opts) (verbosity opts) YesUpdateWorking $ - \(repository :: Repository (Rebasing p) wR wU wR) -> do + RebaseJob (RebaseJobFlags (compression opts) (verbosity opts) YesUpdateWorking) $ + \(repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> do patches <- readRepo repository - (rOld, Sealed ps, _) <- return $ takeHeadRebase patches + (rOld, Items ps, _) <- return $ takeHeadRebase patches let selects = toRebaseSelect ps -- TODO this selection doesn't need to respect dependencies -- TODO we only want to select one patch: generalise withSelectedPatchFromRepo let patches_context = selectionContextGeneric rsToPia First "inject into" (patchSelOpts True opts) Nothing - (chosens :> rest_selects) <- runSelection (selectChanges selects) patches_context + (chosens :> rest_selects) <- runSelection selects patches_context let extractSingle :: FL (RebaseSelect p) wX wY -> (FL (RebaseFixup p) :> Named p) wX wY extractSingle (RSFwd fixups toedit :>: NilFL) = fixups :> toedit @@ -585,8 +588,8 @@ name_fixups :> prim_fixups <- return $ flToNamesPrims fixups - let changes_context = selectionContextPrim Last "inject" (patchSelOpts True opts) (Just primSplitter) Nothing Nothing - (rest_fixups :> injects) <- runSelection (selectChanges prim_fixups) changes_context + let changes_context = selectionContextPrim Last "inject" (patchSelOpts True opts) (Just (primSplitter (diffAlgorithm opts))) Nothing Nothing + (rest_fixups :> injects) <- runSelection prim_fixups changes_context when (nullFL injects) $ do putStrLn "No changes selected!" @@ -595,7 +598,8 @@ -- Don't bother to update patch header since unsuspend will do that later let da = diffAlgorithm opts toeditNew = fmapFL_Named (mapFL_FL fromPrim . canonizeFL da . (injects +>+) . effect) toedit - rNew <- unseal mkSuspended $ unseal (simplifyPushes da (mapFL_FL NameFixup name_fixups)) + rNew <- unseal (mkRebase . Items) + $ unseal (simplifyPushes da (mapFL_FL NameFixup name_fixups)) $ simplifyPushes da (mapFL_FL PrimFixup rest_fixups) $ ToEdit toeditNew :>: fromRebaseSelect rest_selects @@ -644,17 +648,17 @@ obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () obliterateCmd _ opts _args = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ - RebaseJob (compression opts) (verbosity opts) YesUpdateWorking $ - \(repository :: Repository (Rebasing p) wR wU wR) -> (do + RebaseJob (RebaseJobFlags (compression opts) (verbosity opts) YesUpdateWorking) $ + \(repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> (do patches <- readRepo repository - (rOld, Sealed ps, _) <- return $ takeHeadRebase patches + (rOld, Items ps, _) <- return $ takeHeadRebase patches let selects = toRebaseSelect ps -- TODO this selection doesn't need to respect dependencies let patches_context = selectionContextGeneric rsToPia First "obliterate" (obliteratePatchSelOpts opts) Nothing - (chosen :> keep) <- runSelection (selectChanges selects) patches_context + (chosen :> keep) <- runSelection selects patches_context when (nullFL chosen) $ do putStrLn "No patches selected!" exitSuccess @@ -669,7 +673,7 @@ do_obliterate qs let ps_to_keep = do_obliterate (fromRebaseSelect chosen) (fromRebaseSelect keep) - rNew <- unseal mkSuspended ps_to_keep + rNew <- unseal (mkRebase . Items) ps_to_keep repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (rOld :>: NilFL) repository'' <- tentativelyAddPatch repository' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew) @@ -906,21 +910,24 @@ data RebasePatchApplier = RebasePatchApplier instance PatchApplier RebasePatchApplier where - type CarrierType RebasePatchApplier p = Rebasing p + type ApplierRepoTypeConstraint RebasePatchApplier rt = rt ~ 'RepoType 'IsRebase repoJob RebasePatchApplier opts f = - StartRebaseJob (compression opts) (verbosity opts) YesUpdateWorking (f PatchProxy) + StartRebaseJob + (RebaseJobFlags (compression opts) (verbosity opts) YesUpdateWorking) + (f PatchProxy) applyPatches RebasePatchApplier PatchProxy = applyPatchesForRebaseCmd applyPatchesForRebaseCmd :: forall p wR wU wX wT wZ - . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + . ( RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree + ) => String -> [DarcsFlag] -> String - -> Repository (Rebasing p) wR wU wT - -> FL (PatchInfoAnd (Rebasing p)) wX wT - -> FL (PatchInfoAnd (Rebasing p)) wX wZ + -> Repository ('RepoType 'IsRebase) p wR wU wT + -> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wT + -> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wZ -> IO () applyPatchesForRebaseCmd cmdName opts _from_whom repository us' to_be_applied = do printDryRunMessageAndExit cmdName @@ -946,11 +953,16 @@ -- command, review if there are any we should keep let patches_context = selectionContext LastReversed "suspend" applyPatchSelOpts Nothing Nothing - (usKeep :> usToSuspend) <- runSelection (selectChanges usConflicted) patches_context + (usKeep :> usToSuspend) <- runSelection usConflicted patches_context - (rOld, Sealed qs, _) <- return $ takeHeadRebaseFL us' - repository' <- doSuspend opts repository qs rOld usToSuspend + -- test all patches for hijacking and abort if rejected + runHijackT RequestHijackPermission + $ mapM_ (getAuthor "suspend" False Nothing) + $ mapFL info usToSuspend + (rOld, suspended, _) <- return $ takeHeadRebaseFL us' + repository' <- doSuspend opts repository suspended rOld usToSuspend + -- TODO This is a nasty hack, caused by the fact that readUnrecorded -- claims to read the tentative state but actual reads the committed state -- as a result we have to commit here so that tentativelyMergePatches does @@ -978,7 +990,6 @@ applyPatchSelOpts = S.PatchSelectionOptions { S.verbosity = O.NormalVerbosity , S.matchFlags = [] - , S.diffAlgorithm = O.PatienceDiff , S.interactive = True , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary @@ -994,7 +1005,6 @@ patchSelOpts defInteractive flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveralOrLast flags - , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive defInteractive flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags @@ -1051,9 +1061,9 @@ logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () logCmd _ opts _files = withRepository (useCache opts) $ - RebaseJob (compression opts) (verbosity opts) YesUpdateWorking $ \repository -> do + RebaseJob (RebaseJobFlags (compression opts) (verbosity opts) YesUpdateWorking) $ \repository -> do patches <- readRepo repository - (_, Sealed ps, _) <- return $ takeHeadRebase patches + (_, Items ps, _) <- return $ takeHeadRebase patches let psToShow = toRebaseChanges ps if isInteractive False opts then viewChanges (patchSelOpts False opts) (mapFL Sealed2 psToShow) diff --git a/src/Darcs/UI/Commands/Record.hs b/src/Darcs/UI/Commands/Record.hs --- a/src/Darcs/UI/Commands/Record.hs +++ b/src/Darcs/UI/Commands/Record.hs @@ -15,32 +15,26 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, PatternGuards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Record ( record , commit - , getLog -- used by amend and tag, too , recordConfig, RecordConfig(..) -- needed for darcsden ) where -import Prelude hiding ( (^), catch ) +import Prelude () +import Darcs.Prelude +import Data.Foldable ( traverse_ ) -import Control.Applicative ( (<$>) ) -import Control.Exception ( handleJust, catch, IOException ) +import Control.Exception ( handleJust ) import Control.Monad ( when, unless, void ) -import System.IO ( stdin ) -import Data.List ( sort, isPrefixOf ) +import Data.List ( sort ) import Data.Char ( ord ) import System.Exit ( exitFailure, exitSuccess, ExitCode(..) ) import System.Directory ( removeFile ) -import qualified Data.ByteString as B ( hPut ) -import Darcs.Repository.Lock - ( readLocaleFile - , writeLocaleFile - , appendToFile - ) import Darcs.Patch.PatchInfoAnd ( n2pia ) import Darcs.Repository ( Repository @@ -53,9 +47,8 @@ , readRecorded , listRegisteredFiles ) -import Darcs.Patch - ( RepoPatch, Patchy, PrimOf, PrimPatch - , namepatch, summaryFL, adddeps, fromPrims ) +import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf, fromPrims ) +import Darcs.Patch.Named.Wrapped ( namepatch, adddeps ) import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), nullFL ) @@ -63,16 +56,14 @@ import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Split ( primSplitter ) -import Darcs.UI.External ( editFile ) import Darcs.UI.SelectChanges - ( selectChanges - , WhichChanges(..) + ( WhichChanges(..) , selectionContextPrim , runSelection , askAboutDepends ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) -import Darcs.Util.Path ( FilePathLike, SubPath, toFilePath, AbsolutePath ) +import Darcs.Util.Path ( SubPath, toFilePath, AbsolutePath ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , nodefaults @@ -81,7 +72,7 @@ , setEnvDarcsPatches , amInHashedRepository ) -import Darcs.UI.Commands.Util ( announceFiles, filterExistingFiles, +import Darcs.UI.Commands.Util ( announceFiles, filterExistingPaths, testTentativeAndMaybeExit ) import Darcs.UI.Flags ( DarcsFlag @@ -89,21 +80,22 @@ , getAuthor , getDate , diffOpts + , scanKnown , fixSubPaths ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, oparse, defaultFlags ) +import Darcs.UI.PatchHeader ( getLog ) import qualified Darcs.UI.Options.All as O -import Darcs.Repository.Flags ( UpdateWorking (..), DryRun(NoDryRun) ) -import Darcs.Repository.Util ( getMovesPs, getReplaces ) +import Darcs.Repository.Flags ( UpdateWorking (..), DryRun(NoDryRun), ScanKnown(..) ) +import Darcs.Repository.State ( getMovesPs, getReplaces ) import Darcs.Util.Exception ( clarifyErrors ) -import Darcs.Util.Prompt ( askUser, promptYorn ) +import Darcs.Util.Prompt ( promptYorn ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Global ( darcsLastMessage ) import Darcs.Patch.Progress ( progressFL ) -import Darcs.Util.Printer ( putDocLn, hPutDocLn, text, ($$), prefixLines, RenderMode(..) ) -import Darcs.Util.ByteString ( encodeLocale ) -import qualified Darcs.Util.Ratified as Ratified ( hGetContents ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Printer ( putDocLn, text, (<+>) ) +import Darcs.Util.Text ( pathlist ) +import Darcs.Util.Tree( Tree ) recordDescription :: String recordDescription = "Create a patch from unrecorded changes." @@ -143,8 +135,8 @@ ^ O.diffAlgorithm recordAdvancedOpts :: DarcsOption a - (O.Logfile -> O.Compression -> O.UseIndex -> O.UMask -> O.SetScriptsExecutable -> a) -recordAdvancedOpts = O.logfile ^ O.compress ^ O.useIndex ^ O.umask ^ O.setScriptsExecutable + (O.Logfile -> O.Compression -> O.UseIndex -> O.UMask -> O.SetScriptsExecutable -> O.IncludeBoring -> a) +recordAdvancedOpts = O.logfile ^ O.compress ^ O.useIndex ^ O.umask ^ O.setScriptsExecutable ^ O.includeBoring recordOpts :: DarcsOption a (Maybe String @@ -168,6 +160,7 @@ -> O.UseIndex -> O.UMask -> O.SetScriptsExecutable + -> O.IncludeBoring -> O.UseCache -> Maybe String -> Bool @@ -194,6 +187,7 @@ , useIndex :: O.UseIndex , umask :: O.UMask , sse :: O.SetScriptsExecutable + , includeBoring :: O.IncludeBoring , useCache :: O.UseCache } @@ -223,27 +217,37 @@ commit :: DarcsCommand RecordConfig commit = commandAlias "commit" Nothing record +reportNonExisting :: ScanKnown -> ([SubPath], [SubPath]) -> IO () +reportNonExisting scan (paths_only_in_working, _) = do + unless (scan /= ScanKnown || null paths_only_in_working) $ putDocLn $ + "These paths are not yet in the repository and will be added:" <+> + pathlist (map toFilePath paths_only_in_working) + recordCmd :: (AbsolutePath, AbsolutePath) -> RecordConfig -> [String] -> IO () recordCmd fps cfg args = do - checkNameIsNotOption (patchname cfg) (isInteractive True cfg) - withRepoLock NoDryRun (useCache cfg) YesUpdateWorking (umask cfg) $ RepoJob $ \(repository :: Repository p wR wU wR) -> do + checkNameIsNotOption (patchname cfg) (isInteractive cfg) + withRepoLock NoDryRun (useCache cfg) YesUpdateWorking (umask cfg) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do files <- if null args then return Nothing else Just . sort <$> fixSubPaths fps args when (files == Just []) $ fail "No valid arguments were given." - announceFiles files "Recording changes in" - existing_files <- maybe (return Nothing) - (fmap Just . filterExistingFiles repository (O.adds (lookfor cfg))) files + let scan = scanKnown (O.adds (lookfor cfg)) (includeBoring cfg) + files' <- traverse (filterExistingPaths repository (verbosity cfg) (useIndex cfg) scan) files + when (verbosity cfg /= O.Quiet) $ + traverse_ (reportNonExisting scan) files' + let existing_files = fmap snd files' when (existing_files == Just []) $ - fail "None of the files you specified exist!" + fail "None of the files you specified exist." + announceFiles (verbosity cfg) existing_files "Recording changes in" debugMessage "About to get the unrecorded changes." Sealed replacePs <- if O.replaces (lookfor cfg) == O.YesLookForReplaces - then getReplaces (diffingOpts cfg) repository files - else return (Sealed NilFL) + then getReplaces (diffingOpts cfg) repository files + else return (Sealed NilFL) movesPs <- if O.moves (lookfor cfg) == O.YesLookForMoves then getMovesPs repository files else return NilFL - changes <- unrecordedChangesWithPatches (diffingOpts cfg) repository files + changes <- unrecordedChangesWithPatches movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR) + (diffingOpts cfg) repository files debugMessage "I've got unrecorded changes." case changes of NilFL | not (askDeps cfg) -> do @@ -264,19 +268,20 @@ confirmed <- promptYorn $ "You specified " ++ show name ++ " as the patch name. Is that really what you want?" unless confirmed $ putStrLn "Okay, aborting the record." >> exitFailure -doRecord :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => Repository p wR wU wR -> RecordConfig -> Maybe [SubPath] -> FL (PrimOf p) wR wX -> IO () +doRecord :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => Repository rt p wR wU wR -> RecordConfig -> Maybe [SubPath] -> FL (PrimOf p) wR wX -> IO () doRecord repository cfg files ps = do date <- getDate (pipe cfg) my_author <- getAuthor (author cfg) (pipe cfg) debugMessage "I'm slurping the repository." - debugMessage "About to select changes..." pristine <- readRecorded repository - (chs :> _ ) <- runSelection (selectChanges ps) $ - selectionContextPrim First "record" (patchSelOpts cfg) (Just primSplitter) + debugMessage "About to select changes..." + (chs :> _ ) <- runSelection ps $ + selectionContextPrim First "record" (patchSelOpts cfg) + (Just (primSplitter (diffAlgorithm cfg))) (map toFilePath <$> files) (Just pristine) - when (is_empty_but_not_askdeps chs) $ + when (not (askDeps cfg) && nullFL chs) $ do putStrLn "Ok, if you don't want to record anything, that's fine!" exitSuccess handleJust onlySuccessfulExits (\_ -> return ()) $ @@ -290,13 +295,9 @@ (name, my_log, logf) <- getLog (patchname cfg) (pipe cfg) (logfile cfg) (askLongComment cfg) Nothing chs debugMessage ("Patch name as received from getLog: " ++ show (map ord name)) doActualRecord repository cfg name date my_author my_log logf deps chs - where is_empty_but_not_askdeps l - | askDeps cfg = False - -- a "partial tag" patch; see below. - | otherwise = nullFL l -doActualRecord :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wR +doActualRecord :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wR -> RecordConfig -> String -> String -> String -> [String] -> Maybe String @@ -315,7 +316,7 @@ (verbosity cfg) (testChanges cfg) (sse cfg) - (isInteractive True cfg) + (isInteractive cfg) ("you have a bad patch: '" ++ name ++ "'") "record it" (Just failuremessage) finalizeRepositoryChanges repository YesUpdateWorking (compress cfg) @@ -342,10 +343,8 @@ , "interactive selection, to let you enter the patch name (first line) and" , "the patch description (subsequent lines)." , "" - , "The patch name should be a short sentence that concisely describes the" - , "patch, such as \"Add error handling to main event loop.\" You can" - , "supply it in advance with the `-m` option, in which case no text editor" - , "is launched, unless you use the `--edit-long-comment` option." + , "You can supply the patch name in advance with the `-m` option, in which" + , "case no text editor is launched, unless you use `--edit-long-comment`." , "" , "The patch description is an optional block of free-form text. It is" , "used to supply additional information that doesn't fit in the patch" @@ -355,169 +354,32 @@ , "A technical difference between patch name and patch description, is" , "that matching with the flag `-p` is only done on patch names." , "" - , "Finally, the `--logfile` option allows you to supply a file that" - , "already contains the patch name and patch description. This is" - , "useful if a previous record failed and left a `darcs-record-0` file." + , "Finally, the `--logfile` option allows you to supply a file that already" + , "contains the patch name and description. This is useful if a previous" + , "record failed and left a `_darcs/patch_description.txt` file." , "" , unlines fileHelpAuthor - , "" , "If you want to manually define any extra dependencies for your patch," - , "you can use the `--ask-deps` flag, and darcs will ask you for the patch's" - , "dependencies. Some dependencies may be automatically inferred from the" - , "patch's content and cannot be removed. " - , "A patch with specific dependencies can be empty." + , "you can use the `--ask-deps` flag. Some dependencies may be automatically" + , "inferred from the patch's content and cannot be removed. A patch with" + , "specific dependencies can be empty." , "" , "The patch date is generated automatically. It can only be spoofed by" , "using the `--pipe` option." , "" , "If you run record with the `--pipe` option, you will be prompted for" , "the patch date, author, and the long comment. The long comment will extend" - , "until the end of file or stdin is reached (ctrl-D on Unixy systems, ctrl-Z" - , "on systems running a Microsoft OS)." - , "" - , "This interface is intended for scripting darcs, in particular for writing" - , "repository conversion scripts. The prompts are intended mostly as a useful" - , "guide (since scripts won't need them), to help you understand the format in" - , "which to provide the input. Here's an example of what the `--pipe`" - , "prompts look like:" + , "until the end of file or stdin is reached. This interface is intended for" + , "scripting darcs, in particular for writing repository conversion scripts." + , "The prompts are intended mostly as a useful guide (since scripts won't" + , "need them), to help you understand the input format. Here's an example of" + , "what the `--pipe` prompts look like:" , "" , " What is the date? Mon Nov 15 13:38:01 EST 2004" , " Who is the author? David Roundy" , " What is the log? One or more comment lines" ] -data PName = FlagPatchName String | PriorPatchName String | NoPatchName - --- | Get the patch name and long description from one of --- --- * the configuration (flags, defaults, hard-coded) --- --- * an existing log file --- --- * stdin (e.g. a pipe) --- --- * a text editor --- --- It ensures the patch name is not empty nor starts with the prefix TAG. --- --- The last result component is a possible path to a temporary file that should be removed later. -getLog :: forall prim wX wY . (Patchy prim, PrimPatch prim) - => Maybe String -- ^ patchname option - -> Bool -- ^ pipe option - -> O.Logfile -- ^ logfile option - -> Maybe O.AskLongComment -- ^ askLongComment option - -> Maybe (String, [String]) -- ^ possibly an existing patch name and long description - -> FL prim wX wY -- ^ changes to record - -> IO (String, [String], Maybe String) -- ^ patch name, long description and possibly the path - -- to the temporary file that should be removed later -getLog m_name has_pipe log_file ask_long m_old chs = go has_pipe log_file ask_long where - go True _ _ = do - p <- case patchname_specified of - FlagPatchName p -> return p - PriorPatchName p -> return p - NoPatchName -> prompt_patchname False - putStrLn "What is the log?" - thelog <- lines `fmap` Ratified.hGetContents stdin - return (p, thelog, Nothing) - go _ (O.Logfile { O._logfile = Just f }) _ = do - mlp <- lines `fmap` readLocaleFile f `catch` (\(_ :: IOException) -> return []) - firstname <- case (patchname_specified, mlp) of - (FlagPatchName p, []) -> return p - (_, p:_) -> if badName p - then prompt_patchname True - else return p -- logfile trumps prior! - (PriorPatchName p, []) -> return p - (NoPatchName, []) -> prompt_patchname True - append_info f firstname - when (ask_long == Just O.YesEditLongComment) (void $ editFile f) - (name, thelog) <- read_long_comment f firstname - return (name, thelog, if O._rmlogfile log_file then Just $ toFilePath f else Nothing) - go _ _ (Just O.YesEditLongComment) = - case patchname_specified of - FlagPatchName p -> actually_get_log p - PriorPatchName p -> actually_get_log p - NoPatchName -> actually_get_log "" - go _ _ (Just O.NoEditLongComment) = - case patchname_specified of - FlagPatchName p -> return (p, default_log, Nothing) -- record (or amend) -m - PriorPatchName p -> return (p, default_log, Nothing) -- amend - NoPatchName -> do p <- prompt_patchname True -- record - return (p, [], Nothing) - go _ _ (Just O.PromptLongComment) = - case patchname_specified of - FlagPatchName p -> prompt_long_comment p -- record (or amend) -m - PriorPatchName p -> prompt_long_comment p - NoPatchName -> prompt_patchname True >>= prompt_long_comment - go _ _ Nothing = - case patchname_specified of - FlagPatchName p -> return (p, default_log, Nothing) -- record (or amend) -m - PriorPatchName "" -> actually_get_log "" - PriorPatchName p -> return (p, default_log, Nothing) - NoPatchName -> actually_get_log "" - - patchname_specified = case (m_name, m_old) of - (Just name, _) | badName name -> NoPatchName - | otherwise -> FlagPatchName name - (Nothing, Just (name,_)) -> PriorPatchName name - (Nothing, Nothing) -> NoPatchName - - badName "" = True - badName n = "TAG" `isPrefixOf` n - - default_log = case m_old of - Nothing -> [] - Just (_,l) -> l - - prompt_patchname retry = - do n <- askUser "What is the patch name? " - if badName n - then if retry then prompt_patchname retry - else fail "Bad patch name!" - else return n - - prompt_long_comment oldname = - do y <- promptYorn "Do you want to add a long comment?" - if y then actually_get_log oldname - else return (oldname, [], Nothing) - - actually_get_log p = do let logf = darcsLastMessage - -- TODO: make sure encoding used for logf is the same everywhere - -- probably should be locale because the editor will assume it - writeLocaleFile logf $ unlines $ p : default_log - append_info logf p - _ <- editFile logf - (name,long) <- read_long_comment logf p - if badName name - then do putStrLn "WARNING: empty or incorrect patch name!" - pn <- prompt_patchname True - return (pn, long, Nothing) - else return (name,long,Just logf) - - read_long_comment :: FilePathLike p => p -> String -> IO (String, [String]) - read_long_comment f oldname = - do f' <- readLocaleFile f - let t = filter (not.("#" `isPrefixOf`)) $ (lines.filter (/='\r')) f' - case t of [] -> return (oldname, []) - (n:ls) -> return (n, ls) - - append_info f oldname = - do fc <- readLocaleFile f - appendToFile f $ \h -> - do case fc of - _ | null (lines fc) -> B.hPut h (encodeLocale (oldname ++ "\n")) - | last fc /= '\n' -> B.hPut h (encodeLocale "\n") - | otherwise -> return () - hPutDocLn Encode h - $ text "# Please enter the patch name in the first line, and" - $$ text "# optionally, a long description in the following lines." - $$ text "#" - $$ text "# Lines starting with '#' will be ignored." - $$ text "#" - $$ text "#" - $$ text "# This patch contains the following changes:" - $$ text "#" - $$ prefixLines (text "#") (summaryFL chs) - onlySuccessfulExits :: ExitCode -> Maybe () onlySuccessfulExits ExitSuccess = Just () onlySuccessfulExits _ = Nothing @@ -544,15 +406,14 @@ patchSelOpts cfg = S.PatchSelectionOptions { S.verbosity = verbosity cfg , S.matchFlags = [] - , S.diffAlgorithm = diffAlgorithm cfg - , S.interactive = isInteractive True cfg + , S.interactive = isInteractive cfg , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default , S.withContext = withContext cfg } diffingOpts :: RecordConfig -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) -diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) False (diffAlgorithm cfg) +diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) O.NoIncludeBoring (diffAlgorithm cfg) -isInteractive :: Bool -> RecordConfig -> Bool -isInteractive def = maybe def id . interactive +isInteractive :: RecordConfig -> Bool +isInteractive = maybe True id . interactive diff --git a/src/Darcs/UI/Commands/Remove.hs b/src/Darcs/UI/Commands/Remove.hs --- a/src/Darcs/UI/Commands/Remove.hs +++ b/src/Darcs/UI/Commands/Remove.hs @@ -19,6 +19,9 @@ module Darcs.UI.Commands.Remove ( remove, rm, unadd ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^) ) import Control.Monad ( when, foldM ) @@ -49,11 +52,9 @@ import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft ) import Darcs.Repository.Prefs ( filetypeFunction, FileType ) -import Storage.Hashed.Tree( Tree, TreeItem(..), find, modifyTree, expand, list ) +import Darcs.Util.Tree( Tree, TreeItem(..), find, modifyTree, expand, list ) import Darcs.Util.Path( anchorPath, AnchoredPath, fn2fp, SubPath, sp2fn - , AbsolutePath ) -import Storage.Hashed( floatPath ) - + , AbsolutePath, floatPath ) import Darcs.Util.Printer ( text ) @@ -137,7 +138,7 @@ -- flag should be handled by the caller by adding all offspring of a directory -- to the files list. makeRemovePatch :: (RepoPatch p, ApplyState p ~ Tree) - => [DarcsFlag] -> Repository p wR wU wT + => [DarcsFlag] -> Repository rt p wR wU wT -> [SubPath] -> IO (Sealed (FL (PrimOf p) wU)) makeRemovePatch opts repository files = do recorded <- expand =<< readRecordedAndPending repository diff --git a/src/Darcs/UI/Commands/Repair.hs b/src/Darcs/UI/Commands/Repair.hs --- a/src/Darcs/UI/Commands/Repair.hs +++ b/src/Darcs/UI/Commands/Repair.hs @@ -21,10 +21,10 @@ , check ) where -import Prelude hiding ( (^), catch ) +import Prelude () +import Darcs.Prelude import Control.Monad ( when, unless ) -import Control.Applicative( (<$>) ) import Control.Exception ( catch, IOException ) import System.Exit ( ExitCode(..), exitWith ) import System.Directory( renameFile ) @@ -44,7 +44,7 @@ import Darcs.Repository ( Repository, withRepository, readRecorded, RepoJob(..), withRepoLock, replacePristine, writePatchSet ) -import Darcs.Patch ( RepoPatch, showPatch, PrimOf ) +import Darcs.Patch ( IsRepoType, RepoPatch, showPatch, PrimOf ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Witnesses.Ordered ( FL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft ) @@ -53,7 +53,7 @@ import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Printer ( text, ($$), (<+>) ) import Darcs.Util.Path ( AbsolutePath ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) repairDescription :: String @@ -137,8 +137,8 @@ putStrLn "Bad index discarded." check' - :: forall p wR wU wT . (RepoPatch p, ApplyState p ~ Tree) - => [DarcsFlag] -> Repository p wR wU wT -> IO () + :: forall rt p wR wU wT . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => [DarcsFlag] -> Repository rt p wR wU wT -> IO () check' opts repository = do state <- replayRepositoryInTemp (F.diffAlgorithm opts) repository (compression opts) (verbosity opts) failed <- diff --git a/src/Darcs/UI/Commands/Replace.hs b/src/Darcs/UI/Commands/Replace.hs --- a/src/Darcs/UI/Commands/Replace.hs +++ b/src/Darcs/UI/Commands/Replace.hs @@ -22,18 +22,18 @@ , defaultToks ) where -import Prelude hiding ( (^), catch ) +import Prelude () +import Darcs.Prelude import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as BS import Data.Char ( isSpace ) import Data.Maybe ( isJust ) -import Control.Applicative( (<$>) ) import Control.Exception ( catch, IOException ) import Control.Monad ( unless, filterM, void ) -import Storage.Hashed.Tree( readBlob, modifyTree, findFile, TreeItem(..), Tree - , makeBlobBS ) +import Darcs.Util.Tree( readBlob, modifyTree, findFile, TreeItem(..), Tree + , makeBlobBS ) import Darcs.Util.Path( SubPath, toFilePath, AbsolutePath ) import Darcs.UI.Flags ( DarcsFlag( ForceReplace, Toks ) @@ -44,9 +44,8 @@ import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.Repository.Diff( treeDiff ) import Darcs.Patch ( Patchy, PrimPatch, tokreplace, forceTokReplace - , applyToTree ) + , maybeApplyToTree ) import Darcs.Patch.Apply( ApplyState ) -import Darcs.Patch.Patchy ( Apply ) import Darcs.Patch.RegChars ( regChars ) import Darcs.Repository ( withRepoLock @@ -57,8 +56,9 @@ , readRecordedAndPending , listRegisteredFiles ) +import Darcs.Patch.TokenReplace ( defaultToks ) import Darcs.Repository.Prefs ( FileType(TextFile) ) -import Darcs.Repository.Util ( floatSubPath, defaultToks ) +import Darcs.Util.Path ( floatSubPath ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), concatFL, toFL, nullFL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..), unFreeLeft, unseal ) @@ -244,14 +244,6 @@ tokreplace (toFilePath f) toks old new :>: NilFL replaceCmd _ _ [_, _] = fail "You need to supply a list of files to replace in!" replaceCmd _ _ _ = fail "Usage: darcs replace OLD NEW [FILES]" - --- | Attempts to apply a given replace patch to a Tree. If the apply fails (if --- the file the patch applies to already contains the target token), we return --- Nothing, otherwise we return the updated Tree. -maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Tree IO - -> IO (Maybe (Tree IO)) -maybeApplyToTree patch tree = - (Just `fmap` applyToTree patch tree) `catch` (\(_ :: IOException) -> return Nothing) filenameToks :: String filenameToks = "A-Za-z_0-9\\-\\." diff --git a/src/Darcs/UI/Commands/Revert.hs b/src/Darcs/UI/Commands/Revert.hs --- a/src/Darcs/UI/Commands/Revert.hs +++ b/src/Darcs/UI/Commands/Revert.hs @@ -15,24 +15,25 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. +{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Revert ( revert ) where -import Prelude hiding ( (^), catch ) +import Prelude () +import Darcs.Prelude -import Control.Applicative ( (<$>) ) import Control.Exception ( catch, IOException ) -import Control.Monad ( when ) import Data.List ( sort ) import Darcs.UI.Flags - ( DarcsFlag( Debug ), diffingOpts, verbosity, diffAlgorithm, isInteractive, isUnified + ( DarcsFlag, diffingOpts, verbosity, diffAlgorithm, isInteractive, isUnified , dryRun, umask, useCache, fixSubPaths ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( UpdateWorking(..) ) -import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) +import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository, putInfo ) import Darcs.UI.Commands.Util ( announceFiles ) import Darcs.UI.Commands.Unrevert ( writeUnrevert ) +import Darcs.Util.Global ( debugMessage ) import Darcs.Util.Path ( toFilePath, AbsolutePath ) import Darcs.Repository ( withRepoLock @@ -48,8 +49,7 @@ import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), nullFL, (+>+) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.UI.SelectChanges - ( selectChanges - , WhichChanges(Last) + ( WhichChanges(Last) , selectionContextPrim , runSelection ) @@ -109,7 +109,6 @@ patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = [] - , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default @@ -140,30 +139,29 @@ withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do files <- if null args then return Nothing else Just . sort <$> fixSubPaths fps args - announceFiles files "Reverting changes in" + announceFiles (verbosity opts) files "Reverting changes in" changes <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository files let pre_changed_files = effectOnFilePaths (invert changes) . map toFilePath <$> files recorded <- readRecorded repository Sealed touching_changes <- return (chooseTouching pre_changed_files changes) - (case touching_changes of - NilFL -> putStrLn "There are no changes to revert!" + case touching_changes of + NilFL -> putInfo opts "There are no changes to revert!" _ -> do let context = selectionContextPrim Last "revert" (patchSelOpts opts) - (Just reversePrimSplitter) pre_changed_files (Just recorded) - (norevert:>p) <- runSelection (selectChanges changes) context + (Just (reversePrimSplitter (diffAlgorithm opts))) + pre_changed_files (Just recorded) + (norevert:>p) <- runSelection changes context if nullFL p - then putStrLn $ "If you don't want to revert after all," ++ - " that's fine with me!" + then putInfo opts $ "If you don't want to revert after all, that's fine with me!" else do addToPending repository YesUpdateWorking $ invert p - when (Debug `elem` opts) $ putStrLn "About to write the unrevert file." + debugMessage "About to write the unrevert file." case commute (norevert:>p) of Just (p':>_) -> writeUnrevert repository p' recorded NilFL Nothing -> writeUnrevert repository (norevert+>+p) recorded NilFL - when (Debug `elem` opts) $ putStrLn "About to apply to the working directory." + debugMessage "About to apply to the working directory." _ <- applyToWorking repository (verbosity opts) (invert p) `catch` \(e :: IOException) -> fail ("Unable to apply inverse patch!" ++ show e) - return ()) :: IO () - putStrLn "Finished reverting." - + return () + putInfo opts "Finished reverting." diff --git a/src/Darcs/UI/Commands/Rollback.hs b/src/Darcs/UI/Commands/Rollback.hs --- a/src/Darcs/UI/Commands/Rollback.hs +++ b/src/Darcs/UI/Commands/Rollback.hs @@ -19,20 +19,21 @@ module Darcs.UI.Commands.Rollback ( rollback ) where -import Prelude hiding ( (^), catch ) +import Prelude () +import Darcs.Prelude -import Control.Applicative ( (<$>) ) import Control.Exception ( catch, IOException ) import Control.Monad ( when ) import Data.List ( sort ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) import System.Exit ( exitSuccess ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Match ( firstMatch ) import Darcs.Patch.PatchInfoAnd ( n2pia ) -import Darcs.Patch ( RepoPatch, invert, effect, fromPrims, sortCoalesceFL, - canonize, anonymous, PrimOf ) +import Darcs.Patch ( IsRepoType, RepoPatch, invert, effect, fromPrims, sortCoalesceFL, + canonize, PrimOf ) +import Darcs.Patch.Named.Wrapped ( anonymous ) import Darcs.Patch.Set ( PatchSet(..), newset2FL ) import Darcs.Patch.Split ( reversePrimSplitter ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), RL(..), concatFL, @@ -56,7 +57,7 @@ , defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O -import Darcs.UI.SelectChanges ( selectChanges, WhichChanges(..), +import Darcs.UI.SelectChanges ( WhichChanges(..), selectionContext, selectionContextPrim, runSelection ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) @@ -65,20 +66,20 @@ rollbackDescription :: String rollbackDescription = - "Apply the inverse of recorded changes to the working copy." + "Apply the inverse of recorded changes to the working tree." rollbackHelp :: String rollbackHelp = unlines [ "Rollback is used to undo the effects of some changes from patches" , "in the repository. The selected changes are undone in your working" - , "copy, but the repository is left unchanged. First you are offered a" + , "tree, but the repository is left unchanged. First you are offered a" , "choice of which patches to undo, then which changes within the" , "patches to undo." , "" , "Before doing `rollback`, you may want to temporarily undo the changes" - , "of your working copy (if there are) and save them for later use." + , "of your working tree (if there are) and save them for later use." , "To do so, you can run `revert`, then run `rollback`, record a patch," - , "and run `unrevert` to restore the saved changes into your working copy." + , "and run `unrevert` to restore the saved changes into your working tree." ] rollbackBasicOpts :: DarcsOption a @@ -116,7 +117,6 @@ patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveralOrLast flags - , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps , S.summary = O.NoSummary @@ -154,7 +154,7 @@ else Just . sort <$> fixSubPaths fps args when (files == Just []) $ fail "No valid arguments were given." - announceFiles files "Rolling back changes in" + announceFiles (verbosity opts) files "Rolling back changes in" allpatches <- readRepo repository let matchFlags = parseFlags O.matchSeveralOrLast opts (_ :> patches) <- return $ @@ -164,17 +164,18 @@ let filesFps = map toFilePath <$> files patchCtx = selectionContext LastReversed "rollback" (patchSelOpts opts) Nothing filesFps (_ :> ps) <- - runSelection (selectChanges patches) patchCtx + runSelection patches patchCtx exitIfNothingSelected ps "patches" setEnvDarcsPatches ps let hunkContext = selectionContextPrim Last "rollback" (patchSelOpts opts) - (Just reversePrimSplitter) filesFps Nothing + (Just (reversePrimSplitter (diffAlgorithm opts))) + filesFps Nothing hunks = concatFL . mapFL_FL (canonize $ F.diffAlgorithm opts) . sortCoalesceFL . effect $ ps - whatToUndo <- runSelection (selectChanges hunks) hunkContext + whatToUndo <- runSelection hunks hunkContext undoItNow opts repository whatToUndo -undoItNow :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) - => [DarcsFlag] -> Repository p wR wU wT +undoItNow :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => [DarcsFlag] -> Repository rt p wR wU wT -> (q :> FL (PrimOf p)) wA wT -> IO () undoItNow opts repo (_ :> prims) = do exitIfNothingSelected prims "changes" diff --git a/src/Darcs/UI/Commands/Send.hs b/src/Darcs/UI/Commands/Send.hs --- a/src/Darcs/UI/Commands/Send.hs +++ b/src/Darcs/UI/Commands/Send.hs @@ -19,8 +19,11 @@ module Darcs.UI.Commands.Send ( send ) where -import Prelude hiding ( (^), catch ) +import Prelude () +import Darcs.Prelude +import Prelude hiding ( (^) ) + import System.Exit ( exitSuccess #ifndef HAVE_MAPI @@ -32,7 +35,7 @@ import System.IO ( hClose ) import Control.Exception ( catch, IOException ) import Control.Monad ( when, unless, forM_ ) -import Storage.Hashed.Tree ( Tree ) +import Darcs.Util.Tree ( Tree ) import Data.List ( intercalate, isPrefixOf ) #ifdef HAVE_HTTP import Data.List ( stripPrefix ) @@ -86,7 +89,7 @@ readRepo, readRecorded, prefsUrl, checkUnrelatedRepos ) import Darcs.Patch.Set ( Origin ) import Darcs.Patch.Apply( ApplyState ) -import Darcs.Patch ( RepoPatch, description, applyToTree, invert ) +import Darcs.Patch ( IsRepoType, RepoPatch, description, applyToTree, invert ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Witnesses.Ordered @@ -94,7 +97,7 @@ mapFL, mapFL_FL, lengthFL, nullFL ) import Darcs.Patch.Bundle ( minContext, makeBundleN, scanContextFile, patchFilename ) import Darcs.Repository.Prefs ( addRepoSource, getPreflist ) -import Darcs.Repository.External ( fetchFilePS, Cachable(..) ) +import Darcs.Util.External ( fetchFilePS, Cachable(..) ) import Darcs.UI.External ( signString , sendEmailDoc @@ -109,15 +112,14 @@ ) import Darcs.Util.ByteString ( mmapFilePS, isAscii ) import qualified Data.ByteString.Char8 as BC (unpack) -import Darcs.Repository.Lock +import Darcs.Util.Lock ( withOpenTemp , writeDocBinFile , readDocBinFile , removeFileMayNotExist ) import Darcs.UI.SelectChanges - ( selectChanges - , WhichChanges(..) + ( WhichChanges(..) , selectionContext , runSelection ) @@ -233,7 +235,6 @@ patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveral flags - , S.diffAlgorithm = O.PatienceDiff , S.interactive = isInteractive True flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags @@ -263,11 +264,11 @@ sendCmd fps input_opts [""] = sendCmd fps input_opts [] sendCmd (_,o) input_opts [unfixedrepodir] = withRepository (useCache input_opts) $ RepoJob $ - \(repository :: Repository p wR wU wR) -> do + \(repository :: Repository rt p wR wU wR) -> do context_ps <- the_context input_opts case context_ps of Just them -> do - wtds <- decideOnBehavior input_opts (Nothing :: Maybe (Repository p wR wU wR)) + wtds <- decideOnBehavior input_opts (Nothing :: Maybe (Repository rt p wR wU wR)) sendToThem repository input_opts wtds "CONTEXT" them Nothing -> do repodir <- fixUrl o unfixedrepodir @@ -289,9 +290,9 @@ the_context (_:fs) = the_context fs sendCmd _ _ _ = impossible -sendToThem :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> [DarcsFlag] -> [WhatToDo] -> String - -> PatchSet p Origin wX -> IO () +sendToThem :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> [DarcsFlag] -> [WhatToDo] -> String + -> PatchSet rt p Origin wX -> IO () sendToThem repo opts wtds their_name them = do #ifndef HAVE_MAPI -- Check if the user has sendmail or provided a --sendmail-cmd @@ -313,7 +314,7 @@ pristine <- readRecorded repo let direction = if doReverse opts then FirstReversed else First context = selectionContext direction "send" (patchSelOpts opts) Nothing Nothing - (to_be_sent :> _) <- runSelection (selectChanges us') context + (to_be_sent :> _) <- runSelection us' context printDryRunMessageAndExit "send" (verbosity opts) (hasSummary O.NoSummary opts) @@ -347,10 +348,10 @@ Nothing -> sendBundle opts to_be_sent bundle fname wtds their_name -prepareBundle :: forall p wX wY wZ. (RepoPatch p, ApplyState p ~ Tree) - => [DarcsFlag] -> PatchSet p Origin wZ - -> Either (FL (PatchInfoAnd p) wX wY) - (Tree IO, (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wX wY) +prepareBundle :: forall rt p wX wY wZ. (RepoPatch p, ApplyState p ~ Tree) + => [DarcsFlag] -> PatchSet rt p Origin wZ + -> Either (FL (PatchInfoAnd rt p) wX wY) + (Tree IO, (FL (PatchInfoAnd rt p) :\/: FL (PatchInfoAnd rt p)) wX wY) -> IO Doc prepareBundle opts common e = do unsig_bundle <- @@ -365,12 +366,12 @@ (mapFL_FL hopefully to_be_sent) signString (parseFlags O.sign opts) unsig_bundle -sendBundle :: forall p wX wY . (RepoPatch p, ApplyState p ~ Tree) - => [DarcsFlag] -> FL (PatchInfoAnd p) wX wY +sendBundle :: forall rt p wX wY . (RepoPatch p, ApplyState p ~ Tree) + => [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wY -> Doc -> String -> [WhatToDo] -> String -> IO () sendBundle opts to_be_sent bundle fname wtds their_name= let - auto_subject :: forall pp wA wB . FL (PatchInfoAnd pp) wA wB -> String + auto_subject :: forall pp wA wB . FL (PatchInfoAnd rt pp) wA wB -> String auto_subject (p:>:NilFL) = "darcs patch: " ++ trim (patchDesc p) 57 auto_subject (p:>:ps) = "darcs patch: " ++ trim (patchDesc p) 43 ++ " (and " ++ show (lengthFL ps) ++ " more)" @@ -453,8 +454,8 @@ removeFileMayNotExist mailfile cleanup _ Nothing = return () -writeBundleToFile :: forall p wX wY . (RepoPatch p, ApplyState p ~ Tree) - => [DarcsFlag] -> FL (PatchInfoAnd p) wX wY -> Doc -> +writeBundleToFile :: forall rt p wX wY . (RepoPatch p, ApplyState p ~ Tree) + => [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wY -> Doc -> AbsolutePathOrStd -> [WhatToDo] -> String -> IO () writeBundleToFile opts to_be_sent bundle fname wtds their_name = do (d,f,_) <- getDescription opts their_name to_be_sent @@ -470,7 +471,7 @@ = Post String -- ^ POST the patch via HTTP | SendMail String -- ^ send patch via email -decideOnBehavior :: RepoPatch p => [DarcsFlag] -> Maybe (Repository p wR wU wT) -> IO [WhatToDo] +decideOnBehavior :: RepoPatch p => [DarcsFlag] -> Maybe (Repository rt p wR wU wT) -> IO [WhatToDo] decideOnBehavior opts remote_repo = case the_targets of [] -> do wtds <- case remote_repo of @@ -522,7 +523,7 @@ f em = SendMail em getDescription :: (RepoPatch p, ApplyState p ~ Tree) - => [DarcsFlag] -> String -> FL (PatchInfoAnd p) wX wY -> IO (Doc, Maybe String, Maybe String) + => [DarcsFlag] -> String -> FL (PatchInfoAnd rt p) wX wY -> IO (Doc, Maybe String, Maybe String) getDescription opts their_name patches = case get_filename of Just file -> do diff --git a/src/Darcs/UI/Commands/SetPref.hs b/src/Darcs/UI/Commands/SetPref.hs --- a/src/Darcs/UI/Commands/SetPref.hs +++ b/src/Darcs/UI/Commands/SetPref.hs @@ -19,6 +19,9 @@ module Darcs.UI.Commands.SetPref ( setpref ) where +import Prelude () +import Darcs.Prelude + import System.Exit ( exitWith, ExitCode(..) ) import Control.Monad (when) import Data.Maybe (fromMaybe) diff --git a/src/Darcs/UI/Commands/Show.hs b/src/Darcs/UI/Commands/Show.hs --- a/src/Darcs/UI/Commands/Show.hs +++ b/src/Darcs/UI/Commands/Show.hs @@ -15,8 +15,11 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.UI.Commands.Show ( showCommand, list, query ) where +module Darcs.UI.Commands.Show ( showCommand ) where +import Prelude () +import Darcs.Prelude + import Darcs.UI.Commands ( DarcsCommand(..) , normalCommand, hiddenCommand , commandAlias, amInRepository @@ -24,23 +27,21 @@ import Darcs.UI.Commands.ShowAuthors ( showAuthors ) import Darcs.UI.Commands.ShowBug ( showBug ) import Darcs.UI.Commands.ShowContents ( showContents ) -import Darcs.UI.Commands.ShowFiles ( showFiles, manifestCmd, toListManifest ) +import Darcs.UI.Commands.ShowDependencies ( showDeps ) +import Darcs.UI.Commands.ShowFiles ( showFiles ) import Darcs.UI.Commands.ShowTags ( showTags ) import Darcs.UI.Commands.ShowRepo ( showRepo ) import Darcs.UI.Commands.ShowIndex ( showIndex, showPristineCmd ) -import Darcs.UI.Commands.ShowPatchIndex ( showPatchIndexAll, showPatchIndexFiles, showPatchIndexStatus, patchIndexTest ) +import Darcs.UI.Commands.ShowPatchIndex ( showPatchIndex ) import Darcs.UI.Flags ( DarcsFlag ) showDescription :: String -showDescription = "Show information which is stored by darcs." +showDescription = "Show information about the given repository." showHelp :: String showHelp = "Use the `--help` option with the subcommands to obtain help for\n"++ - "subcommands (for example, `darcs show files --help`).\n" ++ - "\n" ++ - "In previous releases, this command was called `darcs query`.\n" ++ - "Currently this is a deprecated alias.\n" + "subcommands (for example, `darcs show files --help`).\n" showCommand :: DarcsCommand [DarcsFlag] showCommand = SuperCommand @@ -52,24 +53,16 @@ , commandSubCommands = [ hiddenCommand showBug , normalCommand showContents - , normalCommand showFiles, hiddenCommand showManifest + , normalCommand showDeps + , normalCommand showFiles , normalCommand showIndex , normalCommand showPristine , normalCommand showRepo , normalCommand showAuthors , normalCommand showTags - , normalCommand showPatchIndexAll - , normalCommand showPatchIndexFiles - , normalCommand showPatchIndexStatus - , normalCommand patchIndexTest ] + , normalCommand showPatchIndex ] } -query :: DarcsCommand [DarcsFlag] -query = commandAlias "query" Nothing showCommand - -list :: DarcsCommand [DarcsFlag] -list = commandAlias "list" Nothing showCommand - -- unfortunately, aliases for sub-commands have to live in their parent command -- to avoid an import cycle showPristine :: DarcsCommand [DarcsFlag] @@ -82,8 +75,4 @@ "For files, the fields correspond to file size, sha256 of the pristine " ++ "file content and the filename." } -showManifest :: DarcsCommand [DarcsFlag] -showManifest = (commandAlias "manifest" (Just showCommand) showFiles) { - commandCommand = manifestCmd toListManifest -} diff --git a/src/Darcs/UI/Commands/ShowAuthors.hs b/src/Darcs/UI/Commands/ShowAuthors.hs --- a/src/Darcs/UI/Commands/ShowAuthors.hs +++ b/src/Darcs/UI/Commands/ShowAuthors.hs @@ -19,6 +19,9 @@ ( showAuthors, Spelling, compiledAuthorSpellings, canonizeAuthor, rankAuthors ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^), catch ) import Control.Arrow ( (&&&), (***) ) diff --git a/src/Darcs/UI/Commands/ShowBug.hs b/src/Darcs/UI/Commands/ShowBug.hs --- a/src/Darcs/UI/Commands/ShowBug.hs +++ b/src/Darcs/UI/Commands/ShowBug.hs @@ -19,6 +19,9 @@ module Darcs.UI.Commands.ShowBug ( showBug ) where +import Prelude () +import Darcs.Prelude + import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository ) import Darcs.UI.Flags ( DarcsFlag ) import Darcs.UI.Options ( DarcsOption, oid, odesc, ocheck, onormalise, defaultFlags ) diff --git a/src/Darcs/UI/Commands/ShowContents.hs b/src/Darcs/UI/Commands/ShowContents.hs --- a/src/Darcs/UI/Commands/ShowContents.hs +++ b/src/Darcs/UI/Commands/ShowContents.hs @@ -17,6 +17,9 @@ module Darcs.UI.Commands.ShowContents ( showContents ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^) ) import Control.Monad ( filterM, forM_, forM ) @@ -30,17 +33,17 @@ import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O ( MatchFlag - , matchOne + , matchUpToOne , workingRepoDir , StdCmdAction , Verbosity , UseCache ) import Darcs.Patch.Match ( haveNonrangeMatch ) import Darcs.Repository ( withRepository, RepoJob(..), readRecorded, repoPatchType ) -import Darcs.Repository.Lock ( withDelayedDir ) +import Darcs.Util.Lock ( withDelayedDir ) import Darcs.Repository.Match ( getNonrangeMatch ) -import Storage.Hashed.Plain( readPlainTree ) -import qualified Storage.Hashed.Monad as HSM +import Darcs.Util.Tree.Plain( readPlainTree ) +import qualified Darcs.Util.Tree.Monad as TM import Darcs.Util.Path( floatPath, sp2fn, toFilePath, AbsolutePath ) showContentsDescription :: String @@ -53,7 +56,7 @@ "version of the file(s).\n" showContentsBasicOpts :: DarcsOption a ([O.MatchFlag] -> Maybe String -> a) -showContentsBasicOpts = O.matchOne ^ O.workingRepoDir +showContentsBasicOpts = O.matchUpToOne ^ O.workingRepoDir showContentsOpts :: DarcsOption a ([O.MatchFlag] @@ -69,7 +72,7 @@ -> Maybe String -> Bool -> a) -showContentsOpts = O.matchOne ^ O.workingRepoDir `withStdOpts` oid +showContentsOpts = O.matchUpToOne ^ O.workingRepoDir `withStdOpts` oid showContents :: DarcsCommand [DarcsFlag] showContents = DarcsCommand @@ -94,15 +97,15 @@ showContentsCmd _ _ [] = fail "show contents needs at least one argument." showContentsCmd fps opts args = do floatedPaths <- map (floatPath . toFilePath . sp2fn) `fmap` fixSubPaths fps args - let matchFlags = parseFlags O.matchOne opts + let matchFlags = parseFlags O.matchUpToOne opts withRepository (useCache opts) $ RepoJob $ \repository -> do let readContents = do - okpaths <- filterM HSM.fileExists floatedPaths - forM okpaths $ \f -> (B.concat . BL.toChunks) `fmap` HSM.readFile f + okpaths <- filterM TM.fileExists floatedPaths + forM okpaths $ \f -> (B.concat . BL.toChunks) `fmap` TM.readFile f -- Note: The two calls to execReadContents below are from -- different working directories. This matters despite our -- use of virtualTreeIO. - execReadContents tree = fst `fmap` HSM.virtualTreeIO readContents tree + execReadContents tree = fst `fmap` TM.virtualTreeIO readContents tree files <- if haveNonrangeMatch (repoPatchType repository) matchFlags then withDelayedDir "show.contents" $ \_ -> do -- this call populates our temporary directory, but note that diff --git a/src/Darcs/UI/Commands/ShowDependencies.hs b/src/Darcs/UI/Commands/ShowDependencies.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/UI/Commands/ShowDependencies.hs @@ -0,0 +1,148 @@ +module Darcs.UI.Commands.ShowDependencies + ( showDeps ) +where + +import Control.Arrow ( (***) ) + +import Data.Maybe( fromMaybe ) +import Data.GraphViz +import Data.GraphViz.Algorithms ( transitiveReduction ) +import Data.GraphViz.Attributes.Complete +import Data.Graph.Inductive.Graph ( Graph(..), mkGraph, LNode, UEdge ) +import Data.Graph.Inductive.PatriciaTree ( Gr ) + +import qualified Data.Text.Lazy as T +import qualified Data.ByteString.Char8 as BC ( unpack ) + +import Darcs.Util.Tree ( Tree ) + +import Darcs.Repository ( readRepo, withRepositoryDirectory, RepoJob(..) ) +import Darcs.UI.Flags ( DarcsFlag(..), getRepourl + , useCache, toMatchFlags ) +import Darcs.UI.Options ( PrimDarcsOption, oid, odesc, ocheck, onormalise, defaultFlags ) +import qualified Darcs.UI.Options.All as O +import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, findRepository, withStdOpts ) +import Darcs.UI.Commands.Unrecord ( matchingHead ) + +import Darcs.Util.Text ( formatText ) +import Darcs.Util.Path ( AbsolutePath ) + +import Darcs.Patch ( RepoPatch ) +import Darcs.Patch.Set ( PatchSet(..), newset2FL ) +import Darcs.Patch.Info ( _piName ) +import Darcs.Patch.PatchInfoAnd ( hopefully ) +import Darcs.Patch.Apply( ApplyState ) +import Darcs.Patch.Named ( Named (..), patch2patchinfo ) +import Darcs.Patch.Named.Wrapped ( removeInternalFL ) +import Darcs.Patch.Match ( firstMatch, matchFirstPatchset ) +import Darcs.Patch.Choices ( lpPatch, LabelledPatch, label, getLabelInt ) +import Darcs.Patch.Depends ( SPatchAndDeps, getDeps, findCommonWithThem ) +import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), seal2, Sealed(..) ) +import Darcs.Patch.Witnesses.Ordered ( (:>)(..), (:>)(..), RL(..) + , reverseFL, foldlFL, mapFL_FL ) +import Darcs.Repository.Flags ( Verbosity(..), UseCache(..) ) + +showDepsDescription :: String +showDepsDescription = "Generate the graph of dependencies." + +showDepsHelp :: String +showDepsHelp = formatText 80 + [ unwords [ "The `darcs show dependencies` command is used to create" + , "a graph of the dependencies between patches of the" + , "repository (by default up to last tag)." + ] + , unwords [ "The resulting graph is described in Dot Language, a" + , "general example of use could be:" + ] + , "darcs show dependencies | dot -Tpdf -o FILE.pdf" + ] + +showDepsBasicOpts :: PrimDarcsOption [O.MatchFlag] +showDepsBasicOpts = O.matchSeveralOrLast + +showDepsOpts :: O.DarcsOption + a + ([O.MatchFlag] + -> Maybe O.StdCmdAction + -> Bool + -> Bool + -> Verbosity + -> Bool + -> UseCache + -> Maybe String + -> Bool + -> Maybe String + -> Bool + -> a) +showDepsOpts = showDepsBasicOpts `withStdOpts` oid + +showDeps :: DarcsCommand [DarcsFlag] +showDeps = DarcsCommand + { commandProgramName = "darcs" + , commandName = "dependencies" + , commandHelp = showDepsHelp + , commandDescription = showDepsDescription + , commandExtraArgs = 0 + , commandExtraArgHelp = [] + , commandCommand = depsCmd + , commandPrereq = findRepository + , commandGetArgPossibilities = return [] + , commandArgdefaults = nodefaults + , commandAdvancedOptions = [] + , commandBasicOptions = odesc showDepsBasicOpts + , commandDefaults = defaultFlags showDepsOpts + , commandCheckOptions = ocheck showDepsOpts + , commandParseOptions = onormalise showDepsOpts + } + +type DepsGraph = Gr String () + +depsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () +depsCmd _ opts _ = do + let repodir = fromMaybe "." (getRepourl opts) + withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repo -> do + Sealed2 r <- readRepo repo >>= pruneRepo + let rFl = newset2FL r + deps = getDeps + (removeInternalFL . mapFL_FL hopefully $ rFl) + rFl + dGraph = transitiveReduction $ + graphToDot nodeLabeledParams $ makeGraph deps + putStrLn $ T.unpack $ printDotGraph dGraph + where + nodeLabeledParams :: GraphvizParams n String el () String + nodeLabeledParams = + defaultParams { globalAttributes = + [GraphAttrs {attrs = [RankDir FromLeft]}] + , fmtNode = \(_,l) -> + [ toLabel l + , ImageScale UniformScale + ] + } + pruneRepo r = let matchFlags = toMatchFlags opts in + if firstMatch matchFlags + then case getLastPatches matchFlags r of + Sealed2 ps -> return $ seal2 $ PatchSet NilRL ps + else case matchingHead matchFlags r of + _ :> patches -> return $ seal2 $ PatchSet NilRL $ reverseFL patches + getLastPatches matchFlags ps = + case matchFirstPatchset matchFlags ps of + Sealed p1s -> case findCommonWithThem ps p1s of + _ :> ps' -> seal2 $ reverseFL ps' + +makeGraph :: (RepoPatch p,ApplyState p ~ Tree) => [SPatchAndDeps p] -> DepsGraph +makeGraph = uncurry mkGraph . (id *** concat) . unzip . map mkNodeWithEdges + where + mkNodeWithEdges :: SPatchAndDeps p -> (LNode String, [UEdge]) + mkNodeWithEdges (Sealed2 father, Sealed2 childs) = (mkLNode father,mkUEdges) + where + mkNode :: LabelledPatch (Named p) wX wY -> Int + mkNode = fromInteger . getLabelInt . label + mkUEdge :: [UEdge] -> LabelledPatch (Named p) wX wY -> [UEdge] + mkUEdge les child = (mkNode father, mkNode child,()) : les + mkLabel :: LabelledPatch (Named p) wX wY -> String + mkLabel = formatText 20 . (:[]) . BC.unpack . _piName . patch2patchinfo . lpPatch + mkLNode :: LabelledPatch (Named p) wX wY -> LNode String + mkLNode p = (mkNode p, mkLabel p) + mkUEdges :: [UEdge] + mkUEdges = foldlFL mkUEdge [] childs diff --git a/src/Darcs/UI/Commands/ShowFiles.hs b/src/Darcs/UI/Commands/ShowFiles.hs --- a/src/Darcs/UI/Commands/ShowFiles.hs +++ b/src/Darcs/UI/Commands/ShowFiles.hs @@ -16,11 +16,11 @@ -- Boston, MA 02110-1301, USA. {-# LANGUAGE CPP #-} -module Darcs.UI.Commands.ShowFiles ( showFiles - , manifestCmd, toListManifest -- for alias - , manifest - ) where +module Darcs.UI.Commands.ShowFiles ( showFiles ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^) ) import Darcs.UI.Flags ( DarcsFlag, useCache ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise @@ -29,22 +29,22 @@ import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) import Darcs.Repository ( Repository, withRepository, RepoJob(..), repoPatchType ) -import Darcs.Patch ( RepoPatch ) +import Darcs.Patch ( IsRepoType, RepoPatch ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Repository.State ( readRecorded, readRecordedAndPending ) -import Storage.Hashed.Tree( Tree, TreeItem(..), list, expand ) +import Darcs.Util.Tree( Tree, TreeItem(..), list, expand ) +import Darcs.Util.Tree.Plain( readPlainTree ) import Darcs.Util.Path( anchorPath, AbsolutePath ) -import Storage.Hashed.Plain( readPlainTree ) import System.FilePath ( splitDirectories ) import Data.List( isPrefixOf ) import Darcs.Patch.Match ( haveNonrangeMatch ) import Darcs.Repository.Match ( getNonrangeMatch ) -import Darcs.Repository.Lock ( withDelayedDir ) +import Darcs.Util.Lock ( withDelayedDir ) showFilesDescription :: String -showFilesDescription = "Show version-controlled files in the working copy." +showFilesDescription = "Show version-controlled files in the working tree." showFilesHelp :: String showFilesHelp = @@ -57,9 +57,8 @@ "default, pending files (and directories) are listed; the `--no-pending`\n" ++ "option prevents this.\n" ++ "\n" ++ - "By default `darcs show files` lists both files and directories, but\n" ++ - "the alias `darcs show manifest` only lists files. The `--files`,\n" ++ - "`--directories`, `--no-files` and `--no-directories` modify this behaviour.\n" ++ + "By default `darcs show files` lists both files and directories, but the\n" ++ + "`--no-files` and `--no-directories` flags modify this behaviour.\n" ++ "\n" ++ "By default entries are one-per-line (i.e. newline separated). This\n" ++ "can cause problems if the files themselves contain newlines or other\n" ++ @@ -78,7 +77,7 @@ ^ O.directories ^ O.pending ^ O.nullFlag - ^ O.matchOne + ^ O.matchUpToOne ^ O.workingRepoDir showFilesOpts :: DarcsOption a @@ -119,9 +118,8 @@ commandCheckOptions = ocheck showFilesOpts, commandParseOptions = onormalise showFilesOpts } -toListFiles, toListManifest :: [DarcsFlag] -> Tree m -> [FilePath] +toListFiles :: [DarcsFlag] -> Tree m -> [FilePath] toListFiles opts = filesDirs (parseFlags O.files opts) (parseFlags O.directories opts) -toListManifest opts = filesDirs (parseFlags O.files opts) (parseFlags O.directories opts) filesDirs :: Bool -> Bool -> Tree m -> [FilePath] filesDirs False False _ = [] @@ -129,9 +127,6 @@ filesDirs True False t = [ anchorPath "." p | (p, File _) <- list t ] filesDirs True True t = "." : map (anchorPath "." . fst) (list t) -manifest :: [DarcsFlag] -> [String] -> IO [FilePath] -manifest = manifestHelper toListFiles - manifestCmd :: ([DarcsFlag] -> Tree IO -> [FilePath]) -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () manifestCmd to_list _ opts argList = @@ -142,28 +137,33 @@ manifestHelper :: ([DarcsFlag] -> Tree IO -> [FilePath]) -> [DarcsFlag] -> [String] -> IO [FilePath] manifestHelper to_list opts argList = do - list' <- to_list opts `fmap` withRepository (useCache opts) (RepoJob myslurp) + list' <- to_list opts `fmap` withRepository (useCache opts) (RepoJob slurp) case argList of [] -> return list' prefixes -> return (onlysubdirs prefixes list') - where myslurp :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wR -> IO (Tree IO) - myslurp r = do let fRevisioned = haveNonrangeMatch (repoPatchType r) (parseFlags O.matchOne opts) - fPending = parseFlags O.pending opts - -- this covers all 4 possibilities - expand =<< case (fRevisioned,fPending) of - (True,False) -> slurpRevision opts r - (True,True) -> error "can't mix revisioned and pending flags" - (False,False) -> readRecorded r - (False,True) -> readRecordedAndPending r -- pending is default - isParentDir a' b' = - let a = splitDirectories a' - b = splitDirectories b' - in (a `isPrefixOf` b) || (("." : a) `isPrefixOf` b) - onlysubdirs dirs = filter (\p -> any (`isParentDir` p) dirs) + where + matchFlags = parseFlags O.matchUpToOne opts + slurp :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wR -> IO (Tree IO) + slurp r = do + let fUpto = haveNonrangeMatch (repoPatchType r) matchFlags + fPending = parseFlags O.pending opts + -- this covers all 4 possibilities + case (fUpto,fPending) of + (True, False) -> slurpUpto matchFlags r + (True, True) -> error "can't mix match and pending flags" + (False,False) -> expand =<< readRecorded r + (False,True) -> expand =<< readRecordedAndPending r -- pending is default + isParentDir a' b' = + let a = splitDirectories a' + b = splitDirectories b' + in (a `isPrefixOf` b) || (("." : a) `isPrefixOf` b) + onlysubdirs dirs = filter (\p -> any (`isParentDir` p) dirs) -slurpRevision :: (RepoPatch p, ApplyState p ~ Tree) - => [DarcsFlag] -> Repository p wR wU wR -> IO (Tree IO) -slurpRevision opts r = withDelayedDir "revisioned.showfiles" $ \_ -> do - getNonrangeMatch r (parseFlags O.matchOne opts) +slurpUpto :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => [O.MatchFlag] -> Repository rt p wR wU wR -> IO (Tree IO) +slurpUpto matchFlags r = withDelayedDir "show.files" $ \_ -> do + getNonrangeMatch r matchFlags + -- note: it is important that we expand the tree from inside the + -- withDelayedDir action, else it has no effect. expand =<< readPlainTree "." - diff --git a/src/Darcs/UI/Commands/ShowIndex.hs b/src/Darcs/UI/Commands/ShowIndex.hs --- a/src/Darcs/UI/Commands/ShowIndex.hs +++ b/src/Darcs/UI/Commands/ShowIndex.hs @@ -26,21 +26,21 @@ , showPristineCmd -- for alias ) where -import Control.Applicative ( (<$>) ) +import Prelude () +import Darcs.Prelude + import Control.Monad ( (>=>) ) import Darcs.UI.Flags ( DarcsFlag(NullFlag), useCache ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) -import Prelude hiding ( (^) ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O import Darcs.Repository ( withRepository, RepoJob(..), readIndex ) import Darcs.Repository.State ( readRecorded ) -import Storage.Hashed( floatPath ) -import Storage.Hashed.Hash( encodeBase16, Hash( NoHash ) ) -import Storage.Hashed.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) ) -import Storage.Hashed.Index( updateIndex, listFileIDs ) -import Darcs.Util.Path( anchorPath, AbsolutePath ) +import Darcs.Util.Hash( encodeBase16, Hash( NoHash ) ) +import Darcs.Util.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) ) +import Darcs.Util.Index( updateIndex, listFileIDs ) +import Darcs.Util.Path( anchorPath, AbsolutePath, floatPath ) import System.Posix.Types ( FileID ) diff --git a/src/Darcs/UI/Commands/ShowPatchIndex.hs b/src/Darcs/UI/Commands/ShowPatchIndex.hs --- a/src/Darcs/UI/Commands/ShowPatchIndex.hs +++ b/src/Darcs/UI/Commands/ShowPatchIndex.hs @@ -1,6 +1,10 @@ -module Darcs.UI.Commands.ShowPatchIndex ( showPatchIndexFiles, showPatchIndexAll, showPatchIndexStatus, patchIndexTest ) where +module Darcs.UI.Commands.ShowPatchIndex ( showPatchIndex ) where + +import Prelude () +import Darcs.Prelude + import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) -import Darcs.UI.Flags ( DarcsFlag, useCache ) +import Darcs.UI.Flags ( DarcsFlag(Verbose), useCache ) import Prelude hiding ( (^) ) import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags ) import qualified Darcs.UI.Options.All as O @@ -32,73 +36,17 @@ -> a) showPatchIndexOpts = showPatchIndexBasicOpts `withStdOpts` oid -showPatchIndexAll :: DarcsCommand [DarcsFlag] -showPatchIndexAll = DarcsCommand { - commandProgramName = "darcs", - commandName = "patch-index-all", - commandDescription = "Dump complete content of patch index.", - commandHelp = - "The `darcs show patch-index all' command lists all information in the patch index", - commandExtraArgs = 0, - commandExtraArgHelp = [], - commandCommand = showPatchIndexAllCmd, - commandPrereq = amInHashedRepository, - commandGetArgPossibilities = return [], - commandArgdefaults = nodefaults, - commandAdvancedOptions = [], - commandBasicOptions = odesc showPatchIndexBasicOpts, - commandDefaults = defaultFlags showPatchIndexOpts, - commandCheckOptions = ocheck showPatchIndexOpts, - commandParseOptions = onormalise showPatchIndexOpts } - -showPatchIndexFiles :: DarcsCommand [DarcsFlag] -showPatchIndexFiles = DarcsCommand { - commandProgramName = "darcs", - commandName = "patch-index-files", - commandDescription = "Dump current files registered in patch index.", - commandHelp = - "The `darcs show patch-index files' command lists all current files registered in the patch index", - commandExtraArgs = 0, - commandExtraArgHelp = [], - commandCommand = showPatchIndexFilesCmd, - commandPrereq = amInHashedRepository, - commandGetArgPossibilities = return [], - commandArgdefaults = nodefaults, - commandAdvancedOptions = [], - commandBasicOptions = odesc showPatchIndexBasicOpts, - commandDefaults = defaultFlags showPatchIndexOpts, - commandCheckOptions = ocheck showPatchIndexOpts, - commandParseOptions = onormalise showPatchIndexOpts } - -showPatchIndexStatus :: DarcsCommand [DarcsFlag] -showPatchIndexStatus = DarcsCommand { - commandProgramName = "darcs", - commandName = "patch-index-status", - commandDescription = " Report patch-index status", - commandHelp = - "The `darcs show patch-index-status' reports if the patch index is in sync, out of sync, or does not exist", - commandExtraArgs = 0, - commandExtraArgHelp = [], - commandCommand = showPatchIndexStatus', - commandPrereq = amInHashedRepository, - commandGetArgPossibilities = return [], - commandArgdefaults = nodefaults, - commandAdvancedOptions = [], - commandBasicOptions = odesc showPatchIndexBasicOpts, - commandDefaults = defaultFlags showPatchIndexOpts, - commandCheckOptions = ocheck showPatchIndexOpts, - commandParseOptions = onormalise showPatchIndexOpts } - -patchIndexTest :: DarcsCommand [DarcsFlag] -patchIndexTest = DarcsCommand { +showPatchIndex :: DarcsCommand [DarcsFlag] +showPatchIndex = DarcsCommand { commandProgramName = "darcs", - commandName = "patch-index-test", - commandDescription = "Test patch-index", + commandName = "patch-index", + commandDescription = "Check integrity of patch index", commandHelp = - "The `darcs show patch-index-test' tests patch index", + "When given the `--verbose` flag, the command dumps the complete content\n" + ++ "of the patch index and checks its integrity.", commandExtraArgs = 0, commandExtraArgHelp = [], - commandCommand = piTest', + commandCommand = showPatchIndexCmd, commandPrereq = amInHashedRepository, commandGetArgPossibilities = return [], commandArgdefaults = nodefaults, @@ -108,25 +56,18 @@ commandCheckOptions = ocheck showPatchIndexOpts, commandParseOptions = onormalise showPatchIndexOpts } -showPatchIndexAllCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -showPatchIndexAllCmd _ opts _ = - withRepository (useCache opts) $ RepoJob $ \(Repo repodir _ _ _) -> - dumpPatchIndex repodir - -showPatchIndexFilesCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -showPatchIndexFilesCmd _ opts _ = withRepository (useCache opts) $ RepoJob $ \(Repo repodir _ _ _) -> - dumpPatchIndexFiles repodir - -showPatchIndexStatus' :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -showPatchIndexStatus' _ opts _ = withRepository (useCache opts) $ RepoJob $ \(repo@(Repo repodir _ _ _)) -> do - ex <- doesPatchIndexExist repodir - if ex - then do +showPatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () +showPatchIndexCmd _ opts _ + | Verbose `elem` opts = do + withRepository (useCache opts) $ RepoJob $ \repo@(Repo repodir _ _ _) -> + dumpPatchIndex repodir >> piTest repo + | otherwise = + withRepository (useCache opts) $ RepoJob $ \(repo@(Repo repodir _ _ _)) -> do + ex <- doesPatchIndexExist repodir + if ex then do sy <- isPatchIndexInSync repo if sy then putStrLn "Patch Index is in sync with repo." else putStrLn "Patch Index is outdated. Run darcs optimize enable-patch-index" - else putStrLn "Patch Index is not yet created. Run darcs optimize enable-patch-index" + else putStrLn "Patch Index is not yet created. Run darcs optimize enable-patch-index" -piTest' :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () -piTest' _ opts _ = withRepository (useCache opts) $ RepoJob piTest diff --git a/src/Darcs/UI/Commands/ShowRepo.hs b/src/Darcs/UI/Commands/ShowRepo.hs --- a/src/Darcs/UI/Commands/ShowRepo.hs +++ b/src/Darcs/UI/Commands/ShowRepo.hs @@ -18,6 +18,9 @@ {-# LANGUAGE CPP #-} module Darcs.UI.Commands.ShowRepo ( showRepo ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^) ) import Data.Char ( toLower, isSpace ) import Data.List ( intercalate ) @@ -29,19 +32,18 @@ import qualified Darcs.UI.Options.All as O import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository ) import Darcs.Repository ( withRepository, RepoJob(..), readRepo ) -import Darcs.Repository.Internal ( Repository(..) ) +import Darcs.Repository.Internal ( Repository(..), repoXor ) import Darcs.Repository.InternalTypes ( Pristine(..) ) import Darcs.Repository.Cache ( Cache(..) ) import Darcs.Repository.Format ( RepoFormat(..) ) import Darcs.Repository.Prefs ( getPreflist ) import Darcs.Repository.Motd ( getMotd ) -import Darcs.Repository.State ( repoXor ) -import Darcs.Patch ( RepoPatch ) +import Darcs.Patch ( IsRepoType, RepoPatch ) import Darcs.Patch.Set ( newset2RL ) import Darcs.Patch.Witnesses.Ordered ( lengthRL ) import qualified Data.ByteString.Char8 as BC (unpack) import Darcs.Patch.Apply( ApplyState ) -import Storage.Hashed.Tree ( Tree ) +import Darcs.Util.Tree ( Tree ) showRepoHelp :: String showRepoHelp = @@ -53,6 +55,10 @@ "By default, the number of patches is shown. If this data isn't\n" ++ "needed, use `--no-files` to accelerate this command from O(n) to O(1).\n" ++ "\n" ++ + "The 'Weak Hash' identifies the set of patches of a repository independently\n" ++ + "of ordering. It can be used to easily compare two repositories of a same\n" ++ + "project. It is not cryptographically secure.\n" ++ + "\n" ++ "By default, output is in a human-readable format. The `--xml-output`\n" ++ "option can be used to generate output for machine postprocessing.\n" @@ -131,8 +137,8 @@ -- sub-displays. The `out' argument is one of the above operations to -- output a labelled text string or an XML tag and contained value. -actuallyShowRepo :: (RepoPatch p, ApplyState p ~ Tree) - => PutInfo -> Repository p wR wU wR -> [DarcsFlag] -> IO () +actuallyShowRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => PutInfo -> Repository rt p wR wU wR -> [DarcsFlag] -> IO () actuallyShowRepo out r@(Repo loc rf pris cs) opts = do when (XMLOutput `elem` opts) (putStr "\n") when (Verbose `elem` opts) (out "Show" $ show r) @@ -145,8 +151,8 @@ showRepoMOTD out r when (XMLOutput `elem` opts) (putStr "\n") -showXor :: (RepoPatch p, ApplyState p ~ Tree) - => PutInfo -> Repository p wR wU wR -> IO () +showXor :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => PutInfo -> Repository rt p wR wU wR -> IO () showXor out repo = do theXor <- repoXor repo out "Weak Hash" (show theXor) @@ -172,11 +178,11 @@ getPreflist "defaultrepo" >>= out "Default Remote" . unlines where prefOut = uncurry out . (\(p,v) -> (p++" Pref", dropWhile isSpace v)) . break isSpace -showRepoMOTD :: RepoPatch p => PutInfo -> Repository p wR wU wR -> IO () +showRepoMOTD :: RepoPatch p => PutInfo -> Repository rt p wR wU wR -> IO () showRepoMOTD out (Repo loc _ _ _) = getMotd loc >>= out "MOTD" . BC.unpack -- Support routines to provide information used by the PutInfo operations above. -numPatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wR -> IO Int +numPatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wR -> IO Int numPatches r = (lengthRL . newset2RL) `liftM` readRepo r diff --git a/src/Darcs/UI/Commands/ShowTags.hs b/src/Darcs/UI/Commands/ShowTags.hs --- a/src/Darcs/UI/Commands/ShowTags.hs +++ b/src/Darcs/UI/Commands/ShowTags.hs @@ -19,12 +19,14 @@ ( showTags ) where +import Prelude () +import Darcs.Prelude + import Control.Monad ( unless, join ) import Data.Maybe ( fromMaybe ) import System.IO ( stderr, hPutStrLn ) import Darcs.Patch.Set ( PatchSet(..) ) -import Darcs.Patch.MaybeInternal ( MaybeInternal ) import Darcs.Repository ( readRepo, withRepositoryDirectory, RepoJob(..) ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository ) import Darcs.UI.Commands.Tag ( getTags ) @@ -91,7 +93,7 @@ withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repo -> readRepo repo >>= printTags where - printTags :: MaybeInternal p => PatchSet p wW wZ -> IO () + printTags :: PatchSet rt p wW wZ -> IO () printTags = join . fmap (sequence_ . map process) . getTags process :: String -> IO () process t = normalize t t False >>= putStrLn diff --git a/src/Darcs/UI/Commands/Tag.hs b/src/Darcs/UI/Commands/Tag.hs --- a/src/Darcs/UI/Commands/Tag.hs +++ b/src/Darcs/UI/Commands/Tag.hs @@ -17,48 +17,46 @@ module Darcs.UI.Commands.Tag ( tag, getTags ) where -import Prelude hiding ( (^) ) -import Control.Applicative ( (<$>) ) +import Prelude () +import Darcs.Prelude + import Control.Monad ( when ) import Data.Maybe ( catMaybes ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) -import Darcs.UI.Commands.Record ( getLog ) import Darcs.UI.Flags ( DarcsFlag(AskDeps), getDate, compression, verbosity, useCache, umask, getAuthor - , hasAuthor, diffAlgorithm ) + , hasAuthor ) import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import qualified Darcs.UI.Options.All as O +import Darcs.UI.PatchHeader ( getLog ) import Darcs.Patch.PatchInfoAnd ( n2pia, hopefully ) import Darcs.Repository ( withRepoLock, Repository, RepoJob(..), readRepo, tentativelyAddPatch, finalizeRepositoryChanges, ) import Darcs.Patch - ( infopatch, adddeps, Patchy, PrimPatch, PrimOf - , RepoPatch + ( Patchy, PrimPatch, PrimOf + , IsRepoType, RepoPatch ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Info ( patchinfo, piTag ) import Darcs.Patch.Depends ( getUncovered ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info ) -import Darcs.Patch.MaybeInternal ( MaybeInternal(patchInternalChecker), InternalChecker(..) ) -import Darcs.Patch.Named ( patchcontents ) -import Darcs.Patch.Set ( PatchSet(..), emptyPatchSet, appendPSFL, newset2FL ) +import Darcs.Patch.Named.Wrapped ( infopatch, adddeps, runInternalChecker, namedInternalChecker ) +import Darcs.Patch.Set ( PatchSet(..), emptyPatchSet, appendPSFL, newset2FL, patchSetfMap ) import Darcs.Patch.Witnesses.Ordered ( FL(..), filterOutRLRL, (:>)(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal ) import Darcs.UI.SelectChanges - ( selectChanges - , WhichChanges(..) + ( WhichChanges(..) , selectionContext , runSelection , PatchSelectionContext(allowSkipAll) ) import qualified Darcs.UI.SelectChanges as S -import Darcs.Repository.Util ( patchSetfMap ) import Darcs.Repository.Flags ( UpdateWorking(..), DryRun(NoDryRun) ) import Darcs.Util.Path ( AbsolutePath ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) import System.IO ( hPutStr, stderr ) @@ -153,15 +151,15 @@ , commandParseOptions = onormalise tagOpts } -filterNonInternal :: MaybeInternal p => PatchSet p wX wY -> PatchSet p wX wY +filterNonInternal :: IsRepoType rt => PatchSet rt p wX wY -> PatchSet rt p wX wY filterNonInternal = - case patchInternalChecker of + case namedInternalChecker of Nothing -> id - Just f -> \(PatchSet ps ts) -> PatchSet (filterOutRLRL (isInternal f . patchcontents . hopefully) ps) ts + Just f -> \(PatchSet ts ps) -> PatchSet ts (filterOutRLRL (runInternalChecker f . hopefully) ps) tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () tagCmd _ opts args = - withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(repository :: Repository p wR wU wR) -> do + withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do date <- getDate (hasPipe opts) the_author <- getAuthor (hasAuthor opts) (hasPipe opts) patches <- readRepo repository @@ -198,7 +196,7 @@ " already exists." return ("TAG " ++ name, comment) -getTags :: MaybeInternal p => PatchSet p wW wR -> IO [String] +getTags :: PatchSet rt p wW wR -> IO [String] getTags ps = catMaybes `fmap` patchSetfMap (return . piTag . info) ps -- This may be useful for developers, but users don't care about @@ -213,21 +211,20 @@ -- since the last tag, plus that tag itself. askAboutTagDepends - :: forall p wX wY . (RepoPatch p, ApplyState p ~ Tree) + :: forall rt p wX wY . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] - -> FL (PatchInfoAnd p) wX wY - -> IO (Sealed (FL (PatchInfoAnd p) wX)) + -> FL (PatchInfoAnd rt p) wX wY + -> IO (Sealed (FL (PatchInfoAnd rt p) wX)) askAboutTagDepends flags ps = do let opts = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = [] - , S.diffAlgorithm = diffAlgorithm flags , S.interactive = True , S.selectDeps = O.PromptDeps , S.summary = O.NoSummary , S.withContext = O.NoContext } - (deps:>_) <- runSelection (selectChanges ps) $ + (deps:>_) <- runSelection ps $ ((selectionContext FirstReversed "depend on" opts Nothing Nothing) { allowSkipAll = False }) return $ Sealed deps diff --git a/src/Darcs/UI/Commands/Test.hs b/src/Darcs/UI/Commands/Test.hs --- a/src/Darcs/UI/Commands/Test.hs +++ b/src/Darcs/UI/Commands/Test.hs @@ -20,7 +20,8 @@ test ) where -import Prelude hiding ( (^), init, catch ) +import Prelude () +import Darcs.Prelude hiding ( init ) import Control.Exception ( catch, IOException ) import Control.Monad( when ) @@ -29,7 +30,7 @@ import System.Exit ( ExitCode(..), exitWith ) import System.IO ( hFlush, stdout ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts @@ -56,7 +57,7 @@ ) import Darcs.Patch.Witnesses.Ordered ( RL(..) - , (:<)(..) + , (:>)(..) , (+<+) , reverseRL , splitAtRL @@ -77,11 +78,11 @@ , ShowPatch ) import Darcs.Patch ( RepoPatch - , Named - , description , apply + , description , invert ) +import Darcs.Patch.Named.Wrapped ( WrappedNamed ) import Darcs.Patch.Set ( newset2RL ) import Darcs.Util.Printer ( putDocLn , text @@ -89,14 +90,14 @@ import Darcs.Util.Path ( AbsolutePath ) import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault ) import Darcs.Repository.Test ( getTest ) -import Darcs.Repository.Lock +import Darcs.Util.Lock ( withTempDir , withPermDir ) testDescription :: String -testDescription = "Run regression test." +testDescription = "Run tests and search for the patch that introduced a bug." testHelp :: String testHelp = @@ -175,12 +176,12 @@ } -- | Functions defining a strategy for executing a test -type Strategy = forall p wX wY - . (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree) +type Strategy = forall rt p wX wY + . (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree) => [DarcsFlag] -> IO ExitCode -- ^ test command -> ExitCode - -> RL (Named p) wX wY + -> RL (WrappedNamed rt p) wX wY -> IO () testCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () @@ -225,7 +226,7 @@ -- | linear search (with --linear) trackLinear :: Strategy trackLinear _ _ ExitSuccess _ = putStrLn "Success!" -trackLinear opts testCmd (ExitFailure _) (p:<:ps) = do +trackLinear opts testCmd (ExitFailure _) (ps:<:p) = do let ip = invert p safeApply ip when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches ip @@ -244,11 +245,11 @@ trackBackoff opts testCmd (ExitFailure _) ps = trackNextBackoff opts testCmd 4 ps -trackNextBackoff :: (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree) +trackNextBackoff :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree) => [DarcsFlag] -> IO ExitCode -> Int -- ^ number of patches to skip - -> RL (Named p) wY wZ -- ^ patches not yet skipped + -> RL (WrappedNamed rt p) wY wZ -- ^ patches not yet skipped -> IO () trackNextBackoff _ _ _ NilRL = putStrLn "Noone passed the test!" trackNextBackoff opts testCmd n ahead @@ -257,7 +258,7 @@ putStrLn $ "Skipping " ++ show n ++ " patches..." hFlush stdout case splitAtRL n ahead of - ( skipped' :< ahead' ) -> do + ( ahead' :> skipped' ) -> do unapplyRL skipped' when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches skipped' testResult <- testCmd @@ -276,10 +277,10 @@ trackBisect opts testCmd (ExitFailure _) ps = initialBisect opts testCmd ps -initialBisect :: (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree) +initialBisect :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree) => [DarcsFlag] -> IO ExitCode - -> RL (Named p) wX wY + -> RL (WrappedNamed rt p) wX wY -> IO () initialBisect opts testCmd ps = trackNextBisect opts currProg testCmd BisectRight (patchTreeFromRL ps) @@ -300,22 +301,22 @@ -- | Create Bisect PatchTree from the RL patchTreeFromRL :: (Patchy p) => RL p wX wY -> PatchTree p wX wY -patchTreeFromRL (l :<: NilRL) = Leaf l +patchTreeFromRL (NilRL :<: l) = Leaf l patchTreeFromRL xs = case splitAtRL (lengthRL xs `div` 2) xs of - (l :< r) -> Fork (patchTreeFromRL l) (patchTreeFromRL r) + (r :> l) -> Fork (patchTreeFromRL l) (patchTreeFromRL r) -- | Convert PatchTree back to RL patchTree2RL :: (Patchy p) => PatchTree p wX wY -> RL p wX wY -patchTree2RL (Leaf p) = p :<: NilRL -patchTree2RL (Fork l r) = patchTree2RL l +<+ patchTree2RL r +patchTree2RL (Leaf p) = NilRL :<: p +patchTree2RL (Fork l r) = patchTree2RL r +<+ patchTree2RL l -- | Iterate the Patch Tree -trackNextBisect :: (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree) +trackNextBisect :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree) => [DarcsFlag] -> BisectState -> IO ExitCode -- ^ test command -> BisectDir - -> PatchTree (Named p) wX wY + -> PatchTree (WrappedNamed rt p) wX wY -> IO () trackNextBisect opts (dnow, dtotal) testCmd dir (Fork l r) = do putStr $ "Trying " ++ show dnow ++ "/" ++ show dtotal ++ " sequences...\n" @@ -335,7 +336,7 @@ jumpHalfOnRight :: (IsHunk p, Conflict p, PatchListFormat p, ShowPatch p, PatchInspect p, - Patchy p, ApplyMonad DefaultIO (ApplyState p)) + Patchy p, ApplyMonad (ApplyState p) DefaultIO) => [DarcsFlag] -> PatchTree p wX wY -> IO () jumpHalfOnRight opts l = do unapplyRL ps when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches ps @@ -343,21 +344,21 @@ jumpHalfOnLeft :: (IsHunk p, Conflict p, PatchListFormat p, ShowPatch p, PatchInspect p, - Patchy p, ApplyMonad DefaultIO (ApplyState p)) + Patchy p, ApplyMonad (ApplyState p) DefaultIO) => [DarcsFlag] -> PatchTree p wX wY -> IO () jumpHalfOnLeft opts r = do applyRL p when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches p where p = patchTree2RL r -applyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad DefaultIO (ApplyState p)) +applyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad (ApplyState p) DefaultIO) => RL p wX wY -> IO () applyRL patches = sequence_ (mapFL safeApply (reverseRL patches)) -unapplyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad DefaultIO (ApplyState p)) +unapplyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad (ApplyState p) DefaultIO) => RL p wX wY -> IO () unapplyRL patches = sequence_ (mapRL (safeApply . invert) patches) -safeApply :: (Invert p, ShowPatch p, Apply p, ApplyMonad DefaultIO (ApplyState p)) +safeApply :: (Invert p, ShowPatch p, Apply p, ApplyMonad (ApplyState p) DefaultIO) => p wX wY -> IO () safeApply p = runDefault (apply p) `catch` \(msg :: IOException) -> fail $ "Bad patch:\n" ++ show msg diff --git a/src/Darcs/UI/Commands/TransferMode.hs b/src/Darcs/UI/Commands/TransferMode.hs --- a/src/Darcs/UI/Commands/TransferMode.hs +++ b/src/Darcs/UI/Commands/TransferMode.hs @@ -15,12 +15,12 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-} - -- The pragma above is only for pattern guards. module Darcs.UI.Commands.TransferMode ( transferMode ) where -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude + import Control.Exception ( catch ) import System.IO ( stdout, hFlush ) @@ -33,6 +33,7 @@ import Darcs.Util.Progress ( setProgressMode ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Path ( AbsolutePath ) +import Darcs.Util.Ssh ( transferModeHeader ) import qualified Data.ByteString as B (hPut, readFile, length, ByteString) @@ -90,7 +91,7 @@ transferModeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () transferModeCmd _ _ _ = do setProgressMode False - putStrLn "Hello user, I am darcs transfer mode" + putStrLn transferModeHeader hFlush stdout withCurrentDirectory darcsdir transfer @@ -109,4 +110,3 @@ readfile :: String -> IO (Either String B.ByteString) readfile fn = (Right `fmap` B.readFile fn) `catch` (return . Left . prettyException) - diff --git a/src/Darcs/UI/Commands/Unrecord.hs b/src/Darcs/UI/Commands/Unrecord.hs --- a/src/Darcs/UI/Commands/Unrecord.hs +++ b/src/Darcs/UI/Commands/Unrecord.hs @@ -25,16 +25,19 @@ , matchingHead ) where -import Prelude hiding ( (^), catch ) +import Prelude () +import Darcs.Prelude +import Prelude hiding ( (^) ) + import Control.Exception ( catch, IOException ) -import Control.Monad ( when ) +import Control.Monad ( when, unless ) import Data.Maybe( isJust, mapMaybe ) import Data.List ( intercalate ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) import System.Exit ( exitSuccess ) -import Darcs.Patch ( RepoPatch, invert, commute, effect ) +import Darcs.Patch ( IsRepoType, RepoPatch, invert, commute, effect ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Bundle ( makeBundleN, contextPatches, minContext ) import Darcs.Patch.Depends ( findCommonWithThem, newsetUnion ) @@ -53,7 +56,7 @@ invalidateIndex, unrecordedChanges, identifyRepositoryFor ) import Darcs.Repository.Flags( UseIndex(..), ScanKnown(..), UpdateWorking(..), DryRun(NoDryRun) ) -import Darcs.Repository.Lock( writeDocBinFile ) +import Darcs.Util.Lock( writeDocBinFile ) import Darcs.Repository.Prefs ( getDefaultRepoPath ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias , putVerbose, printDryRunMessageAndExit @@ -67,21 +70,21 @@ import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags ) import Darcs.UI.Options.All ( notInRemoteFlagName ) import qualified Darcs.UI.Options.All as O -import Darcs.UI.SelectChanges ( selectChanges, WhichChanges(..), +import Darcs.UI.SelectChanges ( WhichChanges(..), selectionContext, runSelection ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Util.English ( presentParticiple ) -import Darcs.Util.Printer ( text, putDoc ) +import Darcs.Util.Printer ( text, putDoc, (<>), (<+>) ) import Darcs.Util.Progress ( debugMessage ) unrecordDescription :: String unrecordDescription = - "Remove recorded patches without changing the working copy." + "Remove recorded patches without changing the working tree." unrecordHelp :: String unrecordHelp = unlines [ "Unrecord does the opposite of record: it deletes patches from" - , "the repository, without changing the working copy." + , "the repository, without changing the working tree." , "Deleting patches from the repository makes active changes again" , "which you may record or revert later." , "Beware that you should not use this command if there is a" @@ -154,9 +157,9 @@ else matchingHead matchFlags allpatches let direction = if doReverse opts then Last else LastReversed context = selectionContext direction "unrecord" (patchSelOpts opts) Nothing Nothing - (_ :> to_unrecord) <- runSelection (selectChanges patches) context + (_ :> to_unrecord) <- runSelection patches context when (nullFL to_unrecord) $ do - putStrLn "No patches selected!" + putInfo opts "No patches selected!" exitSuccess putVerbose opts $ text "About to write out (potentially) modified patches..." @@ -165,10 +168,10 @@ _ <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking to_unrecord finalizeRepositoryChanges repository YesUpdateWorking (compression opts) - putStrLn "Finished unrecording." + putInfo opts "Finished unrecording." -getLastPatches :: RepoPatch p => [MatchFlag] -> PatchSet p Origin wR - -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wR +getLastPatches :: (IsRepoType rt, RepoPatch p) => [MatchFlag] -> PatchSet rt p Origin wR + -> (PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin wR getLastPatches matchFlags ps = case matchFirstPatchset matchFlags ps of Sealed p1s -> findCommonWithThem ps p1s @@ -179,7 +182,7 @@ unpullHelp :: String unpullHelp = unlines [ "Unpull completely removes recorded patches from your local repository." - , "The changes will be undone in your working copy and the patches" + , "The changes will be undone in your working tree and the patches" , "will not be shown in your changes list anymore. Beware that if the" , "patches are not still present in another repository you will lose" , "precious code by unpulling!" @@ -201,12 +204,12 @@ obliterateDescription :: String obliterateDescription = - "Delete selected patches from the repository. (UNSAFE!)" + "Delete selected patches from the repository." obliterateHelp :: String obliterateHelp = unlines [ "Obliterate completely removes recorded patches from your local" - , "repository. The changes will be undone in your working copy and the" + , "repository. The changes will be undone in your working tree and the" , "patches will not be shown in your changes list anymore. Beware that" , "you can lose precious code by obliterating!" , "" @@ -312,6 +315,7 @@ -> IO () genericObliterateCmd cmdname _ opts _ = let cacheOpt = useCache opts + verbOpt = verbosity opts in withRepoLock (dryRun opts) cacheOpt YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do -- FIXME we may need to honour --ignore-times here, although this @@ -331,15 +335,15 @@ else matchingHead matchFlags allpatches nirs -> do (Sealed thems) <- - getNotInRemotePatches cacheOpt repository nirs + getNotInRemotePatches verbOpt cacheOpt repository nirs return $ findCommonWithThem allpatches thems let direction = if doReverse opts then Last else LastReversed context = selectionContext direction cmdname (patchSelOpts opts) Nothing Nothing (kept :> removed) <- - runSelection (selectChanges removal_candidates) context + runSelection removal_candidates context when (nullFL removed) $ do - putStrLn "No patches selected!" + putInfo opts "No patches selected!" exitSuccess case commute (effect removed :> pend) of Nothing -> fail $ "Can't " ++ cmdname @@ -347,7 +351,7 @@ ++ "unrecorded change." Just (_ :> p_after_pending) -> do printDryRunMessageAndExit "obliterate" - (verbosity opts) + verbOpt (hasSummary O.NoSummary opts) (dryRun opts) (hasXmlOutput opts) @@ -364,19 +368,21 @@ finalizeRepositoryChanges repository YesUpdateWorking (compression opts) debugMessage "Applying patches to working directory..." - _ <- applyToWorking repository (verbosity opts) + _ <- applyToWorking repository verbOpt (invert p_after_pending) `catch` \(e :: IOException) -> fail $ "Couldn't undo patch in working dir.\n" ++ show e - putStrLn $ "Finished " ++ presentParticiple cmdname ++ "." + putInfo opts $ "Finished" <+> text (presentParticiple cmdname) <> "." -- | Get the union of the set of patches in each specified location -getNotInRemotePatches :: (RepoPatch p, ApplyState p ~ Tree) => O.UseCache - -> Repository p wX wU wT -> [NotInRemoteLocation] - -> IO (SealedPatchSet p Origin) -getNotInRemotePatches cacheOpt repository nirs = do - putStrLn $ "Determining patches not in" ++ pluralExtra ++ ":\n" ++ names +getNotInRemotePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => O.Verbosity -> O.UseCache + -> Repository rt p wX wU wT -> [NotInRemoteLocation] + -> IO (SealedPatchSet rt p Origin) +getNotInRemotePatches verbOpt cacheOpt repository nirs = do + unless (verbOpt == O.Quiet) $ + putStrLn $ "Determining patches not in" ++ pluralExtra ++ ":\n" ++ names nirsPaths <- mapM getNotInRemotePath nirs newsetUnion `fmap` mapM readNir nirsPaths where @@ -401,23 +407,25 @@ -- | matchingHead returns the repository up to some tag. The tag t is the last -- tag such that there is a patch after t that is matched by the user's query. -matchingHead :: forall p wR. RepoPatch p => [MatchFlag] -> PatchSet p Origin wR - -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wR +matchingHead :: forall rt p wR + . (IsRepoType rt, RepoPatch p) + => [MatchFlag] -> PatchSet rt p Origin wR + -> (PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin wR matchingHead matchFlags set = case mh set of (start :> patches) -> start :> reverseRL patches where - mh :: forall wX . PatchSet p Origin wX - -> (PatchSet p :> RL (PatchInfoAnd p)) Origin wX - mh s@(PatchSet x _) + mh :: forall wX . PatchSet rt p Origin wX + -> (PatchSet rt p :> RL (PatchInfoAnd rt p)) Origin wX + mh s@(PatchSet _ x) | or (mapRL (matchAPatchread matchFlags) x) = contextPatches s - mh (PatchSet x (Tagged t _ ps :<: ts)) = - case mh (PatchSet (t :<: ps) ts) of - (start :> patches) -> start :> x +<+ patches + mh (PatchSet (ts :<: Tagged t _ ps) x) = + case mh (PatchSet ts (ps :<: t)) of + (start :> patches) -> start :> patches +<+ x mh ps = ps :> NilRL savetoBundle :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] - -> PatchSet p Origin wZ -> FL (PatchInfoAnd p) wZ wT -> IO () + -> PatchSet rt p Origin wZ -> FL (PatchInfoAnd rt p) wZ wT -> IO () savetoBundle opts kept removed@(x :>: _) = do let genFullBundle = makeBundleN Nothing kept (mapFL_FL hopefully removed) bundle <- if not (minimize opts) @@ -437,7 +445,6 @@ patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveralOrLast flags - , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags diff --git a/src/Darcs/UI/Commands/Unrevert.hs b/src/Darcs/UI/Commands/Unrevert.hs --- a/src/Darcs/UI/Commands/Unrevert.hs +++ b/src/Darcs/UI/Commands/Unrevert.hs @@ -20,11 +20,14 @@ module Darcs.UI.Commands.Unrevert ( unrevert, writeUnrevert ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^), catch ) import Control.Exception ( catch, IOException ) import System.Exit ( exitSuccess ) -import Storage.Hashed.Tree( Tree ) +import Darcs.Util.Tree( Tree ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Flags @@ -42,20 +45,20 @@ readRepo, readRecorded, applyToWorking, unrecordedChanges ) -import Darcs.Patch ( RepoPatch, PrimOf, commute, namepatch, fromPrims ) +import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf, commute, fromPrims ) import Darcs.Patch.Apply( ApplyState ) +import Darcs.Patch.Named.Wrapped ( namepatch ) import Darcs.Patch.Set ( Origin ) import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), (+>+) ) import Darcs.UI.SelectChanges - ( selectChanges - , WhichChanges(First) + ( WhichChanges(First) , runSelection , selectionContextPrim ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import qualified Data.ByteString as B -import Darcs.Repository.Lock ( writeDocBinFile, removeFileMayNotExist ) +import Darcs.Util.Lock ( writeDocBinFile, removeFileMayNotExist ) import Darcs.Patch.Depends ( mergeThem ) import Darcs.UI.External ( catchall ) import Darcs.Util.Prompt ( askUser ) @@ -68,7 +71,7 @@ unrevertDescription :: String unrevertDescription = - "Undo the last revert (may fail if changes after the revert)." + "Undo the last revert." unrevertHelp :: String unrevertHelp = @@ -121,7 +124,6 @@ patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = [] - , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default @@ -162,7 +164,7 @@ ( UseIndex, ScanKnown, diffAlgorithm opts ) NilFL h_them let context = selectionContextPrim First "unrevert" (patchSelOpts opts) Nothing Nothing (Just recorded) - (p :> skipped) <- runSelection (selectChanges pw) context + (p :> skipped) <- runSelection pw context tentativelyAddToPending repository YesUpdateWorking p withSignalsBlocked $ do finalizeRepositoryChanges repository YesUpdateWorking (compression opts) @@ -174,8 +176,8 @@ debugMessage "Finished unreverting." unrevertCmd _ _ _ = impossible -writeUnrevert :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> FL (PrimOf p) wX wY +writeUnrevert :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> FL (PrimOf p) wX wY -> Tree IO -> FL (PrimOf p) wR wX -> IO () writeUnrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository writeUnrevert repository ps recorded pend = @@ -190,10 +192,10 @@ np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p') bundle <- makeBundleN (Just recorded) rep (np :>: NilFL) writeDocBinFile (unrevertUrl repository) bundle - where fromRepoPrims :: RepoPatch p => Repository p wR wU wT -> FL (PrimOf p) wR wY -> FL p wR wY + where fromRepoPrims :: RepoPatch p => Repository rt p wR wU wT -> FL (PrimOf p) wR wY -> FL p wR wY fromRepoPrims _ = fromPrims -unrevertPatchBundle :: RepoPatch p => Repository p wR wU wT -> IO (SealedPatchSet p Origin) +unrevertPatchBundle :: RepoPatch p => Repository rt p wR wU wT -> IO (SealedPatchSet rt p Origin) unrevertPatchBundle repository = do pf <- B.readFile (unrevertUrl repository) `catchall` fail "There's nothing to unrevert!" diff --git a/src/Darcs/UI/Commands/Util.hs b/src/Darcs/UI/Commands/Util.hs --- a/src/Darcs/UI/Commands/Util.hs +++ b/src/Darcs/UI/Commands/Util.hs @@ -16,9 +16,10 @@ -- Boston, MA 02110-1301, USA. {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Util ( announceFiles - , filterExistingFiles + , filterExistingPaths , testTentativeAndMaybeExit , getUniqueRepositoryName , getUniqueDPatchName @@ -26,34 +27,37 @@ import Control.Monad ( unless ) +import Prelude () +import Darcs.Prelude + import System.Exit ( ExitCode(..), exitWith ) -import Storage.Hashed.Monad ( virtualTreeIO, exists ) -import Storage.Hashed.Tree ( Tree ) -import Storage.Hashed( floatPath, readPlainTree ) +import Darcs.Util.Tree.Monad ( virtualTreeIO, exists ) +import Darcs.Util.Tree ( Tree ) -import Darcs.Util.Path - ( SubPath, toFilePath, getUniquePathName ) import Darcs.Patch ( RepoPatch ) -import Darcs.Repository ( Repository, readRecorded, readUnrecorded, - testTentative ) -import Darcs.Repository.State ( applyTreeFilter, restrictBoring ) -import Darcs.Repository.Flags ( LookForAdds (..) ) +import Darcs.Repository ( Repository, readRecorded, testTentative ) +import Darcs.Repository.State ( readUnrecordedFiltered ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Bundle ( patchFilename ) import Darcs.UI.Options.All - ( Verbosity, SetScriptsExecutable, TestChanges (..) - , RunTest(..), LeaveTestDir(..) ) + ( Verbosity(..), SetScriptsExecutable, TestChanges (..) + , RunTest(..), LeaveTestDir(..), UseIndex, ScanKnown(..) ) import Darcs.Util.Exception ( clarifyErrors ) +import Darcs.Util.Path + ( SubPath, toFilePath, getUniquePathName, floatPath ) +import Darcs.Util.Printer ( putDocLn, text, (<>), (<+>) ) import Darcs.Util.Prompt ( PromptConfig(..), promptChar ) +import Darcs.Util.Text ( pathlist ) -announceFiles :: Maybe [SubPath] -> String -> IO () -announceFiles Nothing _ = return () -announceFiles (Just files) message = putStrLn $ message ++ " " ++ - unwords (map show files) ++ ":\n" +announceFiles :: Verbosity -> Maybe [SubPath] -> String -> IO () +announceFiles Quiet _ _ = return () +announceFiles _ (Just subpaths) message = putDocLn $ + text message <> text ":" <+> pathlist (map toFilePath subpaths) +announceFiles _ _ _ = return () testTentativeAndMaybeExit :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT + => Repository rt p wR wU wT -> Verbosity -> TestChanges -> SetScriptsExecutable @@ -74,29 +78,34 @@ yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') []) unless (yn == 'y') doExit -filterExistingFiles :: (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT - -> LookForAdds +-- | Given a repository and two common command options, classify the given list +-- of subpaths according to whether they exist in the pristine or working tree. +-- Paths which are neither in working nor pristine are reported and dropped. +-- The result is a pair of path lists: those that exist only in the working tree, +-- and those that exist in pristine or working. +filterExistingPaths :: (RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT + -> Verbosity + -> UseIndex + -> ScanKnown -> [SubPath] - -> IO [SubPath] -filterExistingFiles repo lfa files = do + -> IO ([SubPath],[SubPath]) +filterExistingPaths repo verb useidx scan paths = do pristine <- readRecorded repo - -- TODO this is slightly inefficient, since we should really somehow - -- extract the unrecorded state as a side-effect of unrecordedChanges - index <- readUnrecorded repo $ Just files - nonboring <- restrictBoring index - working <- applyTreeFilter nonboring `fmap` readPlainTree "." - let paths = map toFilePath files - check = virtualTreeIO $ mapM (exists . floatPath) paths - (in_working, _) <- check working + working <- readUnrecordedFiltered repo useidx scan (Just paths) + let filepaths = map toFilePath paths + check = virtualTreeIO $ mapM (exists . floatPath) filepaths (in_pristine, _) <- check pristine - mapM_ maybe_warn $ zip3 paths in_working in_pristine - return [ path | (path, True) <- zip files (zipWith (||) in_working in_pristine) ] - where maybe_warn (file, False, False) = - putStrLn $ "WARNING: File '"++file++"' does not exist!" - maybe_warn (file, True, False) | lfa == YesLookForAdds = - putStrLn $ "WARNING: File '" ++ file ++ "' not in repository!" - maybe_warn _ = return () + (in_working, _) <- check working + let paths_with_info = zip3 paths in_pristine in_working + paths_in_neither = [ p | (p,False,False) <- paths_with_info ] + paths_only_in_working = [ p | (p,False,True) <- paths_with_info ] + paths_in_either = [ p | (p,inp,inw) <- paths_with_info, inp || inw ] + or_not_added = if scan == ScanKnown then " or not added " else " " + unless (verb == Quiet || null paths_in_neither) $ putDocLn $ + "Ignoring non-existing" <> or_not_added <> "paths:" <+> + pathlist (map toFilePath paths_in_neither) + return (paths_only_in_working, paths_in_either) getUniqueRepositoryName :: Bool -> FilePath -> IO FilePath getUniqueRepositoryName talkative name = getUniquePathName talkative buildMsg buildName diff --git a/src/Darcs/UI/Commands/Util/Tree.hs b/src/Darcs/UI/Commands/Util/Tree.hs --- a/src/Darcs/UI/Commands/Util/Tree.hs +++ b/src/Darcs/UI/Commands/Util/Tree.hs @@ -24,22 +24,24 @@ , treeHasAnycase ) where +import Prelude () +import Darcs.Prelude + import Control.Monad ( forM ) import Control.Monad.State.Strict( gets ) import qualified Data.ByteString.Char8 as BSC import Data.Char ( toLower ) -import Storage.Hashed.Monad +import Darcs.Util.Tree.Monad ( withDirectory, fileExists, directoryExists , virtualTreeMonad, currentDirectory , TreeMonad ) -import qualified Storage.Hashed.Monad as HS ( exists, tree ) -import Storage.Hashed.Tree ( Tree, listImmediate, findTree ) -import Storage.Hashed ( floatPath ) +import qualified Darcs.Util.Tree.Monad as HS ( exists, tree ) +import Darcs.Util.Tree ( Tree, listImmediate, findTree ) import Darcs.Util.Path - ( AnchoredPath(..), Name(..) ) + ( AnchoredPath(..), Name(..), floatPath ) treeHasAnycase :: (Functor m, Monad m) => Tree m diff --git a/src/Darcs/UI/Commands/WhatsNew.hs b/src/Darcs/UI/Commands/WhatsNew.hs --- a/src/Darcs/UI/Commands/WhatsNew.hs +++ b/src/Darcs/UI/Commands/WhatsNew.hs @@ -24,18 +24,20 @@ , status ) where -import Prelude hiding ( (^), catch ) +import Prelude () +import Darcs.Prelude -import Control.Applicative ( (<$>) ) import Control.Monad ( void ) import Control.Monad.Reader ( runReaderT ) import Control.Monad.State ( evalStateT, liftIO ) -import Storage.Hashed.Tree ( Tree ) +import Darcs.Util.Tree ( Tree ) import System.Exit ( ExitCode (..), exitSuccess, exitWith ) +import Data.List.Ordered ( nubSort ) import Darcs.Patch ( PrimOf, PrimPatch, RepoPatch , applyToTree, plainSummaryPrims, primIsHunk + , listTouchedFiles, IsRepoType ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Choices ( patchChoicesLps, lpPatch ) @@ -60,16 +62,17 @@ import Darcs.Patch.Witnesses.WZipper ( FZipper (..) ) import Darcs.Repository ( RepoJob (..), Repository - , listRegisteredFiles, readRecorded + , listRegisteredFiles, readRecorded, readRepo , unrecordedChangesWithPatches, withRepository ) import Darcs.Repository.Diff ( treeDiff ) import Darcs.Repository.Prefs ( filetypeFunction ) -import Darcs.Repository.Util ( getMovesPs, getReplaces ) +import Darcs.Repository.State ( getMovesPs, getReplaces ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, amInRepository , commandAlias, nodefaults ) +import Darcs.Repository.Resolution ( patchsetConflictResolutions ) import Darcs.UI.Commands.Util ( announceFiles ) import Darcs.UI.Flags ( DarcsFlag (Summary, LookForAdds, LookForMoves), diffAlgorithm, diffingOpts @@ -94,7 +97,7 @@ , skipOne, printSummary ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) -import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath ) +import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath, fp2fn ) import Darcs.Util.Printer ( putDocLn, renderString, RenderMode(..) , text, vcat @@ -120,7 +123,7 @@ ^ O.workingRepoDir ^ O.interactive -- False -whatsnewAdvancedOpts :: DarcsOption a (O.UseIndex -> Bool -> a) +whatsnewAdvancedOpts :: DarcsOption a (O.UseIndex -> O.IncludeBoring -> a) whatsnewAdvancedOpts = O.useIndex ^ O.includeBoring whatsnewOpts :: DarcsOption a @@ -137,7 +140,7 @@ -> O.Verbosity -> Bool -> O.UseIndex - -> Bool + -> O.IncludeBoring -> O.UseCache -> Maybe String -> Bool @@ -150,7 +153,6 @@ patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = [] - , S.diffAlgorithm = diffAlgorithm flags , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = hasSummary (defaultSummary flags) flags @@ -222,7 +224,7 @@ whatsnewCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () whatsnewCmd fps opts args = - withRepository (useCache opts) $ RepoJob $ \(repo :: Repository p wR wU wR) -> do + withRepository (useCache opts) $ RepoJob $ \(repo :: Repository rt p wR wU wR) -> do files <- if null args then return Nothing else Just <$> fixSubPaths fps args @@ -256,12 +258,12 @@ -- Return the patches that create files/dirs that aren't yet added. unFreeLeft <$> treeDiff (diffAlgorithm opts) ftf noLookAddsTree lookAddsTree else return (Sealed NilFL) - announceFiles files "What's new in" + announceFiles (verbosity opts) files "What's new in" exitOnNoChanges (unaddedNewPathsPs, noLookChanges) if maybeIsInteractive opts then runInteractive (interactiveHunks pristine) opts' pristine noLookChanges else do - printChanges opts' pristine noLookChanges + printChanges repo opts' pristine noLookChanges printUnaddedPaths unaddedNewPathsPs where -- |Filter out hunk patches (leaving add patches) and return the tree @@ -278,7 +280,7 @@ printUnaddedPaths :: PrimPatch p => FL p wX wY -> IO () printUnaddedPaths NilFL = return () printUnaddedPaths ps = - putDocLn . lowercaseAs . renderString Encode . (plainSummaryPrims False) $ ps + putDocLn . lowercaseAs . renderString Encode . (plainSummaryPrims False []) $ ps -- Make any add markers lowercase, to distinguish new-but-unadded files -- from those that are unrecorded, but added. @@ -287,25 +289,30 @@ lowercaseA x = x -- |Appropriately print changes, according to the passed flags. - printChanges :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p, PrimDetails p, - ApplyState p ~ Tree) => [DarcsFlag] -> Tree IO -> FL p wX wY + printChanges :: forall rt p wR wU wX wY. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) + => Repository rt p wR wU wR -> [DarcsFlag] -> Tree IO -> FL (PrimOf p) wX wY -> IO () - printChanges opts' pristine changes - | Summary `elem` opts' = putDocLn $ plainSummaryPrims machineReadable changes + printChanges repo opts' pristine changes + | Summary `elem` opts' = do + r <- readRepo repo + Sealed res <- return $ patchsetConflictResolutions r + let conflictFns = map fp2fn $ nubSort $ listTouchedFiles res + putDocLn $ plainSummaryPrims machineReadable conflictFns changes | isUnified opts' == O.YesContext = contextualPrintPatch pristine changes | otherwise = printPatch changes where machineReadable = parseFlags O.machineReadable opts -- |return the unrecorded changes that affect an optional list of paths. - filteredUnrecordedChanges :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree, - ApplyState (PrimOf p) ~ Tree) => [DarcsFlag] - -> Repository p wR wU wT -> Maybe [SubPath] + filteredUnrecordedChanges :: forall rt p wR wU wT. (RepoPatch p, ApplyState p ~ Tree, + ApplyState (PrimOf p) ~ Tree) + => [DarcsFlag] + -> Repository rt p wR wU wT -> Maybe [SubPath] -> FL (PrimOf p) wR wT -- look-for-moves patches -> FL (PrimOf p) wT wT -- look-for-replaces patches -> IO (Sealed (FL (PrimOf p) wT)) filteredUnrecordedChanges opts' repo files movesPs replacesPs = let filePaths = map toFilePath <$> files in - choosePreTouching filePaths <$> unrecordedChangesWithPatches (diffingOpts opts') repo files movesPs replacesPs + choosePreTouching filePaths <$> unrecordedChangesWithPatches movesPs replacesPs (diffingOpts opts') repo files -- | Runs the 'InteractiveSelectionM' code runInteractive :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p, @@ -325,7 +332,8 @@ , choices = choices' } void $ runReaderT ps $ - selectionContextPrim First "view" (patchSelOpts opts) (Just primSplitter) + selectionContextPrim First "view" (patchSelOpts opts) + (Just (primSplitter (diffAlgorithm opts))) Nothing (Just pristine) -- | The interactive part of @darcs whatsnew@ diff --git a/src/Darcs/UI/CommandsAux.hs b/src/Darcs/UI/CommandsAux.hs --- a/src/Darcs/UI/CommandsAux.hs +++ b/src/Darcs/UI/CommandsAux.hs @@ -24,6 +24,9 @@ , hasMaliciousPath ) where +import Prelude () +import Darcs.Prelude + import Control.Monad ( when ) import Darcs.UI.Flags ( DarcsFlag ) diff --git a/src/Darcs/UI/Defaults.hs b/src/Darcs/UI/Defaults.hs --- a/src/Darcs/UI/Defaults.hs +++ b/src/Darcs/UI/Defaults.hs @@ -1,5 +1,8 @@ module Darcs.UI.Defaults ( applyDefaults ) where +import Prelude () +import Darcs.Prelude + import Control.Monad.Writer import Data.Char ( isSpace ) import Data.Functor.Compose ( Compose(..) ) @@ -8,8 +11,8 @@ import qualified Data.Map as M import System.Console.GetOpt import Text.Regex.Applicative - ( (<$>), (<*>), (*>), (<|>) - , match, pure, many, some + ( (<|>) + , match, many, some , psym, anySym, string ) import Darcs.UI.Flags ( DarcsFlag ) diff --git a/src/Darcs/UI/Email.hs b/src/Darcs/UI/Email.hs --- a/src/Darcs/UI/Email.hs +++ b/src/Darcs/UI/Email.hs @@ -5,6 +5,9 @@ , formatHeader ) where +import Prelude () +import Darcs.Prelude + import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper ) import Data.List ( isInfixOf ) import Darcs.Util.Printer diff --git a/src/Darcs/UI/External.hs b/src/Darcs/UI/External.hs --- a/src/Darcs/UI/External.hs +++ b/src/Darcs/UI/External.hs @@ -11,7 +11,6 @@ , execPipeIgnoreError , pipeDoc , pipeDocSSH - , maybeURLCmd , viewDoc , viewDocWith , haveSendmail @@ -27,7 +26,8 @@ , isUTF8Locale ) where -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude import Data.Maybe ( isJust, isNothing, maybeToList ) import Control.Monad ( unless, when, filterM, liftM2, void ) @@ -58,14 +58,14 @@ ( try, finally, catch, IOException ) import System.IO.Error ( ioeGetErrorType ) import GHC.IO.Exception ( IOErrorType(ResourceVanished) ) -import Data.Char ( toUpper, toLower ) +import Data.Char ( toLower ) import Text.Regex #if defined (HAVE_MAPI) import Foreign.C ( withCString ) #endif #ifdef HAVE_MAPI import Foreign.Ptr ( nullPtr ) -import Darcs.Repository.Lock ( canonFilename, writeDocBinFile ) +import Darcs.Util.Lock ( canonFilename, writeDocBinFile ) #endif import Darcs.Util.SignalHandler ( catchNonSignal ) @@ -83,12 +83,12 @@ ,take, concat, drop, isPrefixOf, singleton, append) import qualified Data.ByteString.Char8 as BC (unpack, pack) -import Darcs.Repository.Lock +import Darcs.Util.Lock ( withTemp , withNamedTemp , withOpenTemp ) -import Darcs.Repository.Ssh ( getSSH, SSHCmd(..) ) +import Darcs.Util.Ssh ( getSSH, SSHCmd(..) ) import Darcs.Util.CommandLine ( parseCmd, addUrlencoded ) import Darcs.Util.Exec ( execInteractive, exec, Redirect(..), withoutNonBlock ) import Darcs.Util.URL ( SshFilePath, sshUhost ) @@ -121,12 +121,6 @@ #else darcsProgram = getProgName #endif - -maybeURLCmd :: String -> String -> IO (Maybe String) -maybeURLCmd what url = - do let prot = map toUpper $ takeWhile (/= ':') url - fmap Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot)) - `catch` \(_ :: IOException) -> return Nothing pipeDoc :: RenderMode -> String -> [String] -> Doc -> IO ExitCode pipeDoc = pipeDocInternal (PipeToOther simplePrinters) diff --git a/src/Darcs/UI/Flags.hs b/src/Darcs/UI/Flags.hs --- a/src/Darcs/UI/Flags.hs +++ b/src/Darcs/UI/Flags.hs @@ -15,6 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. +{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Flags ( -- TODO we want to stop exporting the constructors of DarcsFlag -- from here. First need to change all the relevant code over to the @@ -27,6 +28,7 @@ , editDescription , diffingOpts , diffOpts + , scanKnown , externalMerge , wantGuiPause , isInteractive @@ -92,7 +94,8 @@ , applyAs ) where -import Prelude hiding ( (^) ) +import Prelude () +import Darcs.Prelude import Data.List ( nub, intercalate ) import Data.Maybe @@ -102,7 +105,6 @@ , catMaybes ) import Control.Monad ( unless ) -import Control.Applicative( (<$>) ) import System.Directory ( doesDirectoryExist, createDirectory ) import System.FilePath.Posix ( () ) @@ -119,7 +121,7 @@ ( askUser , askUserListItem ) -import Darcs.Repository.Lock ( writeLocaleFile ) +import Darcs.Util.Lock ( writeLocaleFile ) import Darcs.Repository.Prefs ( getPreflist , getGlobal @@ -138,8 +140,9 @@ , ioAbsolute , makeAbsoluteOrStd ) -import Darcs.Util.Printer ( putDocLn, text, ($$) ) +import Darcs.Util.Printer ( putDocLn, ePutDocLn, text, ($$), (<+>) ) import Darcs.Util.URL ( isValidLocalPath ) +import Darcs.Util.Text ( pathlist ) type Config = [F.DarcsFlag] @@ -158,17 +161,18 @@ editDescription :: Config -> Bool editDescription = parseFlags O.editDescription --- | Non-trivial interaction between options. -diffOpts :: O.UseIndex -> O.LookForAdds -> Bool -> O.DiffAlgorithm -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) +diffOpts :: O.UseIndex -> O.LookForAdds -> O.IncludeBoring -> O.DiffAlgorithm -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) diffOpts use_index look_for_adds include_boring diff_alg = (use_index, scanKnown look_for_adds include_boring, diff_alg) - where - scanKnown O.NoLookForAdds _ = O.ScanKnown - scanKnown O.YesLookForAdds False = O.ScanAll - scanKnown O.YesLookForAdds True = O.ScanBoring +-- | Non-trivial interaction between options. +scanKnown :: O.LookForAdds -> O.IncludeBoring -> O.ScanKnown +scanKnown O.NoLookForAdds _ = O.ScanKnown +scanKnown O.YesLookForAdds O.NoIncludeBoring = O.ScanAll +scanKnown O.YesLookForAdds O.YesIncludeBoring = O.ScanBoring + diffingOpts :: Config -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) -diffingOpts flags = diffOpts (useIndex flags) (lookForAdds flags) False (diffAlgorithm flags) +diffingOpts flags = diffOpts (useIndex flags) (lookForAdds flags) O.NoIncludeBoring (diffAlgorithm flags) externalMerge :: Config -> O.ExternalMerge externalMerge = parseFlags O.useExternalMerge @@ -207,7 +211,9 @@ doHappyForwarding = parseFlags O.happyForwarding includeBoring :: Config -> Bool -includeBoring = parseFlags O.includeBoring +includeBoring cfg = case parseFlags O.includeBoring cfg of + O.NoIncludeBoring -> False + O.YesIncludeBoring -> True doAllowCaseOnly :: Config -> Bool doAllowCaseOnly = parseFlags O.allowCaseDifferingFilenames @@ -303,9 +309,14 @@ then toFilePath `fmap` withCurrentDirectory d (ioAbsolute f) else return f --- | @maybeFixSubPaths files@ tries to turn the file paths in its argument into --- @SubPath@s. +-- | @maybeFixSubPaths (repo_path, orig_path) file_paths@ tries to turn +-- @file_paths@ into 'SubPath's, taking into account the repository path and +-- the original path from which darcs was invoked. -- +-- A 'SubPath' is a path /under/ (or inside) the repo path. This does /not/ +-- mean it must exist as a file or directory, nor that the path has been added +-- to the repository; it merely means that it /could/ be added. +-- -- When converting a relative path to an absolute one, this function first tries -- to interpret the relative path with respect to the current working directory. -- If that fails, it tries to interpret it with respect to the repository @@ -314,30 +325,24 @@ -- -- It is intended for validating file arguments to darcs commands. maybeFixSubPaths :: (AbsolutePath, AbsolutePath) -> [FilePath] -> IO [Maybe SubPath] -maybeFixSubPaths (r, o) fs = withCurrentDirectory o $ do +maybeFixSubPaths (r, o) fs = do fixedFs <- mapM fixit fs let bads = snd . unzip . filter (isNothing . fst) $ zip fixedFs fs - unless (null bads) . putStrLn $ "Ignoring non-repository paths: " ++ - intercalate ", " bads + unless (null bads) $ + ePutDocLn $ text "Ignoring non-repository paths:" <+> pathlist bads return fixedFs where - fixit p = do ap <- ioAbsolute p + fixit p = do ap <- withCurrentDirectory o $ ioAbsolute p case makeSubPathOf r ap of Just sp -> return $ Just sp - Nothing -> withCurrentDirectory r $ do - absolutePathByRepodir <- ioAbsolute p + Nothing -> do + absolutePathByRepodir <- withCurrentDirectory r $ ioAbsolute p return $ makeSubPathOf r absolutePathByRepodir --- | @fixSubPaths files@ returns the @SubPath@s for the paths in @files@ that --- are inside the repository, preserving their order. Paths in @files@ that are --- outside the repository directory are not in the result. --- --- When converting a relative path to an absolute one, this function first tries --- to interpret the relative path with respect to the current working directory. --- If that fails, it tries to interpret it with respect to the repository --- directory. Only when that fails does it omit the path from the result. --- --- It is intended for validating file arguments to darcs commands. +-- | 'fixSubPaths' is a variant of 'maybeFixSubPaths' that throws out +-- non-repository paths and duplicates from the result. See there for details. +-- TODO: why filter out null paths from the input? why here and not in +-- 'maybeFixSubPaths'? fixSubPaths :: (AbsolutePath, AbsolutePath) -> [FilePath] -> IO [SubPath] fixSubPaths fps fs = nub . catMaybes <$> maybeFixSubPaths fps (filter (not . null) fs) diff --git a/src/Darcs/UI/Message/Send.hs b/src/Darcs/UI/Message/Send.hs --- a/src/Darcs/UI/Message/Send.hs +++ b/src/Darcs/UI/Message/Send.hs @@ -21,10 +21,12 @@ -- | Help text and UI messages for @darcs send@ module Darcs.UI.Message.Send where +import Prelude () +import Darcs.Prelude + import Darcs.Util.Path ( FilePathLike(..), toFilePath ) -import Darcs.UI.Commands ( formatPath ) import Darcs.Repository.Flags ( DryRun(..) ) -import Darcs.Util.Text ( sentence ) +import Darcs.Util.Text ( sentence, quote ) import Darcs.Util.Printer cmdDescription :: String @@ -113,7 +115,7 @@ cannotSendToSelf = "Can't send to current repository! Did you mean send --context?" creatingPatch :: String -> Doc -creatingPatch repodir = "Creating patch to" <+> text (formatPath repodir) <> "..." +creatingPatch repodir = "Creating patch to" <+> text (quote repodir) <> "..." noWorkingSendmail :: Doc noWorkingSendmail = "No working sendmail instance on your machine!" diff --git a/src/Darcs/UI/Options.hs b/src/Darcs/UI/Options.hs --- a/src/Darcs/UI/Options.hs +++ b/src/Darcs/UI/Options.hs @@ -7,6 +7,9 @@ , optDescr ) where +import Prelude () +import Darcs.Prelude + import Data.Functor.Compose import System.Console.GetOpt diff --git a/src/Darcs/UI/Options/All.hs b/src/Darcs/UI/Options/All.hs --- a/src/Darcs/UI/Options/All.hs +++ b/src/Darcs/UI/Options/All.hs @@ -104,6 +104,7 @@ , UseIndex (..) -- re-export , ScanKnown (..) -- re-export , diffing + , IncludeBoring (..) , includeBoring , allowProblematicFilenames , allowCaseDifferingFilenames @@ -234,6 +235,9 @@ , optimizePatchIndex ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^) ) import Data.Char ( isDigit ) import Data.List ( intercalate ) @@ -265,6 +269,8 @@ , WantGuiPause (..) , WithPatchIndex (..) , WithWorkingDir (..) + , PatchFormat (..) + , IncludeBoring (..) ) import qualified Darcs.UI.Options.Flags as F ( DarcsFlag(..) ) @@ -663,17 +669,17 @@ scanKnown :: PrimDarcsOption ScanKnown scanKnown = imap (Iso fw bw) $ lookforadds ^ includeBoring where - fw k ScanKnown = k NoLookForAdds False - fw k ScanAll = k YesLookForAdds False - fw k ScanBoring = k YesLookForAdds True + fw k ScanKnown = k NoLookForAdds NoIncludeBoring + fw k ScanAll = k YesLookForAdds NoIncludeBoring + fw k ScanBoring = k YesLookForAdds YesIncludeBoring bw k NoLookForAdds _ = k ScanKnown - bw k YesLookForAdds False = k ScanAll - bw k YesLookForAdds True = k ScanBoring + bw k YesLookForAdds NoIncludeBoring = k ScanAll + bw k YesLookForAdds YesIncludeBoring = k ScanBoring -includeBoring :: PrimDarcsOption Bool -includeBoring = withDefault False - [ RawNoArg [] ["boring"] F.Boring True "don't skip boring files" - , RawNoArg [] ["no-boring"] F.SkipBoring False "skip boring files" ] +includeBoring :: PrimDarcsOption IncludeBoring +includeBoring = withDefault NoIncludeBoring + [ RawNoArg [] ["boring"] F.Boring YesIncludeBoring "don't skip boring files" + , RawNoArg [] ["no-boring"] F.SkipBoring NoIncludeBoring "skip boring files" ] allowProblematicFilenames :: DarcsOption a (Bool -> Bool -> a) allowProblematicFilenames = allowCaseDifferingFilenames ^ allowWindowsReservedFilenames @@ -1094,8 +1100,11 @@ -- | See above. machineReadable :: PrimDarcsOption Bool -machineReadable = singleNoArg [] ["machine-readable"] F.MachineReadable "give machine-readable output" +machineReadable = withDefault False [__machineReadable True] +__machineReadable :: RawDarcsOption +__machineReadable val = RawNoArg [] ["machine-readable"] F.MachineReadable val "give machine-readable output" + -- ** clone partial :: PrimDarcsOption CloneKind @@ -1127,14 +1136,12 @@ , "Use --darcs-1 to get the effect that --hashed had previously." ] $ [ RawNoArg [] ["hashed"] F.Hashed () "deprecated, use --darcs-1 instead" ] -data PatchFormat = PatchFormat1 | PatchFormat2 deriving (Eq, Show) - patchFormat :: PrimDarcsOption PatchFormat patchFormat = withDefault PatchFormat2 [ RawNoArg [] ["darcs-2"] F.UseFormat2 PatchFormat2 "Standard darcs patch format" , RawNoArg [] ["darcs-1"] F.UseFormat1 PatchFormat1 - "Older patch format (for compatibility)"] + "Older patch format (for compatibility)" ] -- ** dist @@ -1148,13 +1155,14 @@ -- ** log -data ChangesFormat = HumanReadable | GenContext | GenXml | NumberPatches | CountPatches deriving (Eq, Show) +data ChangesFormat = HumanReadable | MachineReadable | GenContext | GenXml | NumberPatches | CountPatches deriving (Eq, Show) changesFormat :: PrimDarcsOption (Maybe ChangesFormat) changesFormat = withDefault Nothing [ RawNoArg [] ["context"] F.GenContext (Just GenContext) "give output suitable for get --context" , __xmloutput (Just GenXml) , __humanReadable (Just HumanReadable) + , __machineReadable (Just MachineReadable) , RawNoArg [] ["number"] F.NumberPatches (Just NumberPatches) "number the changes" , RawNoArg [] ["count"] F.Count (Just CountPatches) "output count of changes" ] diff --git a/src/Darcs/UI/Options/Core.hs b/src/Darcs/UI/Options/Core.hs --- a/src/Darcs/UI/Options/Core.hs +++ b/src/Darcs/UI/Options/Core.hs @@ -32,8 +32,8 @@ -} module Darcs.UI.Options.Core where -import Prelude hiding ( (^) ) -import Data.Monoid ( Monoid(..) ) +import Prelude () +import Darcs.Prelude import Darcs.UI.Options.Iso diff --git a/src/Darcs/UI/Options/Flags.hs b/src/Darcs/UI/Options/Flags.hs --- a/src/Darcs/UI/Options/Flags.hs +++ b/src/Darcs/UI/Options/Flags.hs @@ -3,6 +3,9 @@ -- should import 'Darcs.UI.Flags' module Darcs.UI.Options.Flags ( DarcsFlag(..) ) where +import Prelude () +import Darcs.Prelude + import Darcs.Util.Path ( AbsolutePath, AbsolutePathOrStd ) -- | The 'DarcsFlag' type is a list of all flags that can ever be diff --git a/src/Darcs/UI/Options/Iso.hs b/src/Darcs/UI/Options/Iso.hs --- a/src/Darcs/UI/Options/Iso.hs +++ b/src/Darcs/UI/Options/Iso.hs @@ -1,4 +1,8 @@ module Darcs.UI.Options.Iso where + +import Prelude () +import Darcs.Prelude + -- * Isomorphisms -- | Lightweight type ismomorphisms (a.k.a. invertible functions). If diff --git a/src/Darcs/UI/Options/Markdown.hs b/src/Darcs/UI/Options/Markdown.hs --- a/src/Darcs/UI/Options/Markdown.hs +++ b/src/Darcs/UI/Options/Markdown.hs @@ -1,6 +1,9 @@ -- Support for @darcs help markdown@ module Darcs.UI.Options.Markdown ( optionsMarkdown ) where +import Prelude () +import Darcs.Prelude + import Data.Functor.Compose ( Compose(..) ) import System.Console.GetOpt ( OptDescr(..), ArgDescr(..) ) import Darcs.UI.Options.Util ( DarcsOptDescr ) diff --git a/src/Darcs/UI/Options/Matching.hs b/src/Darcs/UI/Options/Matching.hs --- a/src/Darcs/UI/Options/Matching.hs +++ b/src/Darcs/UI/Options/Matching.hs @@ -13,7 +13,7 @@ -} module Darcs.UI.Options.Matching ( MatchFlag(..) -- re-export - , matchOne + , matchUpToOne , matchOneContext , matchOneNontag , matchSeveral @@ -22,12 +22,13 @@ , matchRange , matchSeveralOrRange , matchAny -- temporary, for toMatchFlags - , context -- temporary, for getContext ) where -import Prelude hiding ( last ) +import Prelude () +import Darcs.Prelude hiding ( last ) + import Data.Char ( isDigit ) -import Data.Monoid ( (<>), mconcat ) +import Data.Monoid ( (<>) ) import Darcs.Patch.Match ( MatchFlag(..) ) import qualified Darcs.UI.Options.Flags as F ( DarcsFlag(..) ) @@ -40,8 +41,8 @@ -- * Combined matching options -matchOne :: MatchOption -- ^ amend, show files/contents, dist, annotate -matchOne = mconcat [match, patch, hash, tag, index] +matchUpToOne :: MatchOption -- ^ show files/contents, dist, annotate +matchUpToOne = mconcat [match, patch, hash, tag, index] -- | Used by: clone matchOneContext :: MatchOption diff --git a/src/Darcs/UI/Options/Util.hs b/src/Darcs/UI/Options/Util.hs --- a/src/Darcs/UI/Options/Util.hs +++ b/src/Darcs/UI/Options/Util.hs @@ -26,6 +26,9 @@ , makeAbsoluteOrStd ) where +import Prelude () +import Darcs.Prelude + import System.Console.GetOpt ( OptDescr(..), ArgDescr(..) ) import Data.Functor.Compose import Data.List ( intercalate ) diff --git a/src/Darcs/UI/PatchHeader.hs b/src/Darcs/UI/PatchHeader.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/UI/PatchHeader.hs @@ -0,0 +1,295 @@ +module Darcs.UI.PatchHeader + ( getLog + , getAuthor + , updatePatchHeader, AskAboutDeps(..) + , HijackT, HijackOptions(..) + , runHijackT + ) where + +import Prelude () +import Darcs.Prelude + +import Darcs.Patch + ( IsRepoType, RepoPatch, Patchy, PrimPatch, PrimOf, fromPrims + , effect + , summaryFL + ) +import Darcs.Patch.Apply ( ApplyState ) +import Darcs.Patch.Info ( PatchInfo, + piAuthor, piName, piLog, piDateString, + patchinfo, isInverted, invertName, + ) +import Darcs.Patch.Named.Wrapped ( infopatch, getdeps, adddeps ) +import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully, info ) +import Darcs.Patch.Prim ( canonizeFL ) + +import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) ) + +import Darcs.Repository ( Repository ) +import Darcs.Util.Lock + ( readLocaleFile + , writeLocaleFile + , appendToFile + ) + +import Darcs.UI.External ( editFile ) +import Darcs.UI.Flags ( getEasyAuthor, promptAuthor, getDate ) +import qualified Darcs.UI.Options.All as O +import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) +import Darcs.UI.SelectChanges ( askAboutDepends ) + +import Darcs.Util.ByteString ( encodeLocale ) +import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) +import Darcs.Util.English ( capitalize ) +import Darcs.Util.Global ( darcsLastMessage ) +import Darcs.Util.Path ( FilePathLike, toFilePath ) +import Darcs.Util.Prompt ( PromptConfig(..), askUser, promptChar, promptYorn ) +import Darcs.Util.Printer ( hPutDocLn, text, ($$), prefixLines, RenderMode(..) ) +import qualified Darcs.Util.Ratified as Ratified ( hGetContents ) + +import Darcs.Util.Tree ( Tree ) + +import Control.Exception ( catch, IOException ) +import Control.Monad ( when, void ) +import Control.Monad.Trans ( liftIO ) +import Control.Monad.Trans.State.Strict ( StateT(..), evalStateT, get, put ) +import qualified Data.ByteString as B ( hPut ) +import Data.List ( isPrefixOf ) +import System.Exit ( exitSuccess ) +import System.IO ( stdin ) + +data PName = FlagPatchName String | PriorPatchName String | NoPatchName + +-- | Options for how to deal with the situation where we are somehow +-- modifying a patch that is not our own +data HijackOptions = IgnoreHijack -- ^ accept all hijack requests + | RequestHijackPermission -- ^ prompt once, accepting subsequent hijacks if yes + | AlwaysRequestHijackPermission -- ^ always prompt + +-- | Transformer for interactions with a hijack warning state that we +-- need to thread through +type HijackT = StateT HijackOptions + +-- | Get the patch name and long description from one of +-- +-- * the configuration (flags, defaults, hard-coded) +-- +-- * an existing log file +-- +-- * stdin (e.g. a pipe) +-- +-- * a text editor +-- +-- It ensures the patch name is not empty nor starts with the prefix TAG. +-- +-- The last result component is a possible path to a temporary file that should be removed later. +getLog :: forall prim wX wY . (Patchy prim, PrimPatch prim) + => Maybe String -- ^ patchname option + -> Bool -- ^ pipe option + -> O.Logfile -- ^ logfile option + -> Maybe O.AskLongComment -- ^ askLongComment option + -> Maybe (String, [String]) -- ^ possibly an existing patch name and long description + -> FL prim wX wY -- ^ changes to record + -> IO (String, [String], Maybe String) -- ^ patch name, long description and possibly the path + -- to the temporary file that should be removed later +getLog m_name has_pipe log_file ask_long m_old chs = go has_pipe log_file ask_long where + go True _ _ = do + p <- case patchname_specified of + FlagPatchName p -> return p + PriorPatchName p -> return p + NoPatchName -> prompt_patchname False + putStrLn "What is the log?" + thelog <- lines `fmap` Ratified.hGetContents stdin + return (p, thelog, Nothing) + go _ (O.Logfile { O._logfile = Just f }) _ = do + mlp <- lines `fmap` readLocaleFile f `catch` (\(_ :: IOException) -> return []) + firstname <- case (patchname_specified, mlp) of + (FlagPatchName p, []) -> return p + (_, p:_) -> if badName p + then prompt_patchname True + else return p -- logfile trumps prior! + (PriorPatchName p, []) -> return p + (NoPatchName, []) -> prompt_patchname True + append_info f firstname + when (ask_long == Just O.YesEditLongComment) (void $ editFile f) + (name, thelog) <- read_long_comment f firstname + return (name, thelog, if O._rmlogfile log_file then Just $ toFilePath f else Nothing) + go _ _ (Just O.YesEditLongComment) = + case patchname_specified of + FlagPatchName p -> actually_get_log p + PriorPatchName p -> actually_get_log p + NoPatchName -> actually_get_log "" + go _ _ (Just O.NoEditLongComment) = + case patchname_specified of + FlagPatchName p -> return (p, default_log, Nothing) -- record (or amend) -m + PriorPatchName p -> return (p, default_log, Nothing) -- amend + NoPatchName -> do p <- prompt_patchname True -- record + return (p, [], Nothing) + go _ _ (Just O.PromptLongComment) = + case patchname_specified of + FlagPatchName p -> prompt_long_comment p -- record (or amend) -m + PriorPatchName p -> prompt_long_comment p + NoPatchName -> prompt_patchname True >>= prompt_long_comment + go _ _ Nothing = + case patchname_specified of + FlagPatchName p -> return (p, default_log, Nothing) -- record (or amend) -m + PriorPatchName "" -> actually_get_log "" + PriorPatchName p -> return (p, default_log, Nothing) + NoPatchName -> actually_get_log "" + + patchname_specified = case (m_name, m_old) of + (Just name, _) | badName name -> NoPatchName + | otherwise -> FlagPatchName name + (Nothing, Just (name,_)) -> PriorPatchName name + (Nothing, Nothing) -> NoPatchName + + badName "" = True + badName n = "TAG" `isPrefixOf` n + + default_log = case m_old of + Nothing -> [] + Just (_,l) -> l + + prompt_patchname retry = + do n <- askUser "What is the patch name? " + if badName n + then if retry then prompt_patchname retry + else fail "Bad patch name!" + else return n + + prompt_long_comment oldname = + do y <- promptYorn "Do you want to add a long comment?" + if y then actually_get_log oldname + else return (oldname, [], Nothing) + + actually_get_log p = do let logf = darcsLastMessage + -- TODO: make sure encoding used for logf is the same everywhere + -- probably should be locale because the editor will assume it + writeLocaleFile logf $ unlines $ p : default_log + append_info logf p + _ <- editFile logf + (name,long) <- read_long_comment logf p + if badName name + then do putStrLn "WARNING: empty or incorrect patch name!" + pn <- prompt_patchname True + return (pn, long, Nothing) + else return (name,long,Just logf) + + read_long_comment :: FilePathLike p => p -> String -> IO (String, [String]) + read_long_comment f oldname = + do f' <- readLocaleFile f + let t = filter (not.("#" `isPrefixOf`)) $ (lines.filter (/='\r')) f' + case t of [] -> return (oldname, []) + (n:ls) -> return (n, ls) + + append_info f oldname = + do fc <- readLocaleFile f + appendToFile f $ \h -> + do case fc of + _ | null (lines fc) -> B.hPut h (encodeLocale (oldname ++ "\n")) + | last fc /= '\n' -> B.hPut h (encodeLocale "\n") + | otherwise -> return () + hPutDocLn Encode h + $ text "# Please enter the patch name in the first line, and" + $$ text "# optionally, a long description in the following lines." + $$ text "#" + $$ text "# Lines starting with '#' will be ignored." + $$ text "#" + $$ text "#" + $$ text "# Summary of selected changes:" + $$ text "#" + $$ prefixLines (text "#") (summaryFL chs) + +-- |specify whether to ask about dependencies with respect to a particular repository, or not +data AskAboutDeps rt p wR wU wT = AskAboutDeps (Repository rt p wR wU wT) | NoAskAboutDeps + +-- | Run a job that involves a hijack confirmation prompt. +-- +-- See 'RequestHijackPermission' for initial values +runHijackT :: Monad m => HijackOptions -> HijackT m a -> m a +runHijackT = flip evalStateT + +-- | Update the metadata for a patch. +-- This potentially involves a bit of interactivity, so we may return @Nothing@ +-- if there is cause to abort what we're doing along the way +updatePatchHeader :: forall rt p wX wY wR wU wT . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => String -- ^ verb: command name + -> AskAboutDeps rt p wR wU wT + -> S.PatchSelectionOptions + -> D.DiffAlgorithm + -> Bool -- keepDate + -> Bool -- selectAuthor + -> Maybe String -- author + -> Maybe String -- patchname + -> Maybe O.AskLongComment + -> PatchInfoAnd rt p wT wX + -> FL (PrimOf p) wX wY + -> HijackT IO (Maybe String, PatchInfoAnd rt p wT wY) +updatePatchHeader verb ask_deps pSelOpts da nKeepDate nSelectAuthor nAuthor nPatchname nAskLongComment oldp chs = do + + let newchs = canonizeFL da (effect oldp +>+ chs) + + let old_pdeps = getdeps $ hopefully oldp + newdeps <- + case ask_deps of + AskAboutDeps repository -> liftIO $ askAboutDepends repository newchs pSelOpts old_pdeps + NoAskAboutDeps -> return old_pdeps + + let old_pinf = info oldp + prior = (piName old_pinf, piLog old_pinf) + date <- if nKeepDate then return (piDateString old_pinf) else liftIO $ getDate False + new_author <- getAuthor verb nSelectAuthor nAuthor old_pinf + liftIO $ do + (new_name, new_log, mlogf) <- getLog + nPatchname False (O.Logfile Nothing False) nAskLongComment (Just prior) chs + let maybe_invert = if isInverted old_pinf then invertName else id + new_pinf <- maybe_invert `fmap` patchinfo date new_name new_author new_log + let newp = n2pia (adddeps (infopatch new_pinf (fromPrims newchs)) newdeps) + return (mlogf, newp) + + +-- | @getAuthor@ tries to return the updated author for the patch. +-- There are two different scenarios: +-- +-- * [explicit] Either we want to override the patch author, be it by +-- prompting the user (@select@) or having them pass it in from +-- the UI (@new_author@), or +-- +-- * [implicit] We want to keep the original author, in which case we +-- also double-check that we are not inadvertently \"hijacking\" +-- somebody else's patch (if the patch author is not the same as the +-- repository author, we give them a chance to abort the whole +-- operation) +getAuthor :: String -- ^ verb: command name + -> Bool -- ^ select: prompt for new auhor + -> Maybe String -- ^ new author: explict new author + -> PatchInfo -- ^ patch to update + -> HijackT IO String +getAuthor _ True _ _ = do + auth <- liftIO $ promptAuthor False True + return auth +getAuthor _ False (Just new) _ = + return new +getAuthor verb False Nothing pinfo = do + whitelist <- liftIO $ getEasyAuthor + hj <- get + if orig `elem` whitelist || canIgnore hj + then allowHijack + else do + hijackResp <- liftIO $ askAboutHijack hj + case hijackResp of + 'y' -> allowHijack + 'a' -> put IgnoreHijack >> allowHijack + _ -> liftIO exitSuccess + where + askAboutHijack hj = promptChar (PromptConfig msg opts [] Nothing []) + where + msg = "You're not " ++ orig ++"! " ++ capitalize verb ++ " anyway? " + opts = case hj of + AlwaysRequestHijackPermission -> "yn" + _ -> "yna" + canIgnore IgnoreHijack = True + canIgnore RequestHijackPermission = False + canIgnore AlwaysRequestHijackPermission = False + allowHijack = return orig + orig = piAuthor pinfo diff --git a/src/Darcs/UI/PrintPatch.hs b/src/Darcs/UI/PrintPatch.hs --- a/src/Darcs/UI/PrintPatch.hs +++ b/src/Darcs/UI/PrintPatch.hs @@ -25,8 +25,11 @@ , showFriendly ) where -import Storage.Hashed.Monad( virtualTreeIO ) -import Storage.Hashed.Tree( Tree ) +import Prelude () +import Darcs.Prelude + +import Darcs.Util.Tree.Monad( virtualTreeIO ) +import Darcs.Util.Tree( Tree ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Patch.Apply ( ApplyState ) diff --git a/src/Darcs/UI/RemoteApply.hs b/src/Darcs/UI/RemoteApply.hs deleted file mode 100644 --- a/src/Darcs/UI/RemoteApply.hs +++ /dev/null @@ -1,65 +0,0 @@ --- | This module is used by the push and put commands to apply a bundle to a --- remote repository. By remote I do not necessarily mean a repository on another --- machine, it is just not the repository we're located in. -module Darcs.UI.RemoteApply ( remoteApply ) where - -import System.Exit ( ExitCode ) - -import Darcs.UI.Flags ( DarcsFlag, remoteDarcs, applyAs ) -import Darcs.Util.Text ( breakCommand ) -import Darcs.Util.URL ( isHttpUrl, isSshUrl, splitSshUrl, SshFilePath(..) ) -import Darcs.UI.External - ( darcsProgram - , pipeDoc - , pipeDocSSH - , maybeURLCmd - ) -import Darcs.UI.Options ( parseFlags ) -import Darcs.UI.Options.All ( debug, compress ) -import qualified Darcs.Repository.Ssh as Ssh ( remoteDarcs ) -import Darcs.Util.Printer ( Doc, RenderMode(..) ) - -remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode -remoteApply opts repodir bundle - = case applyAs opts of - Nothing - | isSshUrl repodir -> applyViaSsh opts (splitSshUrl repodir) bundle - | isHttpUrl repodir -> applyViaUrl opts repodir bundle - | otherwise -> applyViaLocal opts repodir bundle - Just un -> if isSshUrl repodir - then applyViaSshAndSudo opts (splitSshUrl repodir) un bundle - else applyViaSudo un repodir bundle - -applyViaSudo :: String -> String -> Doc -> IO ExitCode -applyViaSudo user repo bundle = - darcsProgram >>= \darcs -> - pipeDoc Standard "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle - -applyViaLocal :: [DarcsFlag] -> String -> Doc -> IO ExitCode -applyViaLocal opts repo bundle = - darcsProgram >>= \darcs -> - pipeDoc Standard darcs ("apply":"--all":"--repodir":repo:applyopts opts) bundle - -applyViaUrl :: [DarcsFlag] -> String -> Doc -> IO ExitCode -applyViaUrl opts repo bundle = - do maybeapply <- maybeURLCmd "APPLY" repo - case maybeapply of - Nothing -> applyViaLocal opts repo bundle - Just apply -> - do let (cmd, args) = breakCommand apply - pipeDoc Standard cmd (args ++ [repo]) bundle - -applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode -applyViaSsh opts repo = - pipeDocSSH (parseFlags compress opts) Standard repo - [Ssh.remoteDarcs (remoteDarcs opts) ++" apply --all "++unwords (applyopts opts)++ - " --repodir '"++sshRepo repo++"'"] - -applyViaSshAndSudo :: [DarcsFlag] -> SshFilePath -> String -> Doc -> IO ExitCode -applyViaSshAndSudo opts repo username = - pipeDocSSH (parseFlags compress opts) Standard repo - ["sudo -u "++username++" "++Ssh.remoteDarcs (remoteDarcs opts)++ - " apply --all --repodir '"++sshRepo repo++"'"] - -applyopts :: [DarcsFlag] -> [String] -applyopts opts = if parseFlags debug opts then ["--debug"] else [] diff --git a/src/Darcs/UI/RunCommand.hs b/src/Darcs/UI/RunCommand.hs --- a/src/Darcs/UI/RunCommand.hs +++ b/src/Darcs/UI/RunCommand.hs @@ -20,8 +20,9 @@ -- arguments and then running the command itself. module Darcs.UI.RunCommand ( runTheCommand ) where -import Prelude hiding ( (^) ) -import Data.Functor ((<$>)) +import Prelude () +import Darcs.Prelude + import Data.List ( intercalate ) import Control.Monad ( unless, when ) import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ), @@ -59,7 +60,6 @@ , extractCommands , superName , subusage - , formatPath ) import Darcs.UI.Commands.GZCRCs ( doCRCWarnings ) import Darcs.UI.Commands.Clone ( makeRepoName, cloneToSSH ) @@ -69,15 +69,16 @@ import Darcs.Repository.Test ( runPosthook, runPrehook ) import Darcs.Util.AtExit ( atexit ) import Darcs.Util.Download ( setDebugHTTP, disableHTTPPipelining ) +import Darcs.Util.Exception ( die ) import Darcs.Util.Global ( setDebugMode, setTimingsMode ) import Darcs.Util.Path ( AbsolutePath, getCurrentDirectory, toPath, ioAbsoluteOrRemote, makeAbsolute ) import Darcs.Util.Printer ( text ) import Darcs.Util.Progress ( setProgressMode ) -import Darcs.Util.Text ( chompTrailingNewline ) +import Darcs.Util.Text ( chompTrailingNewline, quote ) runTheCommand :: [CommandControl] -> String -> [String] -> IO () runTheCommand commandControlList cmd args = - either fail rtc $ disambiguateCommands commandControlList cmd args + either die rtc $ disambiguateCommands commandControlList cmd args where rtc (CommandOnly c, as) = runCommand Nothing c as rtc (SuperCommandOnly c, as) = runRawSupercommand c as @@ -86,7 +87,7 @@ runCommand :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> [String] -> IO () runCommand _ _ args -- Check for "dangerous" typoes... | "-all" `elem` args = -- -all indicates --all --look-for-adds! - fail "Are you sure you didn't mean --all rather than -all?" + die "Are you sure you didn't mean --all rather than -all?" runCommand msuper cmd args = do old_wd <- getCurrentDirectory let options = commandOptions old_wd cmd @@ -111,18 +112,18 @@ file_args <- commandGetArgPossibilities cmd putStrLn $ intercalate "\n" $ getOptionsOptions options : file_args Just Disable -> - fail $ "Command "++commandName cmd++" disabled with --disable option!" + die $ "Command "++commandName cmd++" disabled with --disable option!" Nothing -> case prereq_errors of - Left complaint -> fail $ - "Unable to " ++ formatPath ("darcs " ++ superName msuper ++ commandName cmd) ++ + Left complaint -> die $ + "Unable to " ++ quote ("darcs " ++ superName msuper ++ commandName cmd) ++ " here.\n\n" ++ complaint Right () -> case getopt_errs ++ flag_errors of [] -> do extra <- commandArgdefaults cmd flags old_wd orig_extra case extraArgumentsError extra cmd msuper of Nothing -> runWithHooks cmd old_wd flags extra - Just msg -> fail msg - es -> fail (intercalate "\n" es) + Just msg -> die msg + es -> die (intercalate "\n" es) fixupMsgs :: (a, b, [String]) -> (a, b, [String]) fixupMsgs (fs,as,es) = (fs,as,map (("command line: "++).chompTrailingNewline) es) @@ -174,7 +175,7 @@ reponame <- makeRepoName False flags repodir return $ makeAbsolute new_wd reponame _ -> return new_wd - _ -> fail "You must provide 'clone' with either one or two arguments." + _ -> die "You must provide 'clone' with either one or two arguments." getPosthookDir new_wd _ _ _ = return new_wd @@ -210,7 +211,7 @@ runRawSupercommand :: DarcsCommand pf -> [String] -> IO () runRawSupercommand super [] = - fail $ "Command '"++ commandName super ++"' requires a subcommand!\n\n" + die $ "Command '"++ commandName super ++"' requires a subcommand!\n\n" ++ subusage super runRawSupercommand super args = do cwd <- getCurrentDirectory @@ -223,8 +224,8 @@ putStrLn "--help" mapM_ (putStrLn . wrappedCommandName) (extractCommands $ getSubcommands super) Just Disable -> do - fail $ "Command " ++ commandName super ++ + die $ "Command " ++ commandName super ++ " disabled with --disable option!" - Nothing -> fail $ case getopt_errs of + Nothing -> die $ case getopt_errs of [] -> "Invalid subcommand!\n\n" ++ subusage super _ -> intercalate "\n" getopt_errs diff --git a/src/Darcs/UI/SelectChanges.hs b/src/Darcs/UI/SelectChanges.hs --- a/src/Darcs/UI/SelectChanges.hs +++ b/src/Darcs/UI/SelectChanges.hs @@ -20,8 +20,7 @@ module Darcs.UI.SelectChanges ( -- * Working with changes - selectChanges - , WhichChanges(..) + WhichChanges(..) , viewChanges , withSelectedPatchFromRepo , runSelection @@ -55,6 +54,9 @@ , askAboutDepends ) where +import Prelude () +import Darcs.Prelude + import Prelude hiding ( (^) ) import Control.Monad ( liftM, unless, when, (>=>) ) import Control.Monad.Identity ( Identity (..) ) @@ -67,15 +69,14 @@ , modify, runStateT ) import Control.Monad.Trans ( liftIO ) -import Data.Char ( toUpper ) import Data.List ( intercalate, union ) -import Data.Maybe ( isJust, isNothing, catMaybes ) +import Data.Maybe ( isJust, catMaybes ) import System.Exit ( exitSuccess ) import Darcs.Patch - ( Patchy, PrimPatch, RepoPatch, PrimOf + ( Patchy, PrimPatch, IsRepoType, RepoPatch, PrimOf , commuteFLorComplain, invert - , listTouchedFiles, anonymous, fromPrims + , listTouchedFiles, fromPrims ) import qualified Darcs.Patch ( thing, things, summary ) import Darcs.Patch.Apply ( ApplyState ) @@ -95,6 +96,7 @@ import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Invert ( Invert ) import Darcs.Patch.Match ( haveNonrangeMatch, matchAPatch, matchAPatchread ) +import Darcs.Patch.Named.Wrapped ( anonymous ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, n2pia ) import Darcs.Patch.Set ( PatchSet(..), newset2RL ) import Darcs.Patch.Show ( ShowPatch ) @@ -119,15 +121,15 @@ import Darcs.Repository ( Repository, readRepo, readTentativeRepo ) import Darcs.UI.External ( editText ) import Darcs.UI.Options.All - ( Verbosity(..), Summary(..), DiffAlgorithm(..) + ( Verbosity(..), Summary(..) , WithContext(..), SelectDeps(..), MatchFlag ) import Darcs.UI.PrintPatch ( printFriendly, printPatch , printPatchPager, showFriendly ) -import Darcs.Util.English ( Noun (..), englishNum ) +import Darcs.Util.English ( Noun (..), englishNum, capitalize ) import Darcs.Util.Printer ( prefix, putDocLn ) import Darcs.Util.Prompt ( PromptConfig (..), askUser, promptChar ) -import Storage.Hashed.Tree ( Tree ) +import Darcs.Util.Tree ( Tree ) -- | When asking about patches, we either ask about them in @@ -166,7 +168,6 @@ data PatchSelectionOptions = PatchSelectionOptions { verbosity :: Verbosity , matchFlags :: [MatchFlag] - , diffAlgorithm :: DiffAlgorithm , interactive :: Bool , selectDeps :: SelectDeps , summary :: Summary @@ -206,8 +207,8 @@ } -- | A 'PatchSelectionContext' for selecting full patches ('PatchInfoAnd' patches) -selectionContext :: (RepoPatch p) => WhichChanges -> String -> PatchSelectionOptions -> Maybe (Splitter (PatchInfoAnd p)) - -> Maybe [FilePath] -> PatchSelectionContext (PatchInfoAnd p) +selectionContext :: (IsRepoType rt, RepoPatch p) => WhichChanges -> String -> PatchSelectionOptions -> Maybe (Splitter (PatchInfoAnd rt p)) + -> Maybe [FilePath] -> PatchSelectionContext (PatchInfoAnd rt p) selectionContext whch jn o spl fs = PSC { opts = o , splitter = spl @@ -220,8 +221,8 @@ } -- | A generic 'PatchSelectionContext'. -selectionContextGeneric :: (RepoPatch p, Invert q) - => (forall wX wY . q wX wY -> Sealed2 (PatchInfoAnd p)) +selectionContextGeneric :: (IsRepoType rt, RepoPatch p, Invert q) + => (forall wX wY . q wX wY -> Sealed2 (PatchInfoAnd rt p)) -> WhichChanges -> String -> PatchSelectionOptions @@ -265,13 +266,13 @@ triv = MatchCriterion { mcHasNonrange = False, mcFunction = \ _ _ -> True } -- | 'iswanted' selects patches according to the given match flags -iswanted :: forall p q - . (RepoPatch p, Invert q) - => (forall wX wY . q wX wY -> Sealed2 (PatchInfoAnd p)) +iswanted :: forall rt p q + . (IsRepoType rt, RepoPatch p, Invert q) + => (forall wX wY . q wX wY -> Sealed2 (PatchInfoAnd rt p)) -> [MatchFlag] -> MatchCriterion q iswanted extract mflags = MatchCriterion - { mcHasNonrange = haveNonrangeMatch (PatchType :: PatchType p) mflags + { mcHasNonrange = haveNonrangeMatch (PatchType :: PatchType rt p) mflags , mcFunction = isWantedMcFunction } where @@ -285,32 +286,31 @@ liftR = asks . runReader -- | runs a 'PatchSelection' action in the given 'PatchSelectionContext'. -runSelection :: (Patchy p) => PatchSelection p wX wY -> PatchSelectionContext p +runSelection :: forall p wX wY . (Patchy p, PatchInspect p, ShowPatch p, ApplyState p ~ Tree) + => FL p wX wY + -> PatchSelectionContext p -> IO ((FL p :> FL p) wX wY) -runSelection = runReaderT - --- | Select patches from a @FL@. -selectChanges :: forall p wX wY . (Patchy p, PatchInspect p, ShowPatch p, ApplyState p ~ Tree) => - FL p wX wY - -> PatchSelection p wX wY -selectChanges ps = do - whch <- asks whichChanges - case whch of +runSelection ps psc = runReaderT patchSelection psc + where + patchSelection = do + case whichChanges psc of First -> normal ps Last -> normal ps FirstReversed -> reversed ps LastReversed -> reversed ps - where normal = sc1 - reversed = return . invert >=> sc1 >=> return . invertC + normal fl = sc1 fl + reversed fl = do let ifl = invert fl + choices_ <- sc1 ifl + return $ invertC choices_ sc1 :: forall p wX wY . (Patchy p, PatchInspect p, ShowPatch p, ApplyState p ~ Tree) => FL p wX wY -> PatchSelection p wX wY -sc1 = - (liftR . patchesToConsider) - >=> realSelectChanges - >=> (\ps -> do whch <- asks whichChanges ; return $ selectedPatches whch ps) - >=> (liftR . canonizeAfterSplitter) +sc1 fl = do ps <- liftR (patchesToConsider fl) + patchChoices_ <- realSelectChanges ps + whch <- asks whichChanges + let sps = selectedPatches whch patchChoices_ + liftR (canonizeAfterSplitter sps) -- | inverses the choices that have been made invertC :: (Patchy p) => (FL p :> FL p) wX wY -> (FL p :> FL p) wY wX @@ -324,7 +324,7 @@ repr Last (Sealed2 p) = Sealed2 p repr FirstReversed (Sealed2 p) = Sealed2 (invert p) --- | The equivalent of 'selectChanges' for the @darcs changes@ command +-- | The equivalent of 'runSelection' for the @darcs log@ command viewChanges :: (Patchy p, ShowPatch p, ApplyState p ~ Tree) => PatchSelectionOptions -> [Sealed2 p] -> IO () viewChanges ps_opts = textView ps_opts Nothing 0 [] @@ -353,11 +353,11 @@ -- | The function for selecting a patch to amend record. Read at your own risks. withSelectedPatchFromRepo :: - forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree) + forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => String -- name of calling command (always "amend" as of now) - -> Repository p wR wU wT + -> Repository rt p wR wU wT -> PatchSelectionOptions - -> (forall wA . (FL (PatchInfoAnd p) :> PatchInfoAnd p) wA wR -> IO ()) + -> (forall wA . (FL (PatchInfoAnd rt p) :> PatchInfoAnd rt p) wA wR -> IO ()) -> IO () withSelectedPatchFromRepo jn repository o job = do patchSet <- readRepo repository @@ -374,14 +374,14 @@ -- | This ensures that the selected patch commutes freely with the skipped -- patches, including pending and also that the skipped sequences has an -- ending context that matches the recorded state, z, of the repository. -wspfr :: forall p wX wY wU. (RepoPatch p, ApplyState p ~ Tree) +wspfr :: forall rt p wX wY wU. (RepoPatch p, ApplyState p ~ Tree) => String - -> (forall wA wB . (PatchInfoAnd p) wA wB -> Bool) - -> RL (PatchInfoAnd p) wX wY - -> FL (WithSkipped (PatchInfoAnd p)) wY wU - -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd p) :> PatchInfoAnd p) wU)) + -> (forall wA wB . (PatchInfoAnd rt p) wA wB -> Bool) + -> RL (PatchInfoAnd rt p) wX wY + -> FL (WithSkipped (PatchInfoAnd rt p)) wY wU + -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd rt p) :> PatchInfoAnd rt p) wU)) wspfr _ _ NilRL _ = return Nothing -wspfr jn matches remaining@(p:<:pps) skipped +wspfr jn matches remaining@(pps:<:p) skipped | not $ matches p = wspfr jn matches pps (WithSkipped SkippedAutomatically p :>: skipped) | otherwise = @@ -407,22 +407,21 @@ 'p' -> printPatchPager p >> repeatThis 'x' -> do putDocLn $ prefix " " $ Darcs.Patch.summary p repeatThis - 'q' -> do putStrLn $ jnCapital ++ " cancelled." + 'q' -> do putStrLn $ (capitalize jn) ++ " cancelled." exitSuccess _ -> do putStrLn $ helpFor jn basicOptions advancedOptions repeatThis - where jnCapital = toUpper (head jn) : tail jn - repeatThis = wspfr jn matches (p:<:pps) skipped + where repeatThis = wspfr jn matches (pps:<:p) skipped prompt' = "Shall I " ++ jn ++ " this patch?" nextPatch = wspfr jn matches pps (WithSkipped SkippedManually p:>:skipped) - previousPatch :: RL (PatchInfoAnd p) wX wQ - -> FL (WithSkipped (PatchInfoAnd p)) wQ wU - -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd p) :> PatchInfoAnd p) wU)) + previousPatch :: RL (PatchInfoAnd rt p) wX wQ + -> FL (WithSkipped (PatchInfoAnd rt p)) wQ wU + -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd rt p) :> PatchInfoAnd rt p) wU)) previousPatch remaining' NilFL = wspfr jn matches remaining' NilFL previousPatch remaining' (WithSkipped sk prev :>: skipped'') = case sk of - SkippedManually -> wspfr jn matches (prev :<: remaining') skipped'' - SkippedAutomatically -> previousPatch (prev :<: remaining') skipped'' + SkippedManually -> wspfr jn matches (remaining' :<: prev) skipped'' + SkippedAutomatically -> previousPatch (remaining' :<: prev) skipped'' basicOptions = [[ KeyPress 'y' (jn ++ " this patch") , KeyPress 'n' ("don't " ++ jn ++ " it") @@ -441,11 +440,9 @@ -- After selecting with a splitter, the results may not be canonical canonizeAfterSplitter :: (FL p :> FL p) wX wY -> Reader (PatchSelectionContext p) ((FL p :> FL p) wX wY) canonizeAfterSplitter (x :> y) = - do o <- asks opts - mspl <- asks splitter - let canonizeIfNeeded = maybe (\_ b -> b) canonizeSplit mspl - da = diffAlgorithm o - return $ canonizeIfNeeded da x :> canonizeIfNeeded da y + do mspl <- asks splitter + let canonizeIfNeeded = maybe id canonizeSplit mspl + return $ canonizeIfNeeded x :> canonizeIfNeeded y realSelectChanges :: forall p wX wY. (Patchy p, ShowPatch p, PatchInspect p, ApplyState p ~ Tree) @@ -512,10 +509,15 @@ FirstReversed -> TouchesFiles.selectNotTouching LastReversed -> TouchesFiles.deselectNotTouching everything = patchChoices ps - if isNothing fs && not (mcHasNonrange crit) - then return everything - else do notUnwanted <- deselectUnwanted everything - return $ deselectNotTouching fs notUnwanted + -- first filter patches by matchers + -- this often requires to read only metadata + notUnwanted <- if not (mcHasNonrange crit) + then return everything + else deselectUnwanted everything + -- if there are path restrictions, we need to read patch contents + -- of what remains + return $ if isJust fs then deselectNotTouching fs notUnwanted + else notUnwanted -- | Returns the results of a patch selection user interaction selectedPatches :: Patchy p => WhichChanges -> PatchChoices p wY wZ @@ -733,8 +735,7 @@ -> InteractiveSelectionM p wX wY () splitCurrent s = do FZipper lps_done (lp:>:lps_todo) <- gets lps - o <- asks opts - case applySplitter s (diffAlgorithm o) (lpPatch lp) of + case applySplitter s (lpPatch lp) of Nothing -> return () Just (text, parse) -> do @@ -858,9 +859,7 @@ reprCur = repr whichch (Sealed2 (lpPatch lp)) (basicOptions,advancedOptions) <- options singleFile theSlot <- liftChoices $ patchSlot' lp - let - the_default = getDefault (whichch == Last || whichch == FirstReversed) theSlot - jnCapital = toUpper (head jn) : tail jn + let the_default = getDefault (whichch == Last || whichch == FirstReversed) theSlot yorn <- promptUser singleFile the_default let nextPatch = skipMundane >> showCur case yorn of @@ -893,7 +892,7 @@ skipAll return True 'q' -> liftIO $ - do putStrLn $ jnCapital++" cancelled." + do putStrLn $ capitalize jn ++ " cancelled." exitSuccess 'j' -> skipOne >> showCur >> return False 'k' -> backOne >> showCur >> return False @@ -909,7 +908,7 @@ aThing <- thing let (basicOptions, advancedOptions) = optionsLast jn aThing yorn <- liftIO . promptChar $ - PromptConfig { pPrompt = "Do you want to "++jn++" these "++ theThings++"?" + PromptConfig { pPrompt = "Do you want to "++capitalize jn++" these "++theThings++"?" , pBasicCharacters = "yglqk" , pAdvancedCharacters = "dan" , pDefault = Just 'y' @@ -1030,7 +1029,7 @@ boring :> interesting -> do justDone $ lengthFL boring + numSkipped - modify $ \isc -> isc {lps = FZipper (reverseFL boring +<+ reverseFL skipped +<+ lps_done) interesting} + modify $ \isc -> isc {lps = FZipper (lps_done +<+ reverseFL skipped +<+ reverseFL boring) interesting} where show_skipped o jn n ps = do putStrLn $ _nevermind_ jn ++ _these_ n ++ "." when (verbosity o == Verbose) $ @@ -1055,8 +1054,8 @@ getDefault False InFirst = 'y' getDefault False InLast = 'n' -askAboutDepends :: forall p wR wU wT wY . (RepoPatch p, ApplyState p ~ Tree) - => Repository p wR wU wT -> FL (PrimOf p) wT wY +askAboutDepends :: forall rt p wR wU wT wY . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) + => Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> PatchSelectionOptions -> [PatchInfo] -> IO [PatchInfo] askAboutDepends repository pa' ps_opts olddeps = do @@ -1068,8 +1067,8 @@ -- FIXME: this code is completely unreadable FlippedSeal ps <- return ((case pps of - PatchSet x _ -> FlippedSeal (reverseRL x+>+(pa:>:NilFL))) - :: FlippedSeal (FL (PatchInfoAnd p)) wY) + PatchSet _ x -> FlippedSeal (reverseRL x+>+(pa:>:NilFL))) + :: FlippedSeal (FL (PatchInfoAnd rt p)) wY) let (pc, my_lps) = patchChoicesLps ps tas = case catMaybes (mapFL (\lp -> if pa `unsafeCompare` lpPatch lp || info (lpPatch lp) `elem` olddeps then Just (label lp) else Nothing) my_lps) of @@ -1077,7 +1076,7 @@ [] -> error "askAboutDepends: []" tgs -> tgs Sealed2 ps' <- return $ case getChoices (forceFirsts tas pc) of _ :> mc :> _ -> Sealed2 $ mapFL_FL lpPatch mc - (deps:>_) <- runSelection (selectChanges ps') $ + (deps:>_) <- runSelection ps' $ selectionContext FirstReversed "depend on" ps_opts { matchFlags = [], interactive = True } Nothing Nothing return $ olddeps `union` mapFL info deps {- diff --git a/src/Darcs/UI/TheCommands.hs b/src/Darcs/UI/TheCommands.hs --- a/src/Darcs/UI/TheCommands.hs +++ b/src/Darcs/UI/TheCommands.hs @@ -19,6 +19,7 @@ module Darcs.UI.TheCommands ( commandControlList ) where import Prelude () + import Darcs.UI.Commands.Add ( add ) import Darcs.UI.Commands.Amend ( amend, amendrecord ) import Darcs.UI.Commands.Annotate ( annotate ) @@ -30,7 +31,7 @@ import Darcs.UI.Commands.GZCRCs ( gzcrcs ) import Darcs.UI.Commands.Init ( initialize ) import Darcs.UI.Commands.Log ( log, changes ) -import Darcs.UI.Commands.Show ( showCommand, list, query ) +import Darcs.UI.Commands.Show ( showCommand ) import Darcs.UI.Commands.MarkConflicts ( markconflicts ) import Darcs.UI.Commands.Move ( move, mv ) import Darcs.UI.Commands.Optimize ( optimize ) @@ -58,45 +59,45 @@ -- are also listed here. commandControlList :: [CommandControl] commandControlList = - [ commandGroup "Changing and querying the working copy:" + [ commandGroup "Most used/starting out:" + , normalCommand initialize , normalCommand add - , normalCommand remove, hiddenCommand unadd, hiddenCommand rm + , normalCommand whatsnew, hiddenCommand status + , normalCommand record, hiddenCommand commit + , normalCommand clone, hiddenCommand get, hiddenCommand put + , normalCommand pull + , normalCommand push + , commandGroup "Preparing patches before recording:" , normalCommand move, hiddenCommand mv + , normalCommand remove, hiddenCommand unadd, hiddenCommand rm , normalCommand replace + , commandGroup "Querying the repository:" + , normalCommand log, hiddenCommand changes + , normalCommand annotate + , normalCommand diffCommand + , normalCommand showCommand + , normalCommand test + , commandGroup "Undoing and correcting:" , normalCommand revert , normalCommand unrevert - , normalCommand whatsnew, hiddenCommand status - , commandGroup "Copying changes between the working copy and the repository:" - , normalCommand record, hiddenCommand commit + , normalCommand amend, hiddenCommand amendrecord + , normalCommand rebase + , normalCommand rollback , normalCommand unrecord - , normalCommand amend - , hiddenCommand amendrecord - , normalCommand markconflicts + , normalCommand obliterate, hiddenCommand unpull , commandGroup "Direct modification of the repository:" , normalCommand tag , normalCommand setpref - , commandGroup "Querying the repository:" - , normalCommand diffCommand - , normalCommand log, hiddenCommand changes - , normalCommand annotate - , normalCommand dist - , normalCommand test - , normalCommand showCommand, hiddenCommand list, hiddenCommand query - , hiddenCommand transferMode - , commandGroup "Copying patches between repositories with working copy update:" - , normalCommand pull - , normalCommand fetch - , normalCommand obliterate, hiddenCommand unpull - , normalCommand rollback - , normalCommand push + , commandGroup "Exchanging patches by e-mail:" , normalCommand send , normalCommand apply - , normalCommand clone, hiddenCommand get, hiddenCommand put - , commandGroup "Administrating repositories:" - , normalCommand initialize + , commandGroup "Other commands:" , normalCommand optimize + , normalCommand dist + , normalCommand markconflicts , normalCommand repair, hiddenCommand check , normalCommand convert + , normalCommand fetch , hiddenCommand gzcrcs - , normalCommand rebase + , hiddenCommand transferMode ] diff --git a/src/Darcs/UI/Usage.hs b/src/Darcs/UI/Usage.hs --- a/src/Darcs/UI/Usage.hs +++ b/src/Darcs/UI/Usage.hs @@ -10,6 +10,10 @@ -- @ module Darcs.UI.Usage ( usageInfo ) where + +import Prelude () +import Darcs.Prelude + import Data.Functor.Compose import System.Console.GetOpt( OptDescr(..), ArgDescr(..) ) import Darcs.UI.Options ( DarcsOptDescr ) diff --git a/src/Darcs/Util/AtExit.hs b/src/Darcs/Util/AtExit.hs --- a/src/Darcs/Util/AtExit.hs +++ b/src/Darcs/Util/AtExit.hs @@ -36,6 +36,8 @@ , withAtexit ) where +import Prelude () +import Darcs.Prelude import Control.Concurrent.MVar import Control.Exception @@ -44,8 +46,6 @@ ) import System.IO.Unsafe (unsafePerformIO) import System.IO ( hPutStrLn, stderr, hPrint ) -import Prelude hiding (catch) - atexitActions :: MVar (Maybe [IO ()]) atexitActions = unsafePerformIO (newMVar (Just [])) diff --git a/src/Darcs/Util/Bug.hs b/src/Darcs/Util/Bug.hs --- a/src/Darcs/Util/Bug.hs +++ b/src/Darcs/Util/Bug.hs @@ -3,6 +3,9 @@ ( _bug, _bugDoc, _impossible, _fromJust ) where +import Prelude () +import Darcs.Prelude + import Data.Maybe(fromMaybe) import Darcs.Util.Printer ( Doc, errorDoc, text, ($$) ) diff --git a/src/Darcs/Util/ByteString.hs b/src/Darcs/Util/ByteString.hs --- a/src/Darcs/Util/ByteString.hs +++ b/src/Darcs/Util/ByteString.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- @@ -30,6 +29,8 @@ gzWriteFilePSs, gzReadStdin, gzWriteHandle, + FileSegment, + readSegment, -- gzip handling isGZFile, @@ -60,10 +61,13 @@ decodeString ) where -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude + import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.ByteString (intercalate) import Data.ByteString.Internal (fromForeignPtr) @@ -71,7 +75,10 @@ #else import Control.Exception ( catch, SomeException ) #endif -import System.IO +import System.IO ( withFile, IOMode(ReadMode) + , hSeek, SeekMode(SeekFromEnd,AbsoluteSeek) + , openBinaryFile, hClose, Handle, hGetChar + , stdin) import System.IO.Unsafe ( unsafePerformIO ) import Foreign.Storable ( peek ) @@ -81,7 +88,7 @@ import Data.Bits ( rotateL ) import Data.Char ( ord, isSpace ) import Data.Word ( Word8 ) -import Data.Int ( Int32 ) +import Data.Int ( Int32, Int64 ) import qualified Data.Text as T ( pack, unpack ) import Data.Text.Encoding ( encodeUtf8, decodeUtf8With ) import Data.Text.Encoding.Error ( lenientDecode ) @@ -110,6 +117,7 @@ import System.Mem( performGC ) import System.Posix.Files( fileSize, getSymbolicLinkStatus ) #endif +import qualified Bundled.Posix as Bundled ( getFileStatus, fileSize ) -- ----------------------------------------------------------------------------- -- obsolete debugging code @@ -395,6 +403,29 @@ compressed = BL.fromChunks [allStdin] in B.concat $ decompress compressed + +-- | Pointer to a filesystem, possibly with start/end offsets. Supposed to be +-- fed to (uncurry mmapFileByteString) or similar. +type FileSegment = (FilePath, Maybe (Int64, Int)) + +-- | Read in a FileSegment into a Lazy ByteString. Implemented using mmap. +readSegment :: FileSegment -> IO BL.ByteString +readSegment (f,range) = do + bs <- tryToRead + `catch` (\(_::SomeException) -> do + size <- Bundled.fileSize `fmap` Bundled.getFileStatus f + if size == 0 + then return BC.empty + else performGC >> tryToRead) + return $ BL8.fromChunks [bs] + where + tryToRead = + case range of + Nothing -> B.readFile f + Just (off, size) -> withFile f ReadMode $ \h -> do + hSeek h AbsoluteSeek $ fromIntegral off + B.hGet h size +{-# INLINE readSegment #-} -- ----------------------------------------------------------------------------- -- mmapFilePS diff --git a/src/Darcs/Util/CommandLine.hs b/src/Darcs/Util/CommandLine.hs --- a/src/Darcs/Util/CommandLine.hs +++ b/src/Darcs/Util/CommandLine.hs @@ -56,6 +56,9 @@ , addUrlencoded ) where +import Prelude () +import Darcs.Prelude + import Control.Arrow ( (***) ) import Data.Char ( ord, intToDigit, toUpper ) import Data.List ( find ) diff --git a/src/Darcs/Util/Compat.hs b/src/Darcs/Util/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Util/Compat.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +module Darcs.Util.Compat + ( stdoutIsAPipe + , mkStdoutTemp + , canonFilename + , maybeRelink + , atomicCreate + , sloppyAtomicCreate + ) where + +import Prelude () +import Darcs.Prelude + +import Darcs.Util.File ( withCurrentDirectory ) +#ifdef WIN32 +import Data.Bits ( (.&.) ) +import System.Random ( randomIO ) +import Numeric ( showHex ) +#else +#endif + +import Control.Monad ( unless ) +import Foreign.C.Types ( CInt(..) ) +import Foreign.C.String ( CString, withCString +#ifndef WIN32 + , peekCString +#endif + ) + +import Foreign.C.Error ( throwErrno, eEXIST, getErrno ) +import System.Directory ( getCurrentDirectory ) +import System.IO ( hFlush, stdout, stderr, hSetBuffering, + BufferMode(NoBuffering) ) +import System.IO.Error ( mkIOError, alreadyExistsErrorType ) +import System.Posix.Files ( stdFileMode ) +import System.Posix.IO ( openFd, closeFd, stdOutput, stdError, + dupTo, defaultFileFlags, exclusive, + OpenMode(WriteOnly) ) +import System.Posix.Types ( Fd(..) ) + +import Darcs.Util.SignalHandler ( stdoutIsAPipe ) + +canonFilename :: FilePath -> IO FilePath +canonFilename f@(_:':':_) = return f -- absolute windows paths +canonFilename f@('/':_) = return f +canonFilename ('.':'/':f) = do cd <- getCurrentDirectory + return $ cd ++ "/" ++ f +canonFilename f = case reverse $ dropWhile (/='/') $ reverse f of + "" -> fmap (++('/':f)) getCurrentDirectory + rd -> withCurrentDirectory rd $ + do fd <- getCurrentDirectory + return $ fd ++ "/" ++ simplefilename + where + simplefilename = reverse $ takeWhile (/='/') $ reverse f + +#ifdef WIN32 +mkstempCore :: FilePath -> IO (Fd, String) +mkstempCore fp + = do r <- randomIO + let fp' = fp ++ showHexLen 6 (r .&. 0xFFFFFF :: Int) + fd <- openFd fp' WriteOnly (Just stdFileMode) flags + return (fd, fp') + where flags = defaultFileFlags { exclusive = True } + +showHexLen :: (Integral a, Show a) + => Int + -> a + -> String +showHexLen n x = let s = showHex x "" + in replicate (n - length s) ' ' ++ s +#else +mkstempCore :: String -> IO (Fd, String) +mkstempCore str = withCString (str++"XXXXXX") $ + \cstr -> do fd <- c_mkstemp cstr + if fd < 0 + then throwErrno $ "Failed to create temporary file "++str + else do str' <- peekCString cstr + fname <- canonFilename str' + return (Fd fd, fname) + +foreign import ccall unsafe "static stdlib.h mkstemp" + c_mkstemp :: CString -> IO CInt +#endif + +mkStdoutTemp :: String -> IO String +mkStdoutTemp str = do (fd, fn) <- mkstempCore str + hFlush stdout + hFlush stderr + _ <- dupTo fd stdOutput + _ <- dupTo fd stdError + hFlush stdout + hFlush stderr + hSetBuffering stdout NoBuffering + hSetBuffering stderr NoBuffering + return fn + + + +foreign import ccall unsafe "maybe_relink.h maybe_relink" maybe_relink + :: CString -> CString -> CInt -> IO CInt + +-- Checks whether src and dst are identical. If so, makes dst into a +-- link to src. Returns True if dst is a link to src (either because +-- we linked it or it already was). Safe against changes to src if +-- they are not in place, but not to dst. +maybeRelink :: String -> String -> IO Bool +maybeRelink src dst = + withCString src $ \csrc -> + withCString dst $ \cdst -> + do rc <- maybe_relink csrc cdst 1 + case rc of + 0 -> return True + 1 -> return True + -1 -> throwErrno ("Relinking " ++ dst) + -2 -> return False + -3 -> do putStrLn ("Relinking: race condition avoided on file " ++ + dst) + return False + _ -> fail ("Unexpected situation when relinking " ++ dst) + +sloppyAtomicCreate :: FilePath -> IO () +sloppyAtomicCreate fp + = do fd <- openFd fp WriteOnly (Just stdFileMode) flags + closeFd fd + where flags = defaultFileFlags { exclusive = True } + +atomicCreate :: FilePath -> IO () +atomicCreate fp = withCString fp $ \cstr -> do + rc <- c_atomic_create cstr + unless (rc >= 0) $ + do errno <- getErrno + pwd <- getCurrentDirectory + if errno == eEXIST + then ioError $ mkIOError alreadyExistsErrorType + ("atomicCreate in "++pwd) + Nothing (Just fp) + else throwErrno $ "atomicCreate "++fp++" in "++pwd + +foreign import ccall unsafe "atomic_create.h atomic_create" c_atomic_create + :: CString -> IO CInt diff --git a/src/Darcs/Util/Crypt/SHA1.hs b/src/Darcs/Util/Crypt/SHA1.hs --- a/src/Darcs/Util/Crypt/SHA1.hs +++ b/src/Darcs/Util/Crypt/SHA1.hs @@ -30,6 +30,9 @@ module Darcs.Util.Crypt.SHA1 ( sha1PS, SHA1(..), showAsHex, sha1Xor, zero ) where +import Prelude () +import Darcs.Prelude + import Darcs.Util.ByteString (unsafeWithInternals) import qualified Data.ByteString as B (ByteString, pack, length, concat) import Data.Binary ( Binary(..) ) diff --git a/src/Darcs/Util/Crypt/SHA256.hs b/src/Darcs/Util/Crypt/SHA256.hs --- a/src/Darcs/Util/Crypt/SHA256.hs +++ b/src/Darcs/Util/Crypt/SHA256.hs @@ -1,5 +1,8 @@ module Darcs.Util.Crypt.SHA256 ( sha256sum ) where +import Prelude () +import Darcs.Prelude + import Crypto.Hash.SHA256 ( hash ) import Data.ByteString ( ByteString ) import Data.ByteString.Base16 ( encode ) diff --git a/src/Darcs/Util/DateMatcher.hs b/src/Darcs/Util/DateMatcher.hs --- a/src/Darcs/Util/DateMatcher.hs +++ b/src/Darcs/Util/DateMatcher.hs @@ -33,6 +33,9 @@ , getMatchers ) where +import Prelude () +import Darcs.Prelude + import Control.Exception ( catchJust ) import Data.Maybe ( isJust ) diff --git a/src/Darcs/Util/DateTime.hs b/src/Darcs/Util/DateTime.hs --- a/src/Darcs/Util/DateTime.hs +++ b/src/Darcs/Util/DateTime.hs @@ -12,6 +12,9 @@ , formatDateTime, fromClockTime, parseDateTime, startOfTime ) where +import Prelude () +import Darcs.Prelude + import qualified Data.Time.Calendar as Calendar ( fromGregorian ) import Data.Time.Clock ( UTCTime(UTCTime), UniversalTime(ModJulianDate) diff --git a/src/Darcs/Util/Diff.hs b/src/Darcs/Util/Diff.hs --- a/src/Darcs/Util/Diff.hs +++ b/src/Darcs/Util/Diff.hs @@ -3,6 +3,9 @@ , DiffAlgorithm(..) ) where +import Prelude () +import Darcs.Prelude + import qualified Darcs.Util.Diff.Myers as M ( getChanges ) import qualified Darcs.Util.Diff.Patience as P ( getChanges ) import qualified Data.ByteString as B ( ByteString ) diff --git a/src/Darcs/Util/Diff/Myers.hs b/src/Darcs/Util/Diff/Myers.hs --- a/src/Darcs/Util/Diff/Myers.hs +++ b/src/Darcs/Util/Diff/Myers.hs @@ -60,6 +60,9 @@ , getSlice ) where +import Prelude () +import Darcs.Prelude + import Control.Monad import Data.Int import Control.Monad.ST diff --git a/src/Darcs/Util/Diff/Patience.hs b/src/Darcs/Util/Diff/Patience.hs --- a/src/Darcs/Util/Diff/Patience.hs +++ b/src/Darcs/Util/Diff/Patience.hs @@ -20,6 +20,9 @@ ( getChanges ) where +import Prelude () +import Darcs.Prelude + import Data.List ( sort ) import Data.Array.Unboxed import Data.Array.ST @@ -27,11 +30,7 @@ import qualified Data.Set as S import qualified Data.ByteString as B ( ByteString, elem ) import qualified Data.ByteString.Char8 as BC ( pack ) -#ifdef USE_LOCAL_DATA_MAP_STRICT -import qualified Darcs.Data.Map.Strict as M -#else import qualified Data.Map.Strict as M -#endif ( Map, lookup, insertWith, empty, elems ) import qualified Data.Hashable as H ( hash ) import Darcs.Util.Diff.Myers (initP, aLen, PArray, getSlice) @@ -102,7 +101,7 @@ --Given a HunkMap, check collisions and return the line with an updated Map toHunk' :: HunkMap -> B.ByteString -> (Hunk, HunkMap) toHunk' lmap bs | oldbs == Nothing || null oldhunkpair = insert hash bs lmap - | otherwise = (fst $ head $ oldhunkpair, lmap) + | otherwise = (fst $ head oldhunkpair, lmap) where hash = H.hash bs oldbs = M.lookup hash (getMap lmap) oldhunkpair = filter ((== bs) . snd) $ fromJust oldbs @@ -111,7 +110,7 @@ listToHunk [] hmap = ([], hmap) listToHunk (x:xs) hmap = let (y, hmap') = toHunk' hmap x (ys, hmap'') = listToHunk xs hmap' - in ((y:ys), hmap'') + in (y:ys, hmap'') --listToHunk :: [B.ByteString] -> HunkMap -> ([Hunk], HunkMap) --listToHunk = listToHunk' [] @@ -149,7 +148,7 @@ borings' = map BC.pack ["", "\n", " ", ")", "(", ","] byparagraph :: [Hunk] -> [[Hunk]] -byparagraph = reverse . (map reverse) . byparagraphAcc [] +byparagraph = reverse . map reverse . byparagraphAcc [] where byparagraphAcc xs [] = xs byparagraphAcc [] (a:b:c:d) | a == nl && c == nl && b == hnull = case d of @@ -158,7 +157,7 @@ byparagraphAcc [] (a:as) = byparagraphAcc [[a]] as byparagraphAcc (x:xs) (a:b:c:d) | a == nl && c == nl && b == hnull = case d of - [] -> ((c:b:a:x):xs) + [] -> (c:b:a:x):xs _ -> byparagraphAcc ([]:((c:b:a:x):xs)) d byparagraphAcc (x:xs) (a:as) = byparagraphAcc ((a:x):xs) as nl = -1 -- "\n" hunk @@ -189,27 +188,27 @@ ([a] -> Bool) -> Int -> [a] -> [a] -> [a] -> [(Int,[a],[a])] mkdiff b ny (l:ls) (x:xs) (y:ys) | l == x && l == y = mkdiff b (ny+1) ls xs ys -mkdiff boring ny (l:ls) xs ys = - if rmd == add - then mkdiff boring (ny+length add+1) ls restx resty - else if boring rmd && boring add - then case lcs rmd add of - [] -> prefixPostfixDiff ny rmd add ++ - mkdiff boring (ny+length add+1) ls restx resty - ll -> mkdiff (const False) ny ll rmd add ++ - mkdiff boring (ny+length add+1) ls restx resty - else prefixPostfixDiff ny rmd add ++ - mkdiff boring (ny+length add+1) ls restx resty +mkdiff boring ny (l:ls) xs ys + | rmd == add = mkdiff boring (ny+length add+1) ls restx resty + | boring rmd && boring add = + case lcs rmd add of + [] -> prefixPostfixDiff ny rmd add ++ + mkdiff boring (ny+length add+1) ls restx resty + ll -> mkdiff (const False) ny ll rmd add ++ + mkdiff boring (ny+length add+1) ls restx resty + | otherwise = prefixPostfixDiff ny rmd add ++ + mkdiff boring (ny+length add+1) ls restx resty where rmd = takeWhile (/= l) xs add = takeWhile (/= l) ys restx = drop (length rmd + 1) xs resty = drop (length add + 1) ys mkdiff _ _ [] [] [] = [] -mkdiff boring ny [] rmd add = - if boring rmd && boring add - then case lcs rmd add of [] -> prefixPostfixDiff ny rmd add - ll -> mkdiff (const False) ny ll rmd add - else prefixPostfixDiff ny rmd add +mkdiff boring ny [] rmd add + | boring rmd && boring add = + case lcs rmd add of + [] -> prefixPostfixDiff ny rmd add + ll -> mkdiff (const False) ny ll rmd add + | otherwise = prefixPostfixDiff ny rmd add prefixPostfixDiff :: Ord a => Int -> [a] -> [a] -> [(Int,[a],[a])] prefixPostfixDiff _ [] [] = [] @@ -302,81 +301,79 @@ lcs (c1:c1s) (c2:c2s) | c1 == c2 = c1: lcs c1s c2s | otherwise = - reverse $ lcs_simple (reverse (c1:c1s)) (reverse (c2:c2s)) + reverse $ lcsSimple (reverse (c1:c1s)) (reverse (c2:c2s)) -lcs_simple :: Ord a => [a] -> [a] -> [a] -lcs_simple [] _ = [] -lcs_simple _ [] = [] -lcs_simple s1@(c1:c1s) s2@(c2:c2s) +lcsSimple :: Ord a => [a] -> [a] -> [a] +lcsSimple [] _ = [] +lcsSimple _ [] = [] +lcsSimple s1@(c1:c1s) s2@(c2:c2s) | c1 == c2 = c1: lcs c1s c2s - | otherwise = hunt $ prune_matches s1 $! find_matches s1 s2 + | otherwise = hunt $ pruneMatches s1 $! findMatches s1 s2 -prune_matches :: [a] -> [[Int]] -> [(a, [Int])] -prune_matches _ [] = [] -prune_matches [] _ = [] -prune_matches (_:cs) ([]:ms) = prune_matches cs ms -prune_matches (c:cs) (m:ms) = (c,m): prune_matches cs ms +pruneMatches :: [a] -> [[Int]] -> [(a, [Int])] +pruneMatches _ [] = [] +pruneMatches [] _ = [] +pruneMatches (_:cs) ([]:ms) = pruneMatches cs ms +pruneMatches (c:cs) (m:ms) = (c,m): pruneMatches cs ms type Threshold s a = STArray s Int (Int,[a]) hunt :: [(a, [Int])] -> [a] hunt [] = [] hunt csmatches = - runST ( do th <- empty_threshold (length csmatches) l - hunt_internal csmatches th - hunt_recover th (-1) l ) + runST ( do th <- emptyThreshold (length csmatches) l + huntInternal csmatches th + huntRecover th (-1) l ) where l = maximum (0 : concat (map snd csmatches)) -hunt_internal :: [(a, [Int])] -> Threshold s a -> ST s () -hunt_internal [] _ = return () -hunt_internal ((c,m):csms) th = do - hunt_one_char c m th - hunt_internal csms th +huntInternal :: [(a, [Int])] -> Threshold s a -> ST s () +huntInternal [] _ = return () +huntInternal ((c,m):csms) th = do + huntOneChar c m th + huntInternal csms th -hunt_one_char :: a -> [Int] -> Threshold s a -> ST s () -hunt_one_char _ [] _ = return () -hunt_one_char c (j:js) th = do - index_k <- my_bs j th +huntOneChar :: a -> [Int] -> Threshold s a -> ST s () +huntOneChar _ [] _ = return () +huntOneChar c (j:js) th = do + index_k <- myBs j th case index_k of Nothing -> return () Just k -> do (_, rest) <- readArray th (k-1) writeArray th k (j, c:rest) - hunt_one_char c js th + huntOneChar c js th -- This is O(n), which is stupid. -hunt_recover :: Threshold s a -> Int -> Int -> ST s [a] -hunt_recover th n limit = +huntRecover :: Threshold s a -> Int -> Int -> ST s [a] +huntRecover th n limit = do (_, th_max) <- getBounds th if n < 0 - then hunt_recover th th_max limit - else if n == 0 + then huntRecover th th_max limit + else if n == 0 || n > th_max then return [] - else if n > th_max - then return [] - else do (thn, sn) <- readArray th n - if thn <= limit - then return $ reverse sn - else hunt_recover th (n-1) limit + else do (thn, sn) <- readArray th n + if thn <= limit + then return $ reverse sn + else huntRecover th (n-1) limit -empty_threshold :: Int -> Int -> ST s (Threshold s a) -empty_threshold l th_max = do +emptyThreshold :: Int -> Int -> ST s (Threshold s a) +emptyThreshold l th_max = do th <- newArray (0,l) (th_max+1, []) writeArray th 0 (0, []) return th -my_bs :: Int -> Threshold s a -> ST s (Maybe Int) -my_bs j th = do bnds <- getBounds th - my_helper_bs j bnds th +myBs :: Int -> Threshold s a -> ST s (Maybe Int) +myBs j th = do bnds <- getBounds th + myHelperBs j bnds th -my_helper_bs :: Int -> (Int,Int) -> Threshold s a -> +myHelperBs :: Int -> (Int,Int) -> Threshold s a -> ST s (Maybe Int) -my_helper_bs j (th_min,th_max) th = +myHelperBs j (th_min,th_max) th = if th_max - th_min > 1 then do (midth, _) <- readArray th th_middle if j > midth - then my_helper_bs j (th_middle,th_max) th - else my_helper_bs j (th_min,th_middle) th + then myHelperBs j (th_middle,th_max) th + else myHelperBs j (th_min,th_middle) th else do (minth, _) <- readArray th th_min (maxth, _) <- readArray th th_max @@ -388,32 +385,32 @@ -find_matches :: Ord a => [a] -> [a] -> [[Int]] -find_matches [] [] = [] -find_matches [] (_:bs) = []: find_matches [] bs -find_matches _ [] = [] -find_matches a b = - unzip_indexed $ sort $ find_sorted_matches indexeda indexedb [] [] +findMatches :: Ord a => [a] -> [a] -> [[Int]] +findMatches [] [] = [] +findMatches [] (_:bs) = []: findMatches [] bs +findMatches _ [] = [] +findMatches a b = + unzipIndexed $ sort $ findSortedMatches indexeda indexedb [] [] where indexeda = sort $ zip a [1..] indexedb = sort $ zip b [1..] -unzip_indexed :: [(Int,[a])] -> [[a]] -unzip_indexed s = unzip_indexed_helper 1 s - where unzip_indexed_helper _ [] = [] - unzip_indexed_helper thisl ((l,c):rest) - | thisl == l = c: unzip_indexed_helper (l+1) rest - | otherwise = []: unzip_indexed_helper (thisl+1) ((l,c):rest) +unzipIndexed :: [(Int,[a])] -> [[a]] +unzipIndexed s = unzipIndexedHelper 1 s + where unzipIndexedHelper _ [] = [] + unzipIndexedHelper thisl ((l,c):rest) + | thisl == l = c: unzipIndexedHelper (l+1) rest + | otherwise = []: unzipIndexedHelper (thisl+1) ((l,c):rest) -find_sorted_matches :: Ord a => [(a, Int)] -> [(a, Int)] -> [a] -> [Int] +findSortedMatches :: Ord a => [(a, Int)] -> [(a, Int)] -> [a] -> [Int] -> [(Int, [Int])] -find_sorted_matches [] _ _ _ = [] -find_sorted_matches _ [] _ _ = [] -find_sorted_matches ((a,na):as) ((b,nb):bs) aold aoldmatches +findSortedMatches [] _ _ _ = [] +findSortedMatches _ [] _ _ = [] +findSortedMatches ((a,na):as) ((b,nb):bs) aold aoldmatches | [a] == aold = (na, aoldmatches) : - find_sorted_matches as ((b,nb):bs) aold aoldmatches - | a > b = find_sorted_matches ((a,na):as) bs aold aoldmatches - | a < b = find_sorted_matches as ((b,nb):bs) aold aoldmatches + findSortedMatches as ((b,nb):bs) aold aoldmatches + | a > b = findSortedMatches ((a,na):as) bs aold aoldmatches + | a < b = findSortedMatches as ((b,nb):bs) aold aoldmatches -- following line is inefficient if a line is repeated many times. -find_sorted_matches ((a,na):as) bs _ _ -- a == b - = (na, matches) : find_sorted_matches as bs [a] matches +findSortedMatches ((a,na):as) bs _ _ -- a == b + = (na, matches) : findSortedMatches as bs [a] matches where matches = reverse $ map snd $ filter ((==a) . fst) bs diff --git a/src/Darcs/Util/Download.hs b/src/Darcs/Util/Download.hs --- a/src/Darcs/Util/Download.hs +++ b/src/Darcs/Util/Download.hs @@ -22,6 +22,9 @@ , ConnectionError(..) ) where +import Prelude ( (^) ) +import Darcs.Prelude + import Control.Arrow ( (&&&) ) import Control.Concurrent ( forkIO ) import Control.Concurrent.Chan ( isEmptyChan, newChan, readChan, writeChan, diff --git a/src/Darcs/Util/Download/Curl.hs b/src/Darcs/Util/Download/Curl.hs --- a/src/Darcs/Util/Download/Curl.hs +++ b/src/Darcs/Util/Download/Curl.hs @@ -1,9 +1,11 @@ -{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE CPP, ForeignFunctionInterface #-} module Darcs.Util.Download.Curl where #ifdef HAVE_CURL + +import Prelude () +import Darcs.Prelude import Control.Exception ( bracket ) import Control.Monad ( when ) diff --git a/src/Darcs/Util/Download/HTTP.hs b/src/Darcs/Util/Download/HTTP.hs --- a/src/Darcs/Util/Download/HTTP.hs +++ b/src/Darcs/Util/Download/HTTP.hs @@ -4,7 +4,8 @@ ( fetchUrl, postUrl, requestUrl, waitNextUrl ) where -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude import Darcs.Util.Global ( debugFail ) diff --git a/src/Darcs/Util/Download/Request.hs b/src/Darcs/Util/Download/Request.hs --- a/src/Darcs/Util/Download/Request.hs +++ b/src/Darcs/Util/Download/Request.hs @@ -15,6 +15,9 @@ , ConnectionError(..) ) where +import Prelude () +import Darcs.Prelude + import Data.List ( delete ) import Data.Map ( Map ) import Foreign.C.Types ( CInt ) diff --git a/src/Darcs/Util/Encoding.hs b/src/Darcs/Util/Encoding.hs --- a/src/Darcs/Util/Encoding.hs +++ b/src/Darcs/Util/Encoding.hs @@ -26,6 +26,9 @@ ( encode,decode ) where +import Prelude () +import Darcs.Prelude + import Data.ByteString ( ByteString ) #ifdef WIN32 diff --git a/src/Darcs/Util/Encoding/Win32.hs b/src/Darcs/Util/Encoding/Win32.hs --- a/src/Darcs/Util/Encoding/Win32.hs +++ b/src/Darcs/Util/Encoding/Win32.hs @@ -26,6 +26,9 @@ ( encode, decode ) where +import Prelude () +import Darcs.Prelude + import Data.ByteString.Internal ( createAndTrim ) import qualified Data.ByteString as B ( ByteString, useAsCStringLen ) diff --git a/src/Darcs/Util/English.hs b/src/Darcs/Util/English.hs --- a/src/Darcs/Util/English.hs +++ b/src/Darcs/Util/English.hs @@ -32,8 +32,12 @@ module Darcs.Util.English where -import Data.List (isSuffixOf, intercalate) +import Prelude () +import Darcs.Prelude +import Data.Char (toUpper) +import Data.List (isSuffixOf) + -- | > englishNum 0 (Noun "watch") "" == "watches" -- > englishNum 1 (Noun "watch") "" == "watch" -- > englishNum 2 (Noun "watch") "" == "watches" @@ -81,17 +85,24 @@ -- -- > orClauses ["foo", "bar", "baz"] == "foo, bar or baz" andClauses, orClauses :: [String] -> String -andClauses = intersperseLast ", " " and " -orClauses = intersperseLast ", " " or " +andClauses = itemize "and" +orClauses = itemize "or" --- | As 'intersperse', with a different separator for the last --- | interspersal. -intersperseLast :: String -> String -> [String] -> String -intersperseLast _ _ [] = "" -intersperseLast _ _ [clause] = clause -intersperseLast sep sepLast clauses = - intercalate sep (init clauses) ++ sepLast ++ last clauses +-- Should not be called with an empty list since this usually +-- prints an extra space. We allow it for compatibility. +itemize :: String -> [String] -> String +itemize _ [] = "" -- error "precondition in Darcs.Util.English.itemize" +itemize _ [x] = x +itemize sep [x,x'] = unwords [x, sep, x'] +itemize sep (x:x':xs) = itemize' x x' xs where + itemize' y y' [] = unwords [y ++ ",", sep, y'] + itemize' y y' (y'':ys) = unwords [y ++ ",", itemize' y' y'' ys] presentParticiple :: String -> String presentParticiple v | last v == 'e' = init v ++ "ing" | otherwise = v ++ "ing" + +-- | Capitalize the first letter of a word +capitalize :: String -> String +capitalize [] = [] +capitalize (x:xs) = toUpper x : xs diff --git a/src/Darcs/Util/Environment.hs b/src/Darcs/Util/Environment.hs --- a/src/Darcs/Util/Environment.hs +++ b/src/Darcs/Util/Environment.hs @@ -3,8 +3,8 @@ maybeGetEnv ) where - -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude import System.Environment ( getEnv ) diff --git a/src/Darcs/Util/Exception.hs b/src/Darcs/Util/Exception.hs --- a/src/Darcs/Util/Exception.hs +++ b/src/Darcs/Util/Exception.hs @@ -1,18 +1,22 @@ -{-# Language MultiParamTypeClasses, DeriveDataTypeable #-} +{-# Language MultiParamTypeClasses #-} module Darcs.Util.Exception ( firstJustIO , catchall , clarifyErrors , prettyException , prettyError + , die ) where -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude import Control.Exception ( SomeException, Exception(fromException), catch ) import Data.Maybe ( isJust ) +import System.Exit ( exitFailure ) +import System.IO ( stderr, hPutStrLn ) import System.IO.Error ( isUserError, ioeGetErrorString , isDoesNotExistError, ioeGetFileName ) @@ -47,7 +51,7 @@ clarifyErrors :: IO a -> String -> IO a -clarifyErrors a e = a `catch` (\x -> fail $ unlines [prettyException x,e]) +clarifyErrors a e = a `catch` (\x -> die $ unlines [prettyException x,e]) prettyException :: SomeException -> String @@ -62,3 +66,7 @@ prettyError :: IOError -> String prettyError e | isUserError e = ioeGetErrorString e | otherwise = show e + +-- | Terminate the program with an error message. +die :: String -> IO a +die msg = hPutStrLn stderr msg >> exitFailure diff --git a/src/Darcs/Util/Exec.hs b/src/Darcs/Util/Exec.hs --- a/src/Darcs/Util/Exec.hs +++ b/src/Darcs/Util/Exec.hs @@ -37,6 +37,9 @@ , ExecException(..) ) where +import Prelude () +import Darcs.Prelude + #ifndef WIN32 import Control.Exception ( bracket ) import System.Posix.Env ( setEnv, getEnv, unsetEnv ) diff --git a/src/Darcs/Util/External.hs b/src/Darcs/Util/External.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Util/External.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE CPP #-} +module Darcs.Util.External + ( cloneTree + , cloneFile + , fetchFilePS + , fetchFileLazyPS + , gzFetchFilePS + , speculateFileOrUrl + , copyFileOrUrl + , Cachable(..) + , backupByRenaming + , backupByCopying + ) where + +import Control.Exception ( catch, IOException ) + +import System.Posix.Files + ( getSymbolicLinkStatus + , isRegularFile + , isDirectory + , createLink + ) +import System.Directory + ( createDirectory + , getDirectoryContents + , doesDirectoryExist + , doesFileExist + , renameFile + , renameDirectory + , copyFile + ) + +import System.FilePath.Posix ( (), normalise ) +import System.IO.Error ( isDoesNotExistError ) +import Control.Monad + ( unless + , when + , zipWithM_ + ) + +import Darcs.Util.Global ( defaultRemoteDarcsCmd ) +import Darcs.Util.Download + ( copyUrl + , copyUrlFirst + , waitUrl + , Cachable(..) + ) + +import Darcs.Util.URL + ( isValidLocalPath + , isHttpUrl + , isSshUrl + , splitSshUrl + ) +import Darcs.Util.Exception ( catchall ) +import Darcs.Util.Lock ( withTemp ) +import Darcs.Util.Ssh ( copySSH ) + +import Darcs.Util.ByteString ( gzReadFilePS ) +import qualified Data.ByteString as B (ByteString, readFile ) +import qualified Data.ByteString.Lazy as BL + +#ifdef HAVE_HTTP +import Network.Browser + ( browse + , request + , setErrHandler + , setOutHandler + , setAllowRedirects + ) +import Network.HTTP + ( RequestMethod(GET) + , rspCode + , rspBody + , rspReason + , mkRequest + ) +import Network.URI + ( parseURI + , uriScheme + ) +#endif + + +copyFileOrUrl :: String -- ^ remote darcs executable + -> FilePath -- ^ path representing the origin file or URL + -> FilePath -- ^ destination path + -> Cachable -- ^ tell whether file to copy is cachable + -> IO () +copyFileOrUrl _ fou out _ | isValidLocalPath fou = copyLocal fou out +copyFileOrUrl _ fou out cache | isHttpUrl fou = copyRemote fou out cache +copyFileOrUrl rd fou out _ | isSshUrl fou = copySSH rd (splitSshUrl fou) out +copyFileOrUrl _ fou _ _ = fail $ "unknown transport protocol: " ++ fou + +copyLocal :: String -> FilePath -> IO () +copyLocal fou out = createLink fou out `catchall` cloneFile fou out + +cloneTree :: FilePath -> FilePath -> IO () +cloneTree = cloneTreeExcept [] + +cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO () +cloneTreeExcept except source dest = + do fs <- getSymbolicLinkStatus source + if isDirectory fs then do + fps <- getDirectoryContents source + let fps' = filter (`notElem` (".":"..":except)) fps + mk_source fp = source fp + mk_dest fp = dest fp + zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') + else fail ("cloneTreeExcept: Bad source " ++ source) + `catch` \(_ :: IOException) -> fail ("cloneTreeExcept: Bad source " ++ source) + +cloneSubTree :: FilePath -> FilePath -> IO () +cloneSubTree source dest = + do fs <- getSymbolicLinkStatus source + if isDirectory fs then do + createDirectory dest + fps <- getDirectoryContents source + let fps' = filter (`notElem` [".", ".."]) fps + mk_source fp = source fp + mk_dest fp = dest fp + zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') + else if isRegularFile fs then + cloneFile source dest + else fail ("cloneSubTree: Bad source "++ source) + `catch` (\e -> unless (isDoesNotExistError e) $ ioError e) + +cloneFile :: FilePath -> FilePath -> IO () +cloneFile = copyFile + +backupByRenaming :: FilePath -> IO () +backupByRenaming = backupBy rename + where rename x y = do + isD <- doesDirectoryExist x + if isD then renameDirectory x y else renameFile x y + +backupByCopying :: FilePath -> IO () +backupByCopying = backupBy copy + where + copy x y = do + isD <- doesDirectoryExist x + if isD then do createDirectory y + cloneTree (normalise x) (normalise y) + else copyFile x y + +backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO () +backupBy backup f = + do hasBF <- doesFileExist f + hasBD <- doesDirectoryExist f + when (hasBF || hasBD) $ helper 0 + where + helper :: Int -> IO () + helper i = do existsF <- doesFileExist next + existsD <- doesDirectoryExist next + if existsF || existsD + then helper (i + 1) + else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")" + backup f next + where next = f ++ suffix + suffix = ".~" ++ show i ++ "~" + +copyAndReadFile :: (FilePath -> IO a) -> String -> Cachable -> IO a +copyAndReadFile readfn fou _ | isValidLocalPath fou = readfn fou +copyAndReadFile readfn fou cache = withTemp $ \t -> do + copyFileOrUrl defaultRemoteDarcsCmd fou t cache + readfn t + +-- | @fetchFile fileOrUrl cache@ returns the content of its argument (either a +-- file or an URL). If it has to download an url, then it will use a cache as +-- required by its second argument. +-- +-- We always use default remote darcs, since it is not fatal if the remote +-- darcs does not exist or is too old -- anything that supports transfer-mode +-- should do, and if not, we will fall back to SFTP or SCP. +fetchFilePS :: String -> Cachable -> IO B.ByteString +fetchFilePS = copyAndReadFile (B.readFile) + +-- | @fetchFileLazyPS fileOrUrl cache@ lazily reads the content of its argument +-- (either a file or an URL). Warning: this function may constitute a fd leak; +-- make sure to force consumption of file contents to avoid that. See +-- "fetchFilePS" for details. +fetchFileLazyPS :: String -> Cachable -> IO BL.ByteString +#ifdef HAVE_HTTP +fetchFileLazyPS x c = case parseURI x of + Just x' | uriScheme x' == "http:" -> do + rsp <- fmap snd . browse $ do + setErrHandler . const $ return () + setOutHandler . const $ return () + setAllowRedirects True + request $ mkRequest GET x' + if rspCode rsp /= (2, 0, 0) + then fail $ "fetchFileLazyPS: " ++ rspReason rsp + else return $ rspBody rsp + _ -> copyAndReadFile BL.readFile x c +#else +fetchFileLazyPS = copyAndReadFile BL.readFile +#endif + +gzFetchFilePS :: String -> Cachable -> IO B.ByteString +gzFetchFilePS = copyAndReadFile gzReadFilePS + +copyRemote :: String -> FilePath -> Cachable -> IO () +copyRemote u v cache = copyUrlFirst u v cache >> waitUrl u + +speculateFileOrUrl :: String -> FilePath -> IO () +speculateFileOrUrl fou out | isHttpUrl fou = speculateRemote fou out + | otherwise = return () + +speculateRemote :: String -> FilePath -> IO () -- speculations are always Cachable +#if defined(HAVE_CURL) || defined(HAVE_HTTP) +speculateRemote u v = copyUrl u v Cachable +#else +speculateRemote u _ = return () +#endif + + diff --git a/src/Darcs/Util/File.hs b/src/Darcs/Util/File.hs --- a/src/Darcs/Util/File.hs +++ b/src/Darcs/Util/File.hs @@ -14,7 +14,8 @@ , getRecursiveContentsFullPath ) where -import Prelude hiding ( catch ) +import Prelude ( lookup ) +import Darcs.Prelude import Control.Exception ( catch, bracket ) import Control.Monad ( when, unless, forM ) diff --git a/src/Darcs/Util/Global.hs b/src/Darcs/Util/Global.hs --- a/src/Darcs/Util/Global.hs +++ b/src/Darcs/Util/Global.hs @@ -50,18 +50,21 @@ , darcsLastMessage , darcsSendMessage , darcsSendMessageFinal + , defaultRemoteDarcsCmd , isReachableSource , addReachableSource ) where +import Prelude () +import Darcs.Prelude + import Control.Monad ( when ) import Data.IORef ( modifyIORef, IORef, newIORef, readIORef, writeIORef ) import System.IO.Unsafe (unsafePerformIO) import System.IO ( hPutStrLn, hPutStr, stderr ) import System.Time ( calendarTimeToString, toCalendarTime, getClockTime ) import System.FilePath.Posix ( combine, (<.>) ) -import Prelude hiding (catch) -- Write-once-read-many global variables make it easier to implement flags, such @@ -173,6 +176,9 @@ darcsdir :: String darcsdir = "_darcs" + +defaultRemoteDarcsCmd :: String +defaultRemoteDarcsCmd = "darcs" darcsLastMessage :: String darcsLastMessage = combine darcsdir "patch_description.txt" diff --git a/src/Darcs/Util/Hash.hs b/src/Darcs/Util/Hash.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Util/Hash.hs @@ -0,0 +1,63 @@ +-- Copyright (C) 2009-2011 Petr Rockai +-- +-- BSD3 +{-# LANGUAGE DeriveDataTypeable #-} +module Darcs.Util.Hash( Hash(..) + , encodeBase16, decodeBase16, sha256, rawHash + , match ) where + +import qualified Crypto.Hash.SHA256 as SHA256 ( hash ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BS8 + +import qualified Codec.Binary.Base16 as B16 + +import Data.Maybe( isJust, fromJust ) +import Data.Char( toLower, toUpper ) + +import Data.Data( Data ) +import Data.Typeable( Typeable ) + +data Hash = SHA256 !BS.ByteString + | SHA1 !BS.ByteString + | NoHash + deriving (Show, Eq, Ord, Read, Typeable, Data) + +base16 :: BS.ByteString -> BS.ByteString +debase16 :: BS.ByteString -> Maybe BS.ByteString + +base16 = BS8.map toLower . B16.b16_enc +debase16 bs = case B16.b16_dec $ BS8.map toUpper bs of + Right (s, _) -> Just s + Left _ -> Nothing + +-- | Produce a base16 (ascii-hex) encoded string from a hash. This can be +-- turned back into a Hash (see "decodeBase16". This is a loss-less process. +encodeBase16 :: Hash -> BS.ByteString +encodeBase16 (SHA256 bs) = base16 bs +encodeBase16 (SHA1 bs) = base16 bs +encodeBase16 NoHash = BS.empty + +-- | Take a base16-encoded string and decode it as a "Hash". If the string is +-- malformed, yields NoHash. +decodeBase16 :: BS.ByteString -> Hash +decodeBase16 bs | BS.length bs == 64 && isJust (debase16 bs) = SHA256 (fromJust $ debase16 bs) + | BS.length bs == 40 && isJust (debase16 bs) = SHA1 (fromJust $ debase16 bs) + | otherwise = NoHash + +-- | Compute a sha256 of a (lazy) ByteString. However, although this works +-- correctly for any bytestring, it is only efficient if the bytestring only +-- has a sigle chunk. +sha256 :: BL.ByteString -> Hash +sha256 bits = SHA256 $ SHA256.hash $ BS.concat $ BL.toChunks bits + +rawHash :: Hash -> BS.ByteString +rawHash NoHash = error "Cannot obtain raw hash from NoHash." +rawHash (SHA1 s) = s +rawHash (SHA256 s) = s + +match :: Hash -> Hash -> Bool +NoHash `match` _ = False +_ `match` NoHash = False +x `match` y = x == y diff --git a/src/Darcs/Util/Index.hs b/src/Darcs/Util/Index.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Util/Index.hs @@ -0,0 +1,583 @@ +-- Copyright (C) 2009-2011 Petr Rockai +-- (C) 2013 Jose Neder +-- BSD3 +{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses #-} + +-- | This module contains plain tree indexing code. The index itself is a +-- CACHE: you should only ever use it as an optimisation and never as a primary +-- storage. In practice, this means that when we change index format, the +-- application is expected to throw the old index away and build a fresh +-- index. Please note that tracking index validity is out of scope for this +-- library: this is responsibility of your application. It is advisable that in +-- your validity tracking code, you also check for format validity (see +-- 'indexFormatValid') and scrap and re-create index when needed. +-- +-- The index is a binary file that overlays a hashed tree over the working +-- copy. This means that every working file and directory has an entry in the +-- index, that contains its path and hash and validity data. The validity data +-- is a timestamp plus the file size. The file hashes are sha256's of the +-- file's content. It also contains the fileid to track moved files. +-- +-- There are two entry types, a file entry and a directory entry. Both have a +-- common binary format (see 'Item'). The on-disk format is best described by +-- the section /Index format/ below. +-- +-- For each file, the index has a copy of the file's last modification +-- timestamp taken at the instant when the hash has been computed. This means +-- that when file size and timestamp of a file in working copy matches those in +-- the index, we assume that the hash stored in the index for given file is +-- valid. These hashes are then exposed in the resulting 'Tree' object, and can +-- be leveraged by eg. 'diffTrees' to compare many files quickly. +-- +-- You may have noticed that we also keep hashes of directories. These are +-- assumed to be valid whenever the complete subtree has been valid. At any +-- point, as soon as a size or timestamp mismatch is found, the working file in +-- question is opened, its hash (and timestamp and size) is recomputed and +-- updated in-place in the index file (everything lives at a fixed offset and +-- is fixed size, so this isn't an issue). This is also true of directories: +-- when a file in a directory changes hash, this triggers recomputation of all +-- of its parent directory hashes; moreover this is done efficiently -- each +-- directory is updated at most once during an update run. +-- +-- /Index format/ +-- +-- The Index is organised into \"lines\" where each line describes a single +-- indexed item. Cf. 'Item'. +-- +-- The first word on the index \"line\" is the length of the file path (which is +-- the only variable-length part of the line). Then comes the path itself, then +-- fixed-length hash (sha256) of the file in question, then three words, one for +-- size, one for "aux", which is used differently for directories and for files, and +-- one for the fileid (inode or fhandle) of the file. +-- +-- With directories, this aux holds the offset of the next sibling line in the +-- index, so we can efficiently skip reading the whole subtree starting at a +-- given directory (by just seeking aux bytes forward). The lines are +-- pre-ordered with respect to directory structure -- the directory comes first +-- and after it come all its items. Cf. 'readIndex''. +-- +-- For files, the aux field holds a timestamp. + +module Darcs.Util.Index( readIndex, updateIndexFrom, indexFormatValid + , updateIndex, listFileIDs, Index, filter + , getFileID + -- for testing + , align + , xlate32 + , xlate64 ) + where + +import Prelude hiding ( lookup, readFile, writeFile, filter, (<$>) ) +import Darcs.Util.ByteString ( readSegment ) +import Darcs.Util.Tree +import Darcs.Util.Path hiding ( getCurrentDirectory ) +import Data.Int( Int64, Int32 ) + +import Bundled.Posix( getFileStatusBS, modificationTime, + getFileStatus, fileSize, fileExists, isDirectory ) +import System.IO.MMap( mmapFileForeignPtr, mmapFileByteString, Mode(..) ) +import System.IO( ) +import System.Directory( doesFileExist, getCurrentDirectory, doesDirectoryExist ) +#if mingw32_HOST_OS +import System.Directory( renameFile ) +import System.FilePath( (<.>) ) +#else +import System.Directory( removeFile ) +#endif +import System.FilePath( () ) +import System.Posix.Types ( FileID ) + +import Control.Monad( when ) +import Control.Exception( catch, SomeException ) +import Control.Applicative( (<$>) ) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.ByteString.Unsafe( unsafeHead, unsafeDrop ) +import Data.ByteString.Internal( toForeignPtr, fromForeignPtr, memcpy + , nullForeignPtr, c2w ) + +import Data.IORef( ) +import Data.Maybe( fromJust, isJust, fromMaybe ) +import Data.Bits( Bits ) +#ifdef BIGENDIAN +import Data.Bits( (.&.), (.|.), shift, shiftL, rotateR ) +#endif + +import Foreign.Storable +import Foreign.ForeignPtr( ForeignPtr, withForeignPtr, castForeignPtr ) +import Foreign.Ptr( Ptr, plusPtr ) + +import Darcs.Util.Hash( sha256, rawHash ) +#ifdef WIN32 +import System.Win32.File ( createFile, getFileInformationByHandle, BY_HANDLE_FILE_INFORMATION(..), + fILE_SHARE_NONE, fILE_FLAG_BACKUP_SEMANTICS, + gENERIC_NONE, oPEN_EXISTING, closeHandle ) +#else +import System.PosixCompat ( fileID, getSymbolicLinkStatus ) +#endif + +-------------------------- +-- Indexed trees +-- + +-- | Description of a a single indexed item. The structure itself does not +-- contain any data, just pointers to the underlying mmap (bytestring is a +-- pointer + offset + length). +-- +-- The structure is recursive-ish (as opposed to flat-ish structure, which is +-- used by git...) It turns out that it's hard to efficiently read a flat index +-- with our internal data structures -- we need to turn the flat index into a +-- recursive Tree object, which is rather expensive... As a bonus, we can also +-- efficiently implement subtree queries this way (cf. 'readIndex'). +data Item = Item { iBase :: !(Ptr ()) + , iHashAndDescriptor :: !BS.ByteString + } deriving Show + +size_magic :: Int +size_magic = 4 -- the magic word, first 4 bytes of the index + +size_dsclen, size_hash, size_size, size_aux, size_fileid :: Int +size_size = 8 -- file/directory size (Int64) +size_aux = 8 -- aux (Int64) +size_fileid = 8 -- fileid (inode or fhandle FileID) +size_dsclen = 4 -- this many bytes store the length of the path +size_hash = 32 -- hash representation + +off_size, off_aux, off_hash, off_dsc, off_dsclen, off_fileid :: Int +off_size = 0 +off_aux = off_size + size_size +off_fileid = off_aux + size_aux +off_dsclen = off_fileid + size_fileid +off_hash = off_dsclen + size_dsclen +off_dsc = off_hash + size_hash + +itemAllocSize :: AnchoredPath -> Int +itemAllocSize apath = + align 4 $ size_hash + size_size + size_aux + size_fileid + size_dsclen + 2 + BS.length (flatten apath) + +itemSize, itemNext :: Item -> Int +itemSize i = size_size + size_aux + size_fileid + size_dsclen + (BS.length $ iHashAndDescriptor i) +itemNext i = align 4 (itemSize i + 1) + +iPath, iHash, iDescriptor :: Item -> BS.ByteString +iDescriptor = unsafeDrop size_hash . iHashAndDescriptor +iPath = unsafeDrop 1 . iDescriptor +iHash = BS.take size_hash . iHashAndDescriptor + +iSize, iAux :: Item -> Ptr Int64 +iSize i = plusPtr (iBase i) off_size +iAux i = plusPtr (iBase i) off_aux + +iFileID :: Item -> Ptr FileID +iFileID i = plusPtr (iBase i) off_fileid + +itemIsDir :: Item -> Bool +itemIsDir i = unsafeHead (iDescriptor i) == c2w 'D' + +-- xlatePeek32 = fmap xlate32 . peek +xlatePeek64 :: (Storable a, Num a, Bits a) => Ptr a -> IO a +xlatePeek64 = fmap xlate64 . peek + +-- xlatePoke32 ptr v = poke ptr (xlate32 v) +xlatePoke64 :: (Storable a, Num a, Bits a) => Ptr a -> a -> IO () +xlatePoke64 ptr v = poke ptr (xlate64 v) + +-- | Lay out the basic index item structure in memory. The memory location is +-- given by a ForeignPointer () and an offset. The path and type given are +-- written out, and a corresponding Item is given back. The remaining bits of +-- the item can be filled out using 'update'. +createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item +createItem typ apath fp off = + do let dsc = BS.concat [ BSC.singleton $ if typ == TreeType then 'D' else 'F' + , flatten apath + , BS.singleton 0 ] + (dsc_fp, dsc_start, dsc_len) = toForeignPtr dsc + withForeignPtr fp $ \p -> + withForeignPtr dsc_fp $ \dsc_p -> + do fileid <- fromMaybe 0 <$> getFileID apath + pokeByteOff p (off + off_fileid) (xlate64 $ fromIntegral fileid :: Int64) + pokeByteOff p (off + off_dsclen) (xlate32 $ fromIntegral dsc_len :: Int32) + memcpy (plusPtr p $ off + off_dsc) + (plusPtr dsc_p dsc_start) + (fromIntegral dsc_len) + peekItem fp off + +-- | Read the on-disk representation into internal data structure. +-- +-- See the module-level section /Index format/ for details on how the index +-- is structured. +peekItem :: ForeignPtr () -> Int -> IO Item +peekItem fp off = + withForeignPtr fp $ \p -> do + nl' :: Int32 <- xlate32 `fmap` peekByteOff p (off + off_dsclen) + when (nl' <= 2) $ fail "Descriptor too short in peekItem!" + let nl = fromIntegral nl' + dsc = fromForeignPtr (castForeignPtr fp) (off + off_hash) (size_hash + nl - 1) + return $! Item { iBase = plusPtr p off + , iHashAndDescriptor = dsc } + +-- | Update an existing item with new hash and optionally mtime (give Nothing +-- when updating directory entries). +updateItem :: Item -> Int64 -> Hash -> IO () +updateItem item _ NoHash = + fail $ "Index.update NoHash: " ++ BSC.unpack (iPath item) +updateItem item size hash = + do xlatePoke64 (iSize item) size + unsafePokeBS (iHash item) (rawHash hash) + +updateFileID :: Item -> FileID -> IO () +updateFileID item fileid = xlatePoke64 (iFileID item) $ fromIntegral fileid +updateAux :: Item -> Int64 -> IO () +updateAux item aux = xlatePoke64 (iAux item) $ aux +updateTime :: forall a.(Enum a) => Item -> a -> IO () +updateTime item mtime = updateAux item (fromIntegral $ fromEnum mtime) + +iHash' :: Item -> Hash +iHash' i = SHA256 (iHash i) + +-- | Gives a ForeignPtr to mmapped index, which can be used for reading and +-- updates. The req_size parameter, if non-0, expresses the requested size of +-- the index file. mmapIndex will grow the index if it is smaller than this. +mmapIndex :: forall a. FilePath -> Int -> IO (ForeignPtr a, Int) +mmapIndex indexpath req_size = do + exist <- doesFileExist indexpath + act_size <- fromIntegral `fmap` if exist then fileSize `fmap` getFileStatus indexpath + else return 0 + let size = case req_size > 0 of + True -> req_size + False | act_size >= size_magic -> act_size - size_magic + | otherwise -> 0 + case size of + 0 -> return (castForeignPtr nullForeignPtr, size) + _ -> do (x, _, _) <- mmapFileForeignPtr indexpath + ReadWriteEx (Just (0, size + size_magic)) + return (x, size) + +data IndexM m = Index { mmap :: (ForeignPtr ()) + , basedir :: FilePath + , hashtree :: Tree m -> Hash + , predicate :: AnchoredPath -> TreeItem m -> Bool } + | EmptyIndex + +type Index = IndexM IO + +data State = State { dirlength :: !Int + , path :: !AnchoredPath + , start :: !Int } + +data Result = Result { -- | marks if the item has changed since the last update to the index + changed :: !Bool + -- | next is the position of the next item, in bytes. + , next :: !Int + -- | treeitem is Nothing in case of the item doesn't exist in the tree + -- or is filtered by a FilterTree. Or a TreeItem otherwise. + , treeitem :: !(Maybe (TreeItem IO)) + -- | resitem is the item extracted. + , resitem :: !Item } + +data ResultF = ResultF { -- | nextF is the position of the next item, in bytes. + nextF :: !Int + -- | resitemF is the item extracted. + , resitemF :: !Item + -- | _fileIDs contains the fileids of the files and folders inside, + -- in a folder item and its own fileid for file item). + , _fileIDs :: [((AnchoredPath, ItemType), FileID)] } + +readItem :: Index -> State -> IO Result +readItem index state = do + item <- peekItem (mmap index) (start state) + res' <- if itemIsDir item + then readDir index state item + else readFile index state item + return res' + +readDir :: Index -> State -> Item -> IO Result +readDir index state item = + do following <- fromIntegral <$> xlatePeek64 (iAux item) + st <- getFileStatusBS (iPath item) + let exists = fileExists st && isDirectory st + fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item) + fileid' <- fromMaybe fileid <$> (getFileID' $ BSC.unpack $ iPath item) + when (fileid == 0) $ updateFileID item fileid' + let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC + namelength = (BS.length $ iDescriptor item) - (dirlength state) + myname = name item (dirlength state) + substate = state { start = start state + itemNext item + , path = path state `appendPath` myname + , dirlength = if myname == Name (BSC.singleton '.') + then dirlength state + else dirlength state + namelength } + + want = exists && (predicate index) (path substate) (Stub undefined NoHash) + oldhash = iHash' item + + subs off | off < following = do + result <- readItem index $ substate { start = off } + rest <- subs $ next result + return $! (name (resitem result) $ dirlength substate, result) : rest + subs coff | coff == following = return [] + | otherwise = fail $ "Offset mismatch at " ++ show coff ++ + " (ends at " ++ show following ++ ")" + + inferiors <- if want then subs $ start substate + else return [] + + let we_changed = or [ changed x | (_, x) <- inferiors ] || nullleaf + nullleaf = null inferiors && oldhash == nullsha + nullsha = SHA256 (BS.replicate 32 0) + tree' = makeTree [ (n, fromJust $ treeitem s) | (n, s) <- inferiors, isJust $ treeitem s ] + treehash = if we_changed then hashtree index tree' else oldhash + tree = tree' { treeHash = treehash } + + when (exists && we_changed) $ updateItem item 0 treehash + return $ Result { changed = not exists || we_changed + , next = following + , treeitem = if want then Just $ SubTree tree + else Nothing + , resitem = item } + +readFile :: Index -> State -> Item -> IO Result +readFile index state item = + do st <- getFileStatusBS (iPath item) + mtime <- fromIntegral <$> (xlatePeek64 $ iAux item) + size <- xlatePeek64 $ iSize item + fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item) + fileid' <- fromMaybe fileid <$> (getFileID' $ BSC.unpack $ iPath item) + let mtime' = modificationTime st + size' = fromIntegral $ fileSize st + readblob = readSegment (basedir index BSC.unpack (iPath item), Nothing) + exists = fileExists st && not (isDirectory st) + we_changed = mtime /= mtime' || size /= size' + hash = iHash' item + when (exists && we_changed) $ + do hash' <- sha256 `fmap` readblob + updateItem item size' hash' + updateTime item mtime' + when (fileid == 0) $ updateFileID item fileid' + return $ Result { changed = not exists || we_changed + , next = start state + itemNext item + , treeitem = if exists then Just $ File $ Blob readblob hash else Nothing + , resitem = item } + +updateIndex :: Index -> IO (Tree IO) +updateIndex EmptyIndex = return emptyTree +updateIndex index = + do let initial = State { start = size_magic + , dirlength = 0 + , path = AnchoredPath [] } + res <- readItem index initial + case treeitem res of + Just (SubTree tree) -> return $ filter (predicate index) tree + _ -> fail "Unexpected failure in updateIndex!" + +-- | Return a list containing all the file/folder names in an index, with +-- their respective ItemType and FileID. +listFileIDs :: Index -> IO ([((AnchoredPath, ItemType), FileID)]) +listFileIDs EmptyIndex = return [] +listFileIDs index = + do let initial = State { start = size_magic + , dirlength = 0 + , path = AnchoredPath [] } + res <- readItemFileIDs index initial + return $ _fileIDs res + +readItemFileIDs :: Index -> State -> IO ResultF +readItemFileIDs index state = do + item <- peekItem (mmap index) (start state) + res' <- if itemIsDir item + then readDirFileIDs index state item + else readFileFileID index state item + return res' + +readDirFileIDs :: Index -> State -> Item -> IO ResultF +readDirFileIDs index state item = + do fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item) + following <- fromIntegral <$> xlatePeek64 (iAux item) + let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC + namelength = (BS.length $ iDescriptor item) - (dirlength state) + myname = name item (dirlength state) + substate = state { start = start state + itemNext item + , path = path state `appendPath` myname + , dirlength = if myname == Name (BSC.singleton '.') + then dirlength state + else dirlength state + namelength } + subs off | off < following = do + result <- readItemFileIDs index $ substate { start = off } + rest <- subs $ nextF result + return $! (name (resitemF result) $ dirlength substate, result) : rest + subs coff | coff == following = return [] + | otherwise = fail $ "Offset mismatch at " ++ show coff ++ + " (ends at " ++ show following ++ ")" + inferiors <- subs $ start substate + return $ ResultF { nextF = following + , resitemF = item + , _fileIDs = (((path substate, TreeType), fileid):concatMap (_fileIDs . snd) inferiors) } + +readFileFileID :: Index -> State -> Item -> IO ResultF +readFileFileID _ state item = + do fileid' <- fromIntegral <$> (xlatePeek64 $ iFileID item) + let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) + myname = name item (dirlength state) + return $ ResultF { nextF = start state + itemNext item + , resitemF = item + , _fileIDs = [((path state `appendPath` myname, BlobType), fileid')] } + + +-- | Read an index and build up a 'Tree' object from it, referring to current +-- working directory. The initial Index object returned by readIndex is not +-- directly useful. However, you can use 'Tree.filter' on it. Either way, to +-- obtain the actual Tree object, call update. +-- +-- The usual use pattern is this: +-- +-- > do (idx, update) <- readIndex +-- > tree <- update =<< filter predicate idx +-- +-- The resulting tree will be fully expanded. +readIndex :: FilePath -> (Tree IO -> Hash) -> IO Index +readIndex indexpath ht = do + (mmap_ptr, mmap_size) <- mmapIndex indexpath 0 + base <- getCurrentDirectory + return $ if mmap_size == 0 then EmptyIndex + else Index { mmap = mmap_ptr + , basedir = base + , hashtree = ht + , predicate = \_ _ -> True } + +formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO () +formatIndex mmap_ptr old reference = + do _ <- create (SubTree reference) (AnchoredPath []) size_magic + unsafePokeBS magic (BSC.pack "HSI5") + where magic = fromForeignPtr (castForeignPtr mmap_ptr) 0 4 + create (File _) path' off = + do i <- createItem BlobType path' mmap_ptr off + let flatpath = BSC.unpack $ flatten path' + case find old path' of + Nothing -> return () + -- TODO calling getFileStatus here is both slightly + -- inefficient and slightly race-prone + Just ti -> do st <- getFileStatus flatpath + let hash = itemHash ti + mtime = modificationTime st + size = fileSize st + updateItem i (fromIntegral size) hash + updateTime i mtime + return $ off + itemNext i + create (SubTree s) path' off = + do i <- createItem TreeType path' mmap_ptr off + case find old path' of + Nothing -> return () + Just ti | itemHash ti == NoHash -> return () + | otherwise -> updateItem i 0 $ itemHash ti + let subs [] = return $ off + itemNext i + subs ((name,x):xs) = do + let path'' = path' `appendPath` name + noff <- subs xs + create x path'' noff + lastOff <- subs (listImmediate s) + xlatePoke64 (iAux i) (fromIntegral lastOff) + return lastOff + create (Stub _ _) path' _ = + fail $ "Cannot create index from stubbed Tree at " ++ show path' + +-- | Will add and remove files in index to make it match the 'Tree' object +-- given (it is an error for the 'Tree' to contain a file or directory that +-- does not exist in a plain form in current working directory). +updateIndexFrom :: FilePath -> (Tree IO -> Hash) -> Tree IO -> IO Index +updateIndexFrom indexpath hashtree' ref = + do old_idx <- updateIndex =<< readIndex indexpath hashtree' + reference <- expand ref + let len_root = itemAllocSize anchoredRoot + len = len_root + sum [ itemAllocSize p | (p, _) <- list reference ] + exist <- doesFileExist indexpath +#if mingw32_HOST_OS + when exist $ renameFile indexpath (indexpath <.> "old") +#else + when exist $ removeFile indexpath -- to avoid clobbering oldidx +#endif + (mmap_ptr, _) <- mmapIndex indexpath len + formatIndex mmap_ptr old_idx reference + readIndex indexpath hashtree' + +-- | Check that a given file is an index file with a format we can handle. You +-- should remove and re-create the index whenever this is not true. +indexFormatValid :: FilePath -> IO Bool +indexFormatValid path' = + do magic <- mmapFileByteString path' (Just (0, size_magic)) + return $ case BSC.unpack magic of + "HSI5" -> True + _ -> False + `catch` \(_::SomeException) -> return False + +instance FilterTree IndexM IO where + filter _ EmptyIndex = EmptyIndex + filter p index = index { predicate = \a b -> predicate index a b && p a b } + + +-- | For a given file or folder path, get the corresponding fileID from the +-- filesystem. +getFileID :: AnchoredPath -> IO (Maybe FileID) +getFileID = getFileID' . anchorPath "" + +getFileID' :: FilePath -> IO (Maybe FileID) +getFileID' fp = do file_exists <- doesFileExist fp + dir_exists <- doesDirectoryExist fp + if file_exists || dir_exists +#ifdef WIN32 + then do h <- createFile fp gENERIC_NONE fILE_SHARE_NONE Nothing oPEN_EXISTING fILE_FLAG_BACKUP_SEMANTICS Nothing + fhnumber <- (Just . fromIntegral . bhfiFileIndex) <$> getFileInformationByHandle h + closeHandle h + return fhnumber +#else + then (Just . fileID) <$> getSymbolicLinkStatus fp +#endif + else return Nothing + + +-- Wow, unsafe. +unsafePokeBS :: BSC.ByteString -> BSC.ByteString -> IO () +unsafePokeBS to from = + do let (fp_to, off_to, len_to) = toForeignPtr to + (fp_from, off_from, len_from) = toForeignPtr from + when (len_to /= len_from) $ fail $ "Length mismatch in unsafePokeBS: from = " + ++ show len_from ++ " /= to = " ++ show len_to + withForeignPtr fp_from $ \p_from -> + withForeignPtr fp_to $ \p_to -> + memcpy (plusPtr p_to off_to) + (plusPtr p_from off_from) + (fromIntegral len_to) + +align :: Integral a => a -> a -> a +align boundary i = case i `rem` boundary of + 0 -> i + x -> i + boundary - x +{-# INLINE align #-} + +xlate32 :: (Num a, Bits a) => a -> a +xlate64 :: (Num a, Bits a) => a -> a + +#ifdef LITTLEENDIAN +xlate32 = id +xlate64 = id +#endif + +#ifdef BIGENDIAN +bytemask :: (Num a, Bits a) => a +bytemask = 255 + +xlate32 a = ((a .&. (bytemask `shift` 0)) `shiftL` 24) .|. + ((a .&. (bytemask `shift` 8)) `shiftL` 8) .|. + ((a .&. (bytemask `shift` 16)) `rotateR` 8) .|. + ((a .&. (bytemask `shift` 24)) `rotateR` 24) + +xlate64 a = ((a .&. (bytemask `shift` 0)) `shiftL` 56) .|. + ((a .&. (bytemask `shift` 8)) `shiftL` 40) .|. + ((a .&. (bytemask `shift` 16)) `shiftL` 24) .|. + ((a .&. (bytemask `shift` 24)) `shiftL` 8) .|. + ((a .&. (bytemask `shift` 32)) `rotateR` 8) .|. + ((a .&. (bytemask `shift` 40)) `rotateR` 24) .|. + ((a .&. (bytemask `shift` 48)) `rotateR` 40) .|. + ((a .&. (bytemask `shift` 56)) `rotateR` 56) +#endif + diff --git a/src/Darcs/Util/IsoDate.hs b/src/Darcs/Util/IsoDate.hs --- a/src/Darcs/Util/IsoDate.hs +++ b/src/Darcs/Util/IsoDate.hs @@ -36,6 +36,9 @@ , unsetTime, TimeInterval ) where +import Prelude ( (^) ) +import Darcs.Prelude + import Text.ParserCombinators.Parsec import System.Time import System.IO.Unsafe ( unsafePerformIO ) diff --git a/src/Darcs/Util/Lock.hs b/src/Darcs/Util/Lock.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Util/Lock.hs @@ -0,0 +1,384 @@ +-- Copyright (C) 2003 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 CPP #-} + +module Darcs.Util.Lock + ( withLock + , withLockCanFail + , environmentHelpLocks + , withTemp + , withOpenTemp + , withStdoutTemp + , withTempDir + , withPermDir + , withDelayedDir + , withNamedTemp + , writeToFile + , appendToFile + , writeBinFile + , writeLocaleFile + , writeDocBinFile + , appendBinFile + , appendDocBinFile + , readBinFile + , readLocaleFile + , readDocBinFile + , writeAtomicFilePS + , gzWriteAtomicFilePS + , gzWriteAtomicFilePSs + , gzWriteDocFile + , rmRecursive + , removeFileMayNotExist + , canonFilename + , maybeRelink + , worldReadableTemp + , tempdirLoc + , environmentHelpTmpdir + , environmentHelpKeepTmpdir + , addToErrorLoc + ) where + +import Data.List ( inits ) +import Data.Maybe ( isJust, listToMaybe ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.IO ( withBinaryFile, openBinaryTempFile, + hClose, hPutStr, Handle, + IOMode(WriteMode, AppendMode), hFlush, stdout ) +import System.IO.Error + ( isAlreadyExistsError + , annotateIOError + ) +import Control.Exception + ( IOException + , bracket + , throwIO + , catch + , try + , SomeException + ) +import System.Directory ( removeFile, removeDirectory, + doesFileExist, doesDirectoryExist, + getDirectoryContents, createDirectory, + getTemporaryDirectory, + ) +import System.FilePath.Posix ( splitDirectories ) +import Control.Concurrent ( threadDelay ) +import Control.Monad ( unless, when, liftM ) + +import Darcs.Util.URL ( isRelative ) +import Darcs.Util.Environment ( maybeGetEnv ) +import Darcs.Util.Exception + ( firstJustIO + , catchall + ) +import Darcs.Util.File ( withCurrentDirectory + , doesDirectoryReallyExist, removeFileMayNotExist ) +import Darcs.Util.Path ( AbsolutePath, FilePathLike, toFilePath, + getCurrentDirectory, setCurrentDirectory ) + +import Darcs.Util.ByteString ( gzWriteFilePSs, decodeLocale, encodeLocale ) +import qualified Data.ByteString as B (null, readFile, hPut, ByteString) +import qualified Data.ByteString.Char8 as BC (unpack) + +import Darcs.Util.SignalHandler ( withSignalsBlocked ) +import Darcs.Util.Printer ( Doc, hPutDoc, packedString, empty, renderPSs, RenderMode(..) ) +import Darcs.Util.AtExit ( atexit ) +import Darcs.Util.Global ( darcsdir ) +import Darcs.Util.Workaround ( renameFile ) +import Darcs.Util.Compat + ( mkStdoutTemp + , canonFilename + , maybeRelink + , atomicCreate + , sloppyAtomicCreate + ) +import System.Posix.Files ( fileMode, getFileStatus, setFileMode ) +import Darcs.Util.Prompt ( askUser ) +#include "impossible.h" + +withLock :: String -> IO a -> IO a +withLock s job = bracket (getlock s 30) releaseLock (\_ -> job) + +releaseLock :: String -> IO () +releaseLock = removeFileMayNotExist + +-- | Tries to perform some task if it can obtain the lock, +-- Otherwise, just gives up without doing the task +withLockCanFail :: String -> IO a -> IO (Either () a) +withLockCanFail s job = + bracket (takeLock s) + (\l -> when l $ releaseLock s) + (\l -> if l then liftM Right job + else return $ Left ()) + +getlock :: String -> Int -> IO String +getlock l 0 = do yorn <- askUser $ "Couldn't get lock "++l++". Abort (yes or anything else)? " + case yorn of + ('y':_) -> exitWith $ ExitFailure 1 + _ -> getlock l 30 +getlock lbad tl = do l <- canonFilename lbad + gotit <- takeLock l + if gotit then return l + else do putStrLn $ "Waiting for lock "++l + hFlush stdout -- for Windows + threadDelay 2000000 + getlock l (tl - 1) + + +takeLock :: FilePathLike p => p -> IO Bool +takeLock fp = + do atomicCreate $ toFilePath fp + return True + `catch` \e -> if isAlreadyExistsError e + then return False + else do pwd <- getCurrentDirectory + throwIO $ addToErrorLoc e + ("takeLock "++toFilePath fp++" in "++toFilePath pwd) + +takeFile :: FilePath -> IO Bool +takeFile fp = + do sloppyAtomicCreate fp + return True + `catch` \e -> if isAlreadyExistsError e + then return False + else do pwd <- getCurrentDirectory + throwIO $ addToErrorLoc e + ("takeFile "++fp++" in "++toFilePath pwd) + +environmentHelpLocks :: ([String],[String]) +environmentHelpLocks = (["DARCS_SLOPPY_LOCKS"],[ + "If on some filesystems you get an error of the kind:", + "", + " darcs: takeLock [...]: atomic_create [...]: unsupported operation", + "", + "you may want to try to export DARCS_SLOPPY_LOCKS=True."]) + +-- |'withTemp' safely creates an empty file (not open for writing) and +-- returns its name. +-- +-- The temp file operations are rather similar to the locking operations, in +-- that they both should always try to clean up, so exitWith causes trouble. +withTemp :: (String -> IO a) -> IO a +withTemp = bracket get_empty_file removeFileMayNotExist + where get_empty_file = do (f,h) <- openBinaryTempFile "." "darcs" + hClose h + return f + +-- |'withOpenTemp' creates a temporary file, and opens it. +-- Both of them run their argument and then delete the file. Also, +-- both of them (to my knowledge) are not susceptible to race conditions on +-- the temporary file (as long as you never delete the temporary file; that +-- would reintroduce a race condition). +withOpenTemp :: ((Handle, String) -> IO a) -> IO a +withOpenTemp = bracket get_empty_file cleanup + where cleanup (h,f) = do _ <- try (hClose h) :: IO (Either SomeException ()) + removeFileMayNotExist f + get_empty_file = invert `fmap` openBinaryTempFile "." "darcs" + invert (a,b) = (b,a) + +withStdoutTemp :: (String -> IO a) -> IO a +withStdoutTemp = bracket (mkStdoutTemp "stdout_") removeFileMayNotExist + +tempdirLoc :: IO FilePath +tempdirLoc = liftM fromJust $ + firstJustIO [ liftM (Just . head . words) (readBinFile (darcsdir++"/prefs/tmpdir")) >>= chkdir, + maybeGetEnv "DARCS_TMPDIR" >>= chkdir, + getTemporaryDirectory >>= chkdir . Just, + getCurrentDirectorySansDarcs, + return $ Just "." -- always returns a Just + ] + where chkdir Nothing = return Nothing + chkdir (Just d) = liftM (\e -> if e then Just (d++"/") else Nothing) $ doesDirectoryExist d + +environmentHelpTmpdir :: ([String], [String]) +environmentHelpTmpdir = (["DARCS_TMPDIR", "TMPDIR"], [ + "Darcs often creates temporary directories. For example, the `darcs", + "diff` command creates two for the working trees to be diffed. By", + "default temporary directories are created in /tmp, or if that doesn't", + "exist, in _darcs (within the current repo). This can be overridden by", + "specifying some other directory in the file _darcs/prefs/tmpdir or the", + "environment variable $DARCS_TMPDIR or $TMPDIR."]) + +getCurrentDirectorySansDarcs :: IO (Maybe FilePath) +getCurrentDirectorySansDarcs = do + c <- getCurrentDirectory + return $ listToMaybe $ drop 5 $ reverse $ takeWhile no_darcs $ inits $ toFilePath c + where no_darcs x = darcsdir `notElem` splitDirectories x + +data WithDirKind = Perm | Temp | Delayed + +-- | Creates a directory based on the path parameter; +-- if a relative path is given the dir is created in the darcs temp dir. +-- If an absolute path is given this dir will be created if it doesn't exist. +-- If it is specified as a temporary dir, it is deleted after finishing the job. +withDir :: WithDirKind -- specifies if and when directory will be deleted + -> String -- path parameter + -> (AbsolutePath -> IO a) -> IO a +withDir _ "" _ = bug "withDir called with empty directory name" +withDir kind absoluteOrRelativeName job = do + absoluteName <- if isRelative absoluteOrRelativeName + then fmap (++ absoluteOrRelativeName) tempdirLoc + else return absoluteOrRelativeName + formerdir <- getCurrentDirectory + bracket (createDir absoluteName 0) + (\dir -> do setCurrentDirectory formerdir + k <- keepTempDir + unless k $ case kind of + Perm -> return () + Temp -> rmRecursive (toFilePath dir) + Delayed -> atexit $ rmRecursive (toFilePath dir)) + job + where newname name 0 = name + newname name n = name ++ "-" ++ show n + createDir :: FilePath -> Int -> IO AbsolutePath + createDir name n + = do createDirectory $ newname name n + setCurrentDirectory $ newname name n + getCurrentDirectory + `catch` (\e -> if isAlreadyExistsError e + then createDir name (n+1) + else throwIO e) + keepTempDir = isJust `fmap` maybeGetEnv "DARCS_KEEP_TMPDIR" + +environmentHelpKeepTmpdir :: ([String], [String]) +environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[ + "If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will", + "not remove the temporary directories it creates. This is intended", + "primarily for debugging Darcs itself, but it can also be useful, for", + "example, to determine why your test preference (see `darcs setpref`)", + "is failing when you run `darcs record`, but working when run manually."]) + +-- |'withPermDir' is like 'withTempDir', except that it doesn't +-- delete the directory afterwards. +withPermDir :: String -> (AbsolutePath -> IO a) -> IO a +withPermDir = withDir Perm + +-- |'withTempDir' creates an empty directory and then removes it when it +-- is no longer needed. withTempDir creates a temporary directory. The +-- location of that directory is determined by the contents of +-- _darcs/prefs/tmpdir, if it exists, otherwise by @$DARCS_TMPDIR@, and if +-- that doesn't exist then whatever your operating system considers to be a +-- a temporary directory (e.g. @$TMPDIR@ under Unix, @$TEMP@ under +-- Windows). +-- +-- If none of those exist it creates the temporary directory +-- in the current directory, unless the current directory is under a _darcs +-- directory, in which case the temporary directory in the parent of the highest +-- _darcs directory to avoid accidentally corrupting darcs's internals. +-- This should not fail, but if it does indeed fail, we go ahead and use the +-- current directory anyway. If @$DARCS_KEEP_TMPDIR@ variable is set +-- temporary directory is not removed, this can be useful for debugging. +withTempDir :: String -> (AbsolutePath -> IO a) -> IO a +withTempDir = withDir Temp + +withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a +withDelayedDir = withDir Delayed + +rmRecursive :: FilePath -> IO () +rmRecursive d = + do isd <- doesDirectoryReallyExist d + if not isd + then removeFile d + else do conts <- actual_dir_contents + withCurrentDirectory d $ + mapM_ rmRecursive conts + removeDirectory d + where actual_dir_contents = -- doesn't include . or .. + do c <- getDirectoryContents d + return $ filter (/=".") $ filter (/="..") c + +worldReadableTemp :: String -> IO String +worldReadableTemp f = wrt 0 + where wrt :: Int -> IO String + wrt 100 = fail $ "Failure creating temp named "++f + wrt n = let f_new = f++"-"++show n + in do ok <- takeFile f_new + if ok then return f_new + else wrt (n+1) + +withNamedTemp :: String -> (String -> IO a) -> IO a +withNamedTemp n = bracket get_empty_file removeFileMayNotExist + where get_empty_file = worldReadableTemp n + +readBinFile :: FilePathLike p => p -> IO String +readBinFile = fmap BC.unpack . B.readFile . toFilePath + +-- | Reads a file. Differs from readBinFile in that it interprets the file in +-- the current locale instead of as ISO-8859-1. +readLocaleFile :: FilePathLike p => p -> IO String +readLocaleFile f = decodeLocale `fmap` B.readFile (toFilePath f) + +readDocBinFile :: FilePathLike p => p -> IO Doc +readDocBinFile fp = do ps <- B.readFile $ toFilePath fp + return $ if B.null ps then empty else packedString ps + +appendBinFile :: FilePathLike p => p -> String -> IO () +appendBinFile f s = appendToFile f $ \h -> hPutStr h s + +appendDocBinFile :: FilePathLike p => p -> Doc -> IO () +appendDocBinFile f d = appendToFile f $ \h -> hPutDoc Standard h d + +writeBinFile :: FilePathLike p => p -> String -> IO () +writeBinFile f s = writeToFile f $ \h -> hPutStr h s + +-- | Writes a file. Differs from writeBinFile in that it writes the string +-- encoded with the current locale instead of what GHC thinks is right. +writeLocaleFile :: FilePathLike p => p -> String -> IO () +writeLocaleFile f s = writeToFile f $ \h -> B.hPut h (encodeLocale s) + +writeDocBinFile :: FilePathLike p => p -> Doc -> IO () +writeDocBinFile f d = writeToFile f $ \h -> hPutDoc Standard h d + +writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO () +writeAtomicFilePS f ps = writeToFile f $ \h -> B.hPut h ps + +gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO () +gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps] + +gzWriteAtomicFilePSs :: FilePathLike p => p -> [B.ByteString] -> IO () +gzWriteAtomicFilePSs f pss = + withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do + gzWriteFilePSs newf pss + already_exists <- doesFileExist $ toFilePath f + when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f) + setFileMode newf mode + `catchall` return () + renameFile newf (toFilePath f) + +gzWriteDocFile :: FilePathLike p => p -> Doc -> IO () +gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs Standard d + +writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO () +writeToFile f job = + withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do + withBinaryFile newf WriteMode job + already_exists <- doesFileExist (toFilePath f) + when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f) + setFileMode newf mode + `catchall` return () + renameFile newf (toFilePath f) + +appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO () +appendToFile f job = withSignalsBlocked $ + withBinaryFile (toFilePath f) AppendMode job + + +addToErrorLoc :: IOException + -> String + -> IOException +addToErrorLoc ioe s = annotateIOError ioe s Nothing Nothing diff --git a/src/Darcs/Util/Path.hs b/src/Darcs/Util/Path.hs --- a/src/Darcs/Util/Path.hs +++ b/src/Darcs/Util/Path.hs @@ -23,8 +23,7 @@ {-# LANGUAGE CPP #-} module Darcs.Util.Path - ( module Storage.Hashed.AnchoredPath - , FileName( ) + ( FileName( ) , fp2fn , fn2fp , fn2ps @@ -74,16 +73,28 @@ -- * Tree filtering. , filterFilePaths , filterPaths - ) where + -- * AnchoredPaths: relative paths within a Tree. All paths are + -- anchored at a certain root (this is usually the Tree root). They are + -- represented by a list of Names (these are just strict bytestrings). + , Name(..) + , AnchoredPath(..) + , anchoredRoot + , appendPath + , anchorPath + , isPrefix + , parent, parents, catPaths, flatten, makeName, appendToName + -- * Unsafe AnchoredPath functions. + , floatBS, floatPath, replacePrefixPath ) where -import Storage.Hashed.AnchoredPath +import Prelude () +import Darcs.Prelude -import Control.Applicative ( (<$>) ) import Data.List ( isPrefixOf , isSuffixOf , stripPrefix , intersect + , inits ) import Data.Char ( isSpace, chr, ord ) import Control.Exception ( tryJust, bracket_ ) @@ -95,19 +106,20 @@ import System.Directory ( doesDirectoryExist, doesFileExist ) import qualified System.FilePath.Posix as FilePath ( normalise ) import qualified System.FilePath as NativeFilePath ( takeFileName, takeDirectory ) -import System.FilePath ( splitDirectories ) +import System.FilePath( (), splitDirectories, normalise, dropTrailingPathSeparator ) import System.Posix.Files ( isDirectory, getSymbolicLinkStatus ) import Darcs.Util.ByteString ( packStringToUTF8, unpackPSFromUTF8 ) -import qualified Data.ByteString.Char8 as BC (unpack, pack) +import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString as B (ByteString) -import Data.Binary +import Data.Binary import Darcs.Util.Global ( darcsdir ) import Darcs.Util.URL ( isAbsolute, isRelative, isSshNopath ) #include "impossible.h" + -- | FileName is an abstract type intended to facilitate the input and output of -- unicode filenames. newtype FileName = FN FilePath deriving ( Eq, Ord ) @@ -261,10 +273,10 @@ class FilePathOrURL a where - toPath :: a -> String + toPath :: a -> String class FilePathOrURL a => FilePathLike a where - toFilePath :: a -> FilePath + toFilePath :: a -> FilePath -- | Paths which are relative to the local darcs repository and normalized. -- Note: These are understood not to have the dot in front. @@ -279,35 +291,35 @@ data AbsoluteOrRemotePath = AbsP AbsolutePath | RmtP String deriving (Eq, Ord) instance FilePathOrURL AbsolutePath where - toPath (AbsolutePath x) = x + toPath (AbsolutePath x) = x instance FilePathOrURL SubPath where - toPath (SubPath x) = x + toPath (SubPath x) = x instance CharLike c => FilePathOrURL [c] where - toPath = toFilePath + toPath = toFilePath instance FilePathOrURL AbsoluteOrRemotePath where - toPath (AbsP a) = toPath a - toPath (RmtP r) = r + toPath (AbsP a) = toPath a + toPath (RmtP r) = r instance FilePathOrURL FileName where - toPath = fn2fp + toPath = fn2fp instance FilePathLike FileName where - toFilePath = fn2fp + toFilePath = fn2fp instance FilePathLike AbsolutePath where - toFilePath (AbsolutePath x) = x + toFilePath (AbsolutePath x) = x instance FilePathLike SubPath where - toFilePath (SubPath x) = x + toFilePath (SubPath x) = x class CharLike c where - toChar :: c -> Char - fromChar :: Char -> c + toChar :: c -> Char + fromChar :: Char -> c instance CharLike Char where - toChar = id - fromChar = id + toChar = id + fromChar = id instance CharLike c => FilePathLike [c] where - toFilePath = map toChar + toFilePath = map toChar -- | Make the second path relative to the first, if possible makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath @@ -552,4 +564,101 @@ -- | Transform a SubPath into an AnchoredPath. floatSubPath :: SubPath -> AnchoredPath floatSubPath = floatPath . fn2fp . sp2fn + +------------------------------- +-- AnchoredPath utilities +-- +newtype Name = Name BC.ByteString deriving (Eq, Show, Ord) + +-- | This is a type of "sane" file paths. These are always canonic in the sense +-- that there are no stray slashes, no ".." components and similar. They are +-- usually used to refer to a location within a Tree, but a relative filesystem +-- path works just as well. These are either constructed from individual name +-- components (using "appendPath", "catPaths" and "makeName"), or converted +-- from a FilePath ("floatPath" -- but take care when doing that) or . +newtype AnchoredPath = AnchoredPath [Name] deriving (Eq, Show, Ord) + +-- | Check whether a path is a prefix of another path. +isPrefix :: AnchoredPath -> AnchoredPath -> Bool +(AnchoredPath a) `isPrefix` (AnchoredPath b) = a `isPrefixOf` b + +-- | Append an element to the end of a path. +appendPath :: AnchoredPath -> Name -> AnchoredPath +appendPath (AnchoredPath p) n = + case n of + (Name s) | s == BC.empty -> AnchoredPath p + | s == BC.pack "." -> AnchoredPath p + | otherwise -> AnchoredPath $ p ++ [n] + +-- | Catenate two paths together. Not very safe, but sometimes useful +-- (e.g. when you are representing paths relative to a different point than a +-- Tree root). +catPaths :: AnchoredPath -> AnchoredPath -> AnchoredPath +catPaths (AnchoredPath p) (AnchoredPath n) = AnchoredPath $ p ++ n + +-- | Get parent (path) of a given path. foo/bar/baz -> foo/bar +parent :: AnchoredPath -> AnchoredPath +parent (AnchoredPath x) = AnchoredPath (init x) + +-- | List all parents of a given path. foo/bar/baz -> [foo, foo/bar] +parents :: AnchoredPath -> [AnchoredPath] +parents (AnchoredPath x) = map AnchoredPath . init . inits $ x + +-- | Take a "root" directory and an anchored path and produce a full +-- 'FilePath'. Moreover, you can use @anchorPath \"\"@ to get a relative +-- 'FilePath'. +anchorPath :: FilePath -> AnchoredPath -> FilePath +anchorPath dir p = dir BC.unpack (flatten p) +{-# INLINE anchorPath #-} + +-- | Unsafe. Only ever use on bytestrings that came from flatten on a +-- pre-existing AnchoredPath. +floatBS :: BC.ByteString -> AnchoredPath +floatBS = AnchoredPath . map Name . takeWhile (not . BC.null) . BC.split '/' + +flatten :: AnchoredPath -> BC.ByteString +flatten (AnchoredPath []) = BC.singleton '.' +flatten (AnchoredPath p) = BC.intercalate (BC.singleton '/') + [ n | (Name n) <- p ] + +makeName :: String -> Name +makeName ".." = error ".. is not a valid AnchoredPath component name" +makeName n | '/' `elem` n = error "/ may not occur in a valid AnchoredPath component name" + | otherwise = Name $ BC.pack n + +-- | Take a relative FilePath and turn it into an AnchoredPath. The operation +-- is (relatively) unsafe. Basically, by using floatPath, you are testifying +-- that the argument is a path relative to some common root -- i.e. the root of +-- the associated "Tree" object. Also, there are certain invariants about +-- AnchoredPath that this function tries hard to preserve, but probably cannot +-- guarantee (i.e. this is a best-effort thing). You should sanitize any +-- FilePaths before you declare them "good" by converting into AnchoredPath +-- (using this function). +floatPath :: FilePath -> AnchoredPath +floatPath = make . splitDirectories . normalise . dropTrailingPathSeparator + where make ["."] = AnchoredPath [] + make x = AnchoredPath $ map (Name . BC.pack) x + + +anchoredRoot :: AnchoredPath +anchoredRoot = AnchoredPath [] + +-- | Take a prefix path, the changed prefix path, and a path to change. +-- Assumes the prefix path is a valid prefix. If prefix is wrong return +-- AnchoredPath []. +replacePrefixPath :: AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath +replacePrefixPath (AnchoredPath []) b c = catPaths b c +replacePrefixPath (AnchoredPath (r:p)) b (AnchoredPath (r':p')) + | r == r' = replacePrefixPath (AnchoredPath p) b (AnchoredPath p') + | otherwise = AnchoredPath [] +replacePrefixPath _ _ _ = AnchoredPath [] + +-- | Append a ByteString to the last Name of an AnchoredPath. +appendToName :: AnchoredPath -> String -> AnchoredPath +appendToName (AnchoredPath p) s = AnchoredPath (init p++[Name finalname]) + where suffix = BC.pack s + finalname | suffix `elem` (BC.tails lastname) = lastname + | otherwise = BC.append lastname suffix + lastname = case last p of + Name name -> name diff --git a/src/Darcs/Util/Printer.hs b/src/Darcs/Util/Printer.hs --- a/src/Darcs/Util/Printer.hs +++ b/src/Darcs/Util/Printer.hs @@ -36,33 +36,61 @@ -- This code was made generic in the element type by Juliusz Chroboczek. module Darcs.Util.Printer ( - Printable(..), Doc(Doc,unDoc), Printers, Printers'(..), Printer, Color(..) + -- * 'Doc' type and structural combinators + Doc(Doc,unDoc) + , empty, (<>), (), (<+>), ($$), vcat, vsep, hcat, hsep + , minus, newline, plus, space, backslash, lparen, rparen + , parens + -- * Constructing 'Doc's + , text + , hiddenText + , invisibleText + , wrapText, quoted + , userchunk, packedString + , prefix + , hiddenPrefix + , insertBeforeLastline + , prefixLines + , invisiblePS, userchunkPS + -- * Rendering , RenderMode(..) + , renderString, renderStringWith, renderPS, renderPSWith + , renderPSs, renderPSsWith + -- * Printers + , Printers + , Printers'(..) + , Printer + , simplePrinters, invisiblePrinter, simplePrinter + -- * Printables + , Printable(..) + , doc + , printable, invisiblePrintable, hiddenPrintable, userchunkPrintable + -- * Constructing colored 'Doc's + , Color(..) + , blueText, redText, greenText, magentaText, cyanText + , colorText + , lineColor + -- * IO , hPutDoc, hPutDocLn, putDoc, putDocLn , hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith , hPutDocCompr , debugDocLn - , renderString, renderStringWith, renderPS, renderPSWith - , renderPSs, renderPSsWith, lineColor - , prefix, insertBeforeLastline, colorText, invisibleText - , prefixLines - , hiddenText, hiddenPrefix, userchunk, text - , printable, wrapText - , blueText, redText, greenText, magentaText, cyanText - , unsafeText, unsafeBoth, unsafeBothText, unsafeChar - , invisiblePS, packedString, unsafePackedString, userchunkPS - , simplePrinters, invisiblePrinter, simplePrinter - , doc, empty, (<>), (), (<+>), ($$), vcat, vsep, hcat - , minus, newline, plus, space, backslash, lparen, rparen - , parens + , ePutDocLn , errorDoc + -- * Unsafe constructors + , unsafeText, unsafeBoth, unsafeBothText, unsafeChar + , unsafePackedString ) where +import Prelude () +import Darcs.Prelude + import Control.Exception ( throwIO, ErrorCall(..) ) import Data.String ( IsString(..) ) import Data.List (intersperse) +import Data.Monoid ( (<>) ) import GHC.Stack ( currentCallStack ) -import System.IO (Handle, stdout, hPutStr) +import System.IO (Handle, stdout, stderr, hPutStr) import System.IO.Unsafe ( unsafePerformIO ) import qualified Data.ByteString as B (ByteString, hPut, concat) import qualified Data.ByteString.Char8 as BC (unpack, pack, singleton) @@ -76,36 +104,47 @@ | PS !B.ByteString | Both !String !B.ByteString --- | 'spaceP' is the 'Printable' representation of a space. +-- | 'Printable' representation of a space spaceP :: Printable spaceP = Both " " (BC.singleton ' ') --- | 'newlineP' is the 'Printable' representation of a newline. +-- | 'Printable' representation of a newline. newlineP :: Printable newlineP = S "\n" --- | Minimal 'Doc's representing the common characters 'space', 'newline' --- 'minus', 'plus', and 'backslash'. -space, newline, plus, minus, backslash :: Doc -space = unsafeBoth " " (BC.singleton ' ') -newline = unsafeChar '\n' -minus = unsafeBoth "-" (BC.singleton '-') -plus = unsafeBoth "+" (BC.singleton '+') +-- | A 'Doc' representing a space (\" \") +space :: Doc +space = unsafeBoth " " (BC.singleton ' ') + +-- | A 'Doc' representing a newline +newline :: Doc +newline = unsafeChar '\n' + +-- | A 'Doc' representing a \"-\" +minus :: Doc +minus = unsafeBoth "-" (BC.singleton '-') + +-- | A 'Doc' representing a \"+\" +plus :: Doc +plus = unsafeBoth "+" (BC.singleton '+') + +-- | A 'Doc' representing a \"\\\" +backslash :: Doc backslash = unsafeBoth "\\" (BC.singleton '\\') --- | 'lparen' is the 'Doc' that represents @\"(\"@ +-- | A 'Doc' that represents @\"(\"@ lparen :: Doc lparen = unsafeBoth "(" (BC.singleton '(') --- | 'rparen' is the 'Doc' that represents @\")\"@ +-- | A 'Doc' that represents @\")\"@ rparen :: Doc rparen = unsafeBoth ")" (BC.singleton ')') --- | @'parens' doc@ returns a 'Doc' with the content of @doc@ put within --- a pair of parenthesis. +-- | prop> parens d = lparen <> d <> rparen parens :: Doc -> Doc parens d = lparen <> d <> rparen +-- | Fail with a stack trace and the given 'Doc' as error message. errorDoc :: Doc -> a errorDoc x = unsafePerformIO $ do stack <- currentCallStack @@ -129,6 +168,14 @@ putDocLn :: Doc -> IO () putDocLn = hPutDocLn Encode stdout +-- | 'eputDocLn' puts a doc, followed by a newline to stderr using +-- 'simplePrinters'. Like putDocLn, it encodes with the user's locale. +-- This function is the recommended way to output messages that should +-- be visible to users on the console, but cannot (or should not) be +-- silenced even when --quiet is in effect. +ePutDocLn :: Doc -> IO () +ePutDocLn = hPutDocLn Encode stderr + -- | 'hputDocWith' puts a doc on the given handle using the given printer. hPutDocWith :: Printers -> RenderMode -> Handle -> Doc -> IO () hPutDocWith prs target h d = hPrintPrintables target h (renderWith (prs h) d) @@ -142,7 +189,7 @@ hPutDoc :: RenderMode -> Handle -> Doc -> IO () hPutDoc = hPutDocWith simplePrinters --- 'hputDocLn' puts a doc, followed by a newline on the given handle using +-- | 'hputDocLn' puts a doc, followed by a newline on the given handle using -- 'simplePrinters'. hPutDocLn :: RenderMode -> Handle -> Doc -> IO () hPutDocLn = hPutDocLnWith simplePrinters @@ -155,11 +202,11 @@ debugDocLn :: Doc -> IO () debugDocLn = debugMessage . renderString Standard --- | @'hPrintPrintables' h@ prints a list of 'Printable's to the handle h +-- | @'hPrintPrintables' h@ prints a list of 'Printable's to the handle @h@ hPrintPrintables :: RenderMode -> Handle -> [Printable] -> IO () hPrintPrintables target h = mapM_ (hPrintPrintable target h) --- | @hPrintPrintable h@ prints a 'Printable' to the handle h. +-- | @'hPrintPrintable' h@ prints a 'Printable' to the handle @h@. hPrintPrintable :: RenderMode -> Handle -> Printable -> IO () hPrintPrintable Standard h (S ps) = hPutStr h ps hPrintPrintable Encode h (S ps) = B.hPut h (encodeLocale ps) @@ -168,10 +215,12 @@ hPrintPrintable Standard h (Both _ ps) = B.hPut h ps hPrintPrintable Encode h (Both _ ps) = B.hPut h ps --- | a 'Doc' is a bit of enriched text. 'Doc's get concatanated using --- '<>', which is right-associative. +-- | A 'Doc' is a bit of enriched text. 'Doc's are concatenated using +-- '<>' from class 'Monoid', which is right-associative. newtype Doc = Doc { unDoc :: St -> Document } +-- | Together with the language extension OverloadedStrings, this allows to +-- use string literals where a 'Doc' is expected. instance IsString Doc where fromString = text @@ -330,6 +379,8 @@ invisiblePS = invisiblePrintable . PS -- | 'userchunkPS' creates a 'Doc' representing a user chunk from a 'B.ByteString'. +-- +-- Rrrright. And what, please is that supposed to mean? userchunkPS :: B.ByteString -> Doc userchunkPS = userchunkPrintable . PS @@ -357,7 +408,6 @@ userchunk :: String -> Doc userchunk = userchunkPrintable . S --- | 'blueText' creates a 'Doc' containing blue text from a @String@ blueText, redText, greenText, magentaText, cyanText :: String -> Doc blueText = colorText Blue redText = colorText Red @@ -378,14 +428,23 @@ add_to_line (l:ls) new | length l + length new > n = new:l:ls add_to_line (l:ls) new = (l ++ " " ++ new):ls --- | 'printable x' creates a 'Doc' from any 'Printable'. -printable, invisiblePrintable, hiddenPrintable, userchunkPrintable :: Printable -> Doc +-- | Creates a 'Doc' from any 'Printable'. +printable :: Printable -> Doc printable x = Doc $ \st -> defP (printers st) x st mkColorPrintable :: Color -> Printable -> Doc mkColorPrintable c x = Doc $ \st -> colorP (printers st) c x st + +-- | Creates an invisible 'Doc' from any 'Printable'. +invisiblePrintable :: Printable -> Doc invisiblePrintable x = Doc $ \st -> invisibleP (printers st) x st + +-- | Creates a hidden 'Doc' from any 'Printable'. +hiddenPrintable :: Printable -> Doc hiddenPrintable x = Doc $ \st -> hiddenP (printers st) x st + +-- | Creates... WTF is a userchunk??? +userchunkPrintable :: Printable -> Doc userchunkPrintable x = Doc $ \st -> userchunkP (printers st) x st -- | 'simplePrinters' is a 'Printers' which uses the set 'simplePriners\'' on any @@ -417,26 +476,25 @@ invisiblePrinter :: Printer invisiblePrinter _ = unDoc empty -infixr 6 <> +infixr 6 `append` infixr 6 <+> infixr 5 $$ --- | The empty 'Doc'. +-- | The empty 'Doc' empty :: Doc empty = Doc $ const Empty + doc :: ([Printable] -> [Printable]) -> Doc doc f = Doc $ const $ Document f --- | '(<>)' is the concatenation operator for 'Doc's -(<>) :: Doc -> Doc -> Doc --- | @a '' b@ is @a <> b@ if @a@ is not empty, else empty. -() :: Doc -> Doc -> Doc --- | @a '<+>' b@ is @a@ followed by a space, then @b@. -(<+>) :: Doc -> Doc -> Doc --- | @a '$$' b@ is @a@ above @b@. -($$) :: Doc -> Doc -> Doc --- a then b -Doc a <> Doc b = +-- | 'mappend' ('<>') is concatenation, 'mempty' is the 'empty' 'Doc' +instance Monoid Doc where + mempty = empty + mappend = append + +-- | Concatenation of two 'Doc's +append :: Doc -> Doc -> Doc +Doc a `append` Doc b = Doc $ \st -> case a st of Empty -> b st Document af -> @@ -444,7 +502,8 @@ Empty -> s Document bf -> bf s) --- empty if a empty, else a then b +-- | @a '' b@ is @a '<>' b@ if @a@ is not empty, else empty +() :: Doc -> Doc -> Doc Doc a Doc b = Doc $ \st -> case a st of Empty -> Empty @@ -452,7 +511,8 @@ Empty -> s Document bf -> bf s) --- a then space then b +-- | @a '<+>' b@ is @a@ followed by a space, then @b@ +(<+>) :: Doc -> Doc -> Doc Doc a <+> Doc b = Doc $ \st -> case a st of Empty -> b st @@ -461,7 +521,8 @@ Document bf -> spaceP:bf s) --- a above b +-- | @a '$$' b@ is @a@ above @b@ +($$) :: Doc -> Doc -> Doc Doc a $$ Doc b = Doc $ \st -> case a st of Empty -> b st @@ -472,17 +533,29 @@ where pf = currentPrefix st sf = lineColorS $ printers st --- | 'vcat' piles vertically a list of 'Doc's. +-- | Pile 'Doc's vertically vcat :: [Doc] -> Doc vcat [] = empty vcat ds = foldr1 ($$) ds --- | 'vsep' piles vertically a list of 'Doc's leaving a blank line between each. +-- | Pile 'Doc's vertically, with a blank line in between vsep :: [Doc] -> Doc vsep [] = empty vsep ds = foldr1 ($$) $ intersperse (text "") ds --- | 'hcat' concatenates (horizontally) a list of 'Doc's +-- | Concatenate 'Doc's horizontally hcat :: [Doc] -> Doc -hcat [] = empty -hcat ds = foldr1 (<>) ds +hcat = mconcat + +-- | Concatenate 'Doc's horizontally with a space as separator +hsep :: [Doc] -> Doc +hsep = foldr (<+>) empty + +-- | Quote a string for screen output +quoted :: String -> Doc +quoted s = text "\"" <> text (escape s) <> text "\"" + where + escape "" = "" + escape (c:cs) = if c `elem` ['\\', '"'] + then '\\' : c : escape cs + else c : escape cs diff --git a/src/Darcs/Util/Printer/Color.hs b/src/Darcs/Util/Printer/Color.hs --- a/src/Darcs/Util/Printer/Color.hs +++ b/src/Darcs/Util/Printer/Color.hs @@ -4,6 +4,9 @@ , environmentHelpColor, environmentHelpEscape, environmentHelpEscapeWhite ) where +import Prelude () +import Darcs.Prelude + import Darcs.Util.Printer ( Printer, Printers, Printers'(..), Printable(..), Color(..), RenderMode(..) , invisiblePrinter, (<>), (), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat @@ -11,7 +14,6 @@ , renderStringWith, prefix ) -import Prelude hiding ( catch ) import Control.Monad ( liftM ) import Control.Exception ( catch, IOException ) import Debug.Trace ( trace ) diff --git a/src/Darcs/Util/Progress.hs b/src/Darcs/Util/Progress.hs --- a/src/Darcs/Util/Progress.hs +++ b/src/Darcs/Util/Progress.hs @@ -29,6 +29,9 @@ ) where +import Prelude () +import Darcs.Prelude hiding ( lookup ) + import Prelude hiding (lookup) import Control.Arrow ( second ) diff --git a/src/Darcs/Util/Prompt.hs b/src/Darcs/Util/Prompt.hs --- a/src/Darcs/Util/Prompt.hs +++ b/src/Darcs/Util/Prompt.hs @@ -10,7 +10,8 @@ ) where -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude import Control.Monad ( void ) diff --git a/src/Darcs/Util/Show.hs b/src/Darcs/Util/Show.hs --- a/src/Darcs/Util/Show.hs +++ b/src/Darcs/Util/Show.hs @@ -2,6 +2,9 @@ ( appPrec, BSWrapper(..) ) where +import Prelude () +import Darcs.Prelude + import qualified Data.ByteString as B appPrec :: Int diff --git a/src/Darcs/Util/SignalHandler.hs b/src/Darcs/Util/SignalHandler.hs --- a/src/Darcs/Util/SignalHandler.hs +++ b/src/Darcs/Util/SignalHandler.hs @@ -23,7 +23,8 @@ tryNonSignal, stdoutIsAPipe ) where -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude import System.IO.Error ( isUserError, ioeGetErrorString, ioeGetFileName ) import System.Exit ( exitWith, ExitCode ( ExitFailure ) ) diff --git a/src/Darcs/Util/Ssh.hs b/src/Darcs/Util/Ssh.hs --- a/src/Darcs/Util/Ssh.hs +++ b/src/Darcs/Util/Ssh.hs @@ -20,19 +20,47 @@ SshSettings(..) , defaultSsh , windows + , copySSH + , SSHCmd(..) + , getSSH + , environmentHelpSsh + , environmentHelpScp + , environmentHelpSshPort + , transferModeHeader ) where +import Prelude () +import Darcs.Prelude +import Prelude hiding ( lookup ) -import Control.Applicative ( (<$>), (<*>) ) -import Control.Exception ( catch, catchJust, SomeException ) +import System.Environment ( getEnv ) +import System.Exit ( ExitCode(..) ) + +import Control.Concurrent.MVar ( MVar, newMVar, withMVar, modifyMVar, modifyMVar_ ) +import Control.Exception ( throwIO, catch, catchJust, SomeException ) +import Control.Monad ( unless, (>=>) ) + +import qualified Data.ByteString as B (ByteString, hGet, writeFile ) + +import Data.Map ( Map, empty, insert, lookup ) + +import System.IO ( Handle, hSetBinaryMode, hPutStrLn, hGetLine, hFlush ) +import System.IO.Unsafe ( unsafePerformIO ) +import System.Process ( runInteractiveProcess, readProcessWithExitCode ) + +import Darcs.Util.SignalHandler ( catchNonSignal ) +import Darcs.Util.URL ( SshFilePath, sshFilePathOf, sshUhost, sshRepo, sshFile ) +import Darcs.Util.Text ( breakCommand ) +import Darcs.Util.Exception ( prettyException, catchall ) +import Darcs.Util.Exec ( readInteractiveProcess, ExecException(..), Redirect(AsIs) ) +import Darcs.Util.Progress ( withoutProgress, debugMessage, debugFail ) + +import qualified Darcs.Util.Ratified as Ratified ( hGetContents ) + import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isPrefixOf ) import System.Info ( os ) -import System.IO.Unsafe (unsafePerformIO) import System.IO.Error ( ioeGetErrorType, isDoesNotExistErrorType ) -import System.Process ( readProcessWithExitCode ) -import System.Environment ( getEnv ) -import Prelude hiding (catch) import Darcs.Util.Global ( whenDebugMode ) @@ -48,7 +76,7 @@ _defaultSsh :: IORef SshSettings _defaultSsh = unsafePerformIO $ newIORef =<< detectSsh - +{-# NOINLINE _defaultSsh #-} -- | Expected properties: -- @@ -89,3 +117,212 @@ defaultSsh :: SshSettings defaultSsh = unsafePerformIO $ readIORef _defaultSsh +{-# NOINLINE defaultSsh #-} + +-- | A re-usable connection to a remote darcs in transfer-mode. +-- It contains the three standard handles. +data Connection = C + { inp :: !Handle + , out :: !Handle + , err :: !Handle + } + +-- | Identifier (key) for a connection. +type RepoId = (String, String) -- (user@host,repodir) + +-- | Global mutable variable that contains open connections, +-- identified by the repoid part of the ssh file name. +-- Only one thread can use a connection at a time, which is why +-- we stuff them behind their own 'MVar's. +-- +-- We distinguish between a failed connection (represented by a +-- 'Nothing' entry in the map) and one that was never established +-- (the repoid is not in the map). Once a connection fails, +-- either when trying to establish it or during usage, it will not +-- be tried again. +sshConnections :: MVar (Map RepoId (Maybe (MVar Connection))) +sshConnections = unsafePerformIO $ newMVar empty +{-# NOINLINE sshConnections #-} + +-- | Wait for an existing connection to become available or, if none +-- is available, try to create a new one and cache it. +getSshConnection :: String -- ^ remote darcs command + -> SshFilePath -- ^ destination + -> IO (Maybe (MVar Connection)) -- ^ wrapper for the action +getSshConnection rdarcs sshfp = modifyMVar sshConnections $ \cmap -> do + let key = repoid sshfp + case lookup key cmap of + Nothing -> do + -- we have not yet tried with this key, do it now + mc <- newSshConnection rdarcs sshfp + case mc of + Nothing -> + -- failed, remember it, so we don't try again + return (insert key Nothing cmap, Nothing) + Just c -> do + -- success, remember and use + v <- newMVar c + return (insert key (Just v) cmap, Just v) + Just Nothing -> + -- we have tried to connect before, don't do it again + return (cmap, Nothing) + Just (Just v) -> + -- we do have a connection, return an action that + -- waits until it is available + return (cmap, Just v) + +-- | Try to create a new ssh connection to a remote darcs that runs the +-- transfer-mode command. This is tried only once per repoid. +newSshConnection :: String -> SshFilePath -> IO (Maybe Connection) +newSshConnection rdarcs sshfp = do + (sshcmd,sshargs_) <- getSSH SSH + debugMessage $ "Starting new ssh connection to " ++ sshUhost sshfp + let sshargs = sshargs_ ++ [sshUhost sshfp, rdarcs, + "transfer-mode","--repodir",sshRepo sshfp] + debugMessage $ unwords (sshcmd : sshargs) + (i,o,e,_) <- runInteractiveProcess sshcmd sshargs Nothing Nothing + do + hSetBinaryMode i True + hSetBinaryMode o True + l <- hGetLine o + unless (l == transferModeHeader) $ + debugFail "Couldn't start darcs transfer-mode on server" + return $ Just C { inp = i, out = o, err = e } + `catchNonSignal` \exn -> do + debugMessage $ "Failed to start ssh connection: " ++ prettyException exn + debugMessage $ unlines + [ "NOTE: the server may be running a version of darcs prior to 2.0.0." + , "" + , "Installing darcs 2 on the server will speed up ssh-based commands." + ] + return Nothing + +-- | Mark any connection associated with the given ssh file path +-- as failed, so it won't be tried again. +dropSshConnection :: RepoId -> IO () +dropSshConnection key = do + debugMessage $ "Dropping ssh failed connection to " ++ fst key ++ ":" ++ snd key + modifyMVar_ sshConnections (return . insert key Nothing) + +repoid :: SshFilePath -> RepoId +repoid sshfp = (sshUhost sshfp, sshRepo sshfp) + +grabSSH :: SshFilePath -> Connection -> IO B.ByteString +grabSSH src c = do + debugMessage $ "grabSSH src=" ++ sshFilePathOf src + let failwith e = do dropSshConnection (repoid src) + -- hGetContents is ok here because we're + -- only grabbing stderr, and we're also + -- about to throw the contents. + eee <- Ratified.hGetContents (err c) + debugFail $ e ++ " grabbing ssh file " ++ + sshFilePathOf src ++"\n" ++ eee + file = sshFile src + hPutStrLn (inp c) $ "get " ++ file + hFlush (inp c) + l2 <- hGetLine (out c) + if l2 == "got "++file + then do showlen <- hGetLine (out c) + case reads showlen of + [(len,"")] -> B.hGet (out c) len + _ -> failwith "Couldn't get length" + else if l2 == "error "++file + then do e <- hGetLine (out c) + case reads e of + (msg,_):_ -> debugFail $ "Error reading file remotely:\n"++msg + [] -> failwith "An error occurred" + else failwith "Error" + +copySSH :: String -> SshFilePath -> FilePath -> IO () +copySSH rdarcs src dest = do + debugMessage $ "copySSH file: " ++ sshFilePathOf src + -- TODO why do we disable progress reporting here? + withoutProgress $ do + mc <- getSshConnection rdarcs src + case mc of + Just v -> withMVar v (grabSSH src >=> B.writeFile dest) + Nothing -> do + -- remote 'darcs transfer-mode' does not work => use scp + let u = escape_dollar $ sshFilePathOf src + (scpcmd, args) <- getSSH SCP + let scp_args = filter (/="-q") args ++ [u, dest] + (r, scp_err) <- readInteractiveProcess scpcmd scp_args + unless (r == ExitSuccess) $ + throwIO $ ExecException scpcmd scp_args (AsIs,AsIs,AsIs) scp_err + where + -- '$' in filenames is troublesome for scp, for some reason. + escape_dollar :: String -> String + escape_dollar = concatMap tr + where + tr '$' = "\\$" + tr c = [c] + +transferModeHeader :: String +transferModeHeader = "Hello user, I am darcs transfer mode" + +-- --------------------------------------------------------------------- +-- older ssh helper functions +-- --------------------------------------------------------------------- + +data SSHCmd = SSH + | SCP + | SFTP + + +fromSshCmd :: SshSettings + -> SSHCmd + -> String +fromSshCmd s SSH = ssh s +fromSshCmd s SCP = scp s +fromSshCmd s SFTP = sftp s + + +-- | Return the command and arguments needed to run an ssh command +-- First try the appropriate darcs environment variable and SSH_PORT +-- defaulting to "ssh" and no specified port. +getSSH :: SSHCmd + -> IO (String, [String]) +getSSH cmd = do + port <- (portFlag cmd `fmap` getEnv "SSH_PORT") `catchall` return [] + let (sshcmd, ssh_args) = breakCommand command + return (sshcmd, ssh_args ++ port) + where + command = fromSshCmd defaultSsh cmd + portFlag SSH x = ["-p", x] + portFlag SCP x = ["-P", x] + portFlag SFTP x = ["-oPort=" ++ x] + + +environmentHelpSsh :: ([String], [String]) +environmentHelpSsh = (["DARCS_SSH"], [ + "Repositories of the form [user@]host:[dir] are taken to be remote", + "repositories, which Darcs accesses with the external program ssh(1).", + "", + "The environment variable $DARCS_SSH can be used to specify an", + "alternative SSH client. Arguments may be included, separated by", + "whitespace. The value is not interpreted by a shell, so shell", + "constructs cannot be used; in particular, it is not possible for the", + "program name to contain whitespace by using quoting or escaping."]) + + +environmentHelpScp :: ([String], [String]) +environmentHelpScp = (["DARCS_SCP", "DARCS_SFTP"], [ + "When reading from a remote repository, Darcs will attempt to run", + "`darcs transfer-mode` on the remote host. This will fail if the", + "remote host only has Darcs 1 installed, doesn't have Darcs installed", + "at all, or only allows SFTP.", + "", + "If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).", + "The commands invoked can be customized with the environment variables", + "$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.", + "If the remote end allows only sftp, try setting DARCS_SCP=sftp."]) + + +environmentHelpSshPort :: ([String], [String]) +environmentHelpSshPort = (["SSH_PORT"], [ + "If this environment variable is set, it will be used as the port", + "number for all SSH calls made by Darcs (when accessing remote", + "repositories over SSH). This is useful if your SSH server does not", + "run on the default port, and your SSH client does not support", + "ssh_config(5). OpenSSH users will probably prefer to put something", + "like `Host *.example.net Port 443` into their ~/.ssh/config file."]) diff --git a/src/Darcs/Util/Text.hs b/src/Darcs/Util/Text.hs --- a/src/Darcs/Util/Text.hs +++ b/src/Darcs/Util/Text.hs @@ -11,12 +11,17 @@ , chompTrailingNewline -- * Text processing , breakCommand + , quote + , pathlist ) where +import Prelude () +import Darcs.Prelude + import Control.Arrow ( first ) import Data.List ( intercalate ) -import Darcs.Util.Printer ( Doc, (<>) ) +import Darcs.Util.Printer ( Doc, (<>), renderString, RenderMode(..), quoted, hsep ) sentence :: Doc -> Doc sentence = (<> ".") @@ -48,3 +53,14 @@ chompTrailingNewline :: String -> String chompTrailingNewline "" = "" chompTrailingNewline s = if last s == '\n' then init s else s + +-- | Quote a string for screen output. +quote :: String -> String +quote = renderString Encode . quoted + +-- | Format a list of 'FilePath's as quoted text. It deliberately refuses to +-- use English.andClauses but rather separates the quoted strings only with a +-- space, because this makes it usable for copy and paste e.g. as arguments to +-- another shell command. +pathlist :: [FilePath] -> Doc +pathlist paths = hsep (map quoted paths) diff --git a/src/Darcs/Util/Tree.hs b/src/Darcs/Util/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Util/Tree.hs @@ -0,0 +1,470 @@ +-- Copyright (C) 2009-2011 Petr Rockai +-- +-- BSD3 +{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, BangPatterns #-} +{-# LANGUAGE CPP #-} + +-- | The abstract representation of a Tree and useful abstract utilities to +-- handle those. +module Darcs.Util.Tree + ( Tree, Blob(..), TreeItem(..), ItemType(..), Hash(..) + , makeTree, makeTreeWithHash, emptyTree, emptyBlob, makeBlob, makeBlobBS + + -- * Unfolding stubbed (lazy) Trees. + -- + -- | By default, Tree obtained by a read function is stubbed: it will + -- contain Stub items that need to be executed in order to access the + -- respective subtrees. 'expand' will produce an unstubbed Tree. + , expandUpdate, expand, expandPath, checkExpand + + -- * Tree access and lookup. + , items, list, listImmediate, treeHash + , lookup, find, findFile, findTree, itemHash, itemType + , zipCommonFiles, zipFiles, zipTrees, diffTrees + + -- * Files (Blobs). + , readBlob + + -- * Filtering trees. + , FilterTree(..), restrict + + -- * Manipulating trees. + , modifyTree, updateTree, partiallyUpdateTree, updateSubtrees, overlay + , addMissingHashes ) where + +import Control.Exception( catch, IOException ) +import Prelude hiding( lookup, filter, all, (<$>) ) +import Darcs.Util.Path +import Darcs.Util.Hash + +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.ByteString.Char8 as BS +import qualified Data.Map as M + +import Data.Maybe( catMaybes, isNothing ) +import Data.Either( lefts, rights ) +import Data.List( union, sort ) +import Control.Monad( filterM ) +import Control.Applicative( (<$>) ) + +#include "impossible.h" + +-------------------------------- +-- Tree, Blob and friends +-- + +data Blob m = Blob !(m BL.ByteString) !Hash +data TreeItem m = File !(Blob m) + | SubTree !(Tree m) + | Stub !(m (Tree m)) !Hash + +data ItemType = TreeType | BlobType deriving (Show, Eq, Ord) + +-- | Abstraction of a filesystem tree. +-- Please note that the Tree returned by the respective read operations will +-- have TreeStub items in it. To obtain a Tree without such stubs, call +-- expand on it, eg.: +-- +-- > tree <- readDarcsPristine "." >>= expand +-- +-- When a Tree is expanded, it becomes \"final\". All stubs are forced and the +-- Tree can be traversed purely. Access to actual file contents stays in IO +-- though. +-- +-- A Tree may have a Hash associated with it. A pair of Tree's is identical +-- whenever their hashes are (the reverse need not hold, since not all Trees +-- come equipped with a hash). +data Tree m = Tree { items :: M.Map Name (TreeItem m) + -- | Get hash of a Tree. This is guaranteed to uniquely + -- identify the Tree (including any blob content), as far as + -- cryptographic hashes are concerned. Sha256 is recommended. + , treeHash :: !Hash } + +listImmediate :: Tree m -> [(Name, TreeItem m)] +listImmediate = M.toList . items + +-- | Get a hash of a TreeItem. May be Nothing. +itemHash :: TreeItem m -> Hash +itemHash (File (Blob _ h)) = h +itemHash (SubTree t) = treeHash t +itemHash (Stub _ h) = h + +itemType :: TreeItem m -> ItemType +itemType (File _) = BlobType +itemType (SubTree _) = TreeType +itemType (Stub _ _) = TreeType + +emptyTree :: (Monad m) => Tree m +emptyTree = Tree { items = M.empty + , treeHash = NoHash } + +emptyBlob :: (Monad m) => Blob m +emptyBlob = Blob (return BL.empty) NoHash + +makeBlob :: (Monad m) => BL.ByteString -> Blob m +makeBlob str = Blob (return str) (sha256 str) + +makeBlobBS :: (Monad m) => BS.ByteString -> Blob m +makeBlobBS s' = let s = BL.fromChunks [s'] in Blob (return s) (sha256 s) + +makeTree :: (Monad m) => [(Name,TreeItem m)] -> Tree m +makeTree l = Tree { items = M.fromList l + , treeHash = NoHash } + +makeTreeWithHash :: (Monad m) => [(Name,TreeItem m)] -> Hash -> Tree m +makeTreeWithHash l h = Tree { items = M.fromList l + , treeHash = h } + +----------------------------------- +-- Tree access and lookup +-- + +-- | Look up a 'Tree' item (an immediate subtree or blob). +lookup :: Tree m -> Name -> Maybe (TreeItem m) +lookup t n = M.lookup n (items t) + +find' :: TreeItem m -> AnchoredPath -> Maybe (TreeItem m) +find' t (AnchoredPath []) = Just t +find' (SubTree t) (AnchoredPath (d : rest)) = + case lookup t d of + Just sub -> find' sub (AnchoredPath rest) + Nothing -> Nothing +find' _ _ = Nothing + +-- | Find a 'TreeItem' by its path. Gives 'Nothing' if the path is invalid. +find :: Tree m -> AnchoredPath -> Maybe (TreeItem m) +find = find' . SubTree + +-- | Find a 'Blob' by its path. Gives 'Nothing' if the path is invalid, or does +-- not point to a Blob. +findFile :: Tree m -> AnchoredPath -> Maybe (Blob m) +findFile t p = case find t p of + Just (File x) -> Just x + _ -> Nothing + +-- | Find a 'Tree' by its path. Gives 'Nothing' if the path is invalid, or does +-- not point to a Tree. +findTree :: Tree m -> AnchoredPath -> Maybe (Tree m) +findTree t p = case find t p of + Just (SubTree x) -> Just x + _ -> Nothing + +-- | List all contents of a 'Tree'. +list :: Tree m -> [(AnchoredPath, TreeItem m)] +list t_ = paths t_ (AnchoredPath []) + where paths t p = [ (appendPath p n, i) + | (n,i) <- listImmediate t ] ++ + concat [ paths subt (appendPath p subn) + | (subn, SubTree subt) <- listImmediate t ] + +expandUpdate :: (Monad m) => (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m) +expandUpdate update t_ = go (AnchoredPath []) t_ + where go path t = do + let subtree (name, sub) = do tree <- go (path `appendPath` name) =<< unstub sub + return (name, SubTree tree) + expanded <- mapM subtree [ x | x@(_, item) <- listImmediate t, isSub item ] + let orig_map = M.filter (not . isSub) (items t) + expanded_map = M.fromList expanded + tree = t { items = M.union orig_map expanded_map } + update path tree + +-- | Expand a stubbed Tree into a one with no stubs in it. You might want to +-- filter the tree before expanding to save IO. This is the basic +-- implementation, which may be overriden by some Tree instances (this is +-- especially true of the Index case). +expand :: (Monad m) => Tree m -> m (Tree m) +expand = expandUpdate $ const return + +-- | Unfold a path in a (stubbed) Tree, such that the leaf node of the path is +-- reachable without crossing any stubs. Moreover, the leaf ought not be a Stub +-- in the resulting Tree. A non-existent path is expanded as far as it can be. +expandPath :: (Monad m) => Tree m -> AnchoredPath -> m (Tree m) +expandPath t (AnchoredPath []) = return t +expandPath t (AnchoredPath (n:rest)) = + case lookup t n of + (Just item) | isSub item -> amend t n rest =<< unstub item + _ -> return t -- fail $ "Descent error in expandPath: " ++ show path_ + where + amend t' name rest' sub = do + sub' <- expandPath sub (AnchoredPath rest') + let tree = t' { items = M.insert name (SubTree sub') (items t') } + return tree + +-- | Check the disk version of a Tree: expands it, and checks each +-- hash. Returns either the expanded tree or a list of AnchoredPaths +-- where there are problems. The first argument is the hashing function +-- used to create the tree. +checkExpand :: (TreeItem IO -> IO Hash) -> Tree IO + -> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)) +checkExpand hashFunc t = go (AnchoredPath []) t + where + go path t_ = do + let + subtree (name, sub) = + do let here = path `appendPath` name + sub' <- (Just <$> unstub sub) `catch` \(_ :: IOException) -> return Nothing + case sub' of + Nothing -> return $ Left [(here, treeHash t_, Nothing)] + Just sub'' -> do + treeOrTrouble <- go (path `appendPath` name) sub'' + return $ case treeOrTrouble of + Left problems -> Left problems + Right tree -> Right (name, SubTree tree) + badBlob (_, f@(File (Blob _ h))) = + fmap (/= h) (hashFunc f `catch` (\(_ :: IOException) -> return NoHash)) + badBlob _ = return False + render (name, f@(File (Blob _ h))) = do + h' <- (Just <$> hashFunc f) `catch` \(_ :: IOException) -> return Nothing + return (path `appendPath` name, h, h') + render (name, _) = return (path `appendPath` name, NoHash, Nothing) + subs <- mapM subtree [ x | x@(_, item) <- listImmediate t_, isSub item ] + badBlobs <- filterM badBlob (listImmediate t) >>= mapM render + let problems = badBlobs ++ concat (lefts subs) + if null problems + then do + let orig_map = M.filter (not . isSub) (items t) + expanded_map = M.fromList $ rights subs + tree = t_ {items = orig_map `M.union` expanded_map} + h' <- hashFunc (SubTree t_) + if h' `match` treeHash t_ + then return $ Right tree + else return $ Left [(path, treeHash t_, Just h')] + else return $ Left problems + +class (Monad m) => FilterTree a m where + -- | Given @pred tree@, produce a 'Tree' that only has items for which + -- @pred@ returns @True@. + -- The tree might contain stubs. When expanded, these will be subject to + -- filtering as well. + filter :: (AnchoredPath -> TreeItem m -> Bool) -> a m -> a m + +instance (Monad m) => FilterTree Tree m where + filter predicate t_ = filter' t_ (AnchoredPath []) + where filter' t path = t { items = M.mapMaybeWithKey (wibble path) $ items t } + wibble path name item = + let npath = path `appendPath` name in + if predicate npath item + then Just $ filterSub npath item + else Nothing + filterSub npath (SubTree t) = SubTree $ filter' t npath + filterSub npath (Stub stub h) = + Stub (do x <- stub + return $ filter' x npath) h + filterSub _ x = x + +-- | Given two Trees, a @guide@ and a @tree@, produces a new Tree that is a +-- identical to @tree@, but only has those items that are present in both +-- @tree@ and @guide@. The @guide@ Tree may not contain any stubs. +restrict :: (FilterTree t m, Monad n) => Tree n -> t m -> t m +restrict guide tree = filter accept tree + where accept path item = + case (find guide path, item) of + (Just (SubTree _), SubTree _) -> True + (Just (SubTree _), Stub _ _) -> True + (Just (File _), File _) -> True + (Just (Stub _ _), _) -> + bug "*sulk* Go away, you, you precondition violator!" + (_, _) -> False + +-- | Read a Blob into a Lazy ByteString. Might be backed by an mmap, use with +-- care. +readBlob :: Blob m -> m BL.ByteString +readBlob (Blob r _) = r + +-- | For every pair of corresponding blobs from the two supplied trees, +-- evaluate the supplied function and accumulate the results in a list. Hint: +-- to get IO actions through, just use sequence on the resulting list. +-- NB. This won't expand any stubs. +zipCommonFiles :: (AnchoredPath -> Blob m -> Blob m -> a) -> Tree m -> Tree m -> [a] +zipCommonFiles f a b = catMaybes [ flip (f p) x `fmap` findFile a p + | (p, File x) <- list b ] + +-- | For each file in each of the two supplied trees, evaluate the supplied +-- function (supplying the corresponding file from the other tree, or Nothing) +-- and accumulate the results in a list. Hint: to get IO actions through, just +-- use sequence on the resulting list. NB. This won't expand any stubs. +zipFiles :: (AnchoredPath -> Maybe (Blob m) -> Maybe (Blob m) -> a) + -> Tree m -> Tree m -> [a] +zipFiles f a b = [ f p (findFile a p) (findFile b p) + | p <- paths a `sortedUnion` paths b ] + where paths t = sort [ p | (p, File _) <- list t ] + +zipTrees :: (AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a) + -> Tree m -> Tree m -> [a] +zipTrees f a b = [ f p (find a p) (find b p) + | p <- reverse (paths a `sortedUnion` paths b) ] + where paths t = sort [ p | (p, _) <- list t ] + +-- | Helper function for taking the union of AnchoredPath lists that +-- are already sorted. This function does not check the precondition +-- so use it carefully. +sortedUnion :: [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath] +sortedUnion [] ys = ys +sortedUnion xs [] = xs +sortedUnion a@(x:xs) b@(y:ys) = case compare x y of + LT -> x : sortedUnion xs b + EQ -> x : sortedUnion xs ys + GT -> y : sortedUnion a ys + +-- | Cautiously extracts differing subtrees from a pair of Trees. It will never +-- do any unneccessary expanding. Tree hashes are used to cut the comparison as +-- high up the Tree branches as possible. The result is a pair of trees that do +-- not share any identical subtrees. They are derived from the first and second +-- parameters respectively and they are always fully expanded. It might be +-- advantageous to feed the result into 'zipFiles' or 'zipTrees'. +diffTrees :: forall m. (Functor m, Monad m) => Tree m -> Tree m -> m (Tree m, Tree m) +diffTrees left right = + if treeHash left `match` treeHash right + then return (emptyTree, emptyTree) + else diff left right + where isFile (File _) = True + isFile _ = False + notFile = not . isFile + isEmpty = null . listImmediate + subtree :: TreeItem m -> m (Tree m) + subtree (Stub x _) = x + subtree (SubTree x) = return x + subtree (File _) = bug "diffTrees tried to descend a File as a subtree" + maybeUnfold (Stub x _) = SubTree `fmap` (x >>= expand) + maybeUnfold (SubTree x) = SubTree `fmap` expand x + maybeUnfold i = return i + immediateN t = [ n | (n, _) <- listImmediate t ] + diff left' right' = do + is <- sequence [ + case (lookup left' n, lookup right' n) of + (Just l, Nothing) -> do + l' <- maybeUnfold l + return (n, Just l', Nothing) + (Nothing, Just r) -> do + r' <- maybeUnfold r + return (n, Nothing, Just r') + (Just l, Just r) + | itemHash l `match` itemHash r -> + return (n, Nothing, Nothing) + | notFile l && notFile r -> + do x <- subtree l + y <- subtree r + (x', y') <- diffTrees x y + if isEmpty x' && isEmpty y' + then return (n, Nothing, Nothing) + else return (n, Just $ SubTree x', Just $ SubTree y') + | isFile l && isFile r -> + return (n, Just l, Just r) + | otherwise -> + do l' <- maybeUnfold l + r' <- maybeUnfold r + return (n, Just l', Just r') + _ -> bug "n lookups failed" + | n <- immediateN left' `union` immediateN right' ] + let is_l = [ (n, l) | (n, Just l, _) <- is ] + is_r = [ (n, r) | (n, _, Just r) <- is ] + return (makeTree is_l, makeTree is_r) + +-- | Modify a Tree (by replacing, or removing or adding items). +modifyTree :: (Monad m) => Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m +modifyTree t_ p_ i_ = snd $ go t_ p_ i_ + where fix t unmod items' = (unmod, t { items = (countmap items':: Int) `seq` items' + , treeHash = if unmod then treeHash t else NoHash }) + + go t (AnchoredPath []) (Just (SubTree sub)) = (treeHash t `match` treeHash sub, sub) + + go t (AnchoredPath [n]) (Just item) = fix t unmod items' + where !items' = M.insert n item (items t) + !unmod = itemHash item `match` case lookup t n of + Nothing -> NoHash + Just i -> itemHash i + + go t (AnchoredPath [n]) Nothing = fix t unmod items' + where !items' = M.delete n (items t) + !unmod = isNothing $ lookup t n + + go t path@(AnchoredPath (n:r)) item = fix t unmod items' + where subtree s = go s (AnchoredPath r) item + !items' = M.insert n sub (items t) + !sub = snd sub' + !unmod = fst sub' + !sub' = case lookup t n of + Just (SubTree s) -> let (mod', sub'') = subtree s in (mod', SubTree sub'') + Just (Stub s _) -> (False, Stub (do x <- s + return $! snd $! subtree x) NoHash) + Nothing -> (False, SubTree $! snd $! subtree emptyTree) + _ -> bug $ "Modify tree at " ++ show path + + go _ (AnchoredPath []) (Just (Stub _ _)) = + bug $ "descending in modifyTree, case = (Just (Stub _ _)), path = " ++ show p_ + go _ (AnchoredPath []) (Just (File _)) = + bug $ "descending in modifyTree, case = (Just (File _)), path = " ++ show p_ + go _ (AnchoredPath []) Nothing = + bug $ "descending in modifyTree, case = Nothing, path = " ++ show p_ + +countmap :: forall a k. M.Map k a -> Int +countmap = M.fold (\_ i -> i + 1) 0 + +updateSubtrees :: (Tree m -> Tree m) -> Tree m -> Tree m +updateSubtrees fun t = + fun $ t { items = M.mapWithKey (curry $ snd . update) $ items t + , treeHash = NoHash } + where update (k, SubTree s) = (k, SubTree $ updateSubtrees fun s) + update (k, File f) = (k, File f) + update (_, Stub _ _) = bug "Stubs not supported in updateTreePostorder" + +-- | Does /not/ expand the tree. +updateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m) +updateTree fun t = partiallyUpdateTree fun (\_ _ -> True) t + +-- | Does /not/ expand the tree. +partiallyUpdateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m)) + -> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m) +partiallyUpdateTree fun predi t' = go (AnchoredPath []) t' + where go path t = do + items' <- M.fromList <$> mapM (maybeupdate path) (listImmediate t) + SubTree t'' <- fun . SubTree $ t { items = items' + , treeHash = NoHash } + return t'' + maybeupdate path (k, item) = if predi (path `appendPath` k) item + then update (path `appendPath` k) (k, item) + else return (k, item) + update path (k, SubTree tree) = (\new -> (k, SubTree new)) <$> go path tree + update _ (k, item) = (\new -> (k, new)) <$> fun item + +-- | Lay one tree over another. The resulting Tree will look like the base (1st +-- parameter) Tree, although any items also present in the overlay Tree will be +-- taken from the overlay. It is not allowed to overlay a different kind of an +-- object, nor it is allowed for the overlay to add new objects to base. This +-- means that the overlay Tree should be a subset of the base Tree (although +-- any extraneous items will be ignored by the implementation). +overlay :: (Functor m, Monad m) => Tree m -> Tree m -> Tree m +overlay base over = Tree { items = M.fromList immediate + , treeHash = NoHash } + where immediate = [ (n, get n) | (n, _) <- listImmediate base ] + get n = case (M.lookup n $ items base, M.lookup n $ items over) of + (Just (File _), Just f@(File _)) -> f + (Just (SubTree b), Just (SubTree o)) -> SubTree $ overlay b o + (Just (Stub b _), Just (SubTree o)) -> Stub (flip overlay o `fmap` b) NoHash + (Just (SubTree b), Just (Stub o _)) -> Stub (overlay b `fmap` o) NoHash + (Just (Stub b _), Just (Stub o _)) -> Stub (do o' <- o + b' <- b + return $ overlay b' o') NoHash + (Just x, _) -> x + (_, _) -> bug $ "Unexpected case in overlay at get " ++ show n ++ "." + +addMissingHashes :: (Monad m, Functor m) => (TreeItem m -> m Hash) -> Tree m -> m (Tree m) +addMissingHashes make = updateTree update -- use partiallyUpdateTree here + where update (SubTree t) = make (SubTree t) >>= \x -> return $ SubTree (t { treeHash = x }) + update (File blob@(Blob con NoHash)) = + do hash <- make $ File blob + return $ File (Blob con hash) + update (Stub s NoHash) = update . SubTree =<< s + update x = return x + +------ Private utilities shared among multiple functions. -------- + +unstub :: (Monad m) => TreeItem m -> m (Tree m) +unstub (Stub s _) = s +unstub (SubTree s) = return s +unstub _ = return emptyTree + +isSub :: TreeItem m -> Bool +isSub (File _) = False +isSub _ = True + diff --git a/src/Darcs/Util/Tree/Hashed.hs b/src/Darcs/Util/Tree/Hashed.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Util/Tree/Hashed.hs @@ -0,0 +1,245 @@ +-- Copyright (C) 2009-2011 Petr Rockai +-- +-- BSD3 +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} + +-- | A few darcs-specific utility functions. These are used for reading and +-- writing darcs and darcs-compatible hashed trees. +module Darcs.Util.Tree.Hashed + ( -- * Obtaining Trees. + -- + -- | Please note that Trees obtained this way will contain Stub + -- items. These need to be executed (they are IO actions) in order to be + -- accessed. Use 'expand' to do this. However, many operations are + -- perfectly fine to be used on a stubbed Tree (and it is often more + -- efficient to do everything that can be done before expanding a Tree). + readDarcsHashed + -- * Writing trees. + , writeDarcsHashed + -- * Interact with hashed tree + , hashedTreeIO + -- * Other + , readDarcsHashedDir + , readDarcsHashedNosize + , darcsAddMissingHashes + , darcsLocation + , darcsTreeHash + , decodeDarcsHash + , decodeDarcsSize + , darcsUpdateHashes + ) where + +import Prelude hiding ( lookup, (<$>) ) +import System.FilePath ( () ) + +import System.Directory( doesFileExist ) +import Codec.Compression.GZip( decompress, compress ) +import Control.Applicative( (<$>) ) + +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString as BS + +import Data.List( sortBy ) +import Data.Maybe( fromJust, isJust ) +import Control.Monad.State.Strict + +import Darcs.Util.Path +import Darcs.Util.ByteString ( FileSegment, readSegment ) +import Darcs.Util.Hash +import Darcs.Util.Tree +import Darcs.Util.Tree.Monad + +--------------------------------------------------------------------- +-- Utilities for coping with the darcs directory format. +-- + +darcsEncodeWhiteBS :: BS8.ByteString -> BS8.ByteString +darcsEncodeWhiteBS = BS8.pack . encodeWhite . BS8.unpack + +decodeDarcsHash :: BS8.ByteString -> Hash +decodeDarcsHash bs = case BS8.split '-' bs of + [s, h] | BS8.length s == 10 -> decodeBase16 h + _ -> decodeBase16 bs + +decodeDarcsSize :: BS8.ByteString -> Maybe Int +decodeDarcsSize bs = case BS8.split '-' bs of + [s, _] | BS8.length s == 10 -> + case reads (BS8.unpack s) of + [(x, _)] -> Just x + _ -> Nothing + _ -> Nothing + +darcsLocation :: FilePath -> (Maybe Int, Hash) -> FileSegment +darcsLocation dir (s,h) = case hash of + "" -> error "darcsLocation: invalid hash" + _ -> (dir prefix s ++ hash, Nothing) + where prefix Nothing = "" + prefix (Just s') = formatSize s' ++ "-" + formatSize s' = let n = show s' in replicate (10 - length n) '0' ++ n + hash = BS8.unpack (encodeBase16 h) + +---------------------------------------------- +-- Darcs directory format. +-- + +darcsFormatDir :: Tree m -> Maybe BL8.ByteString +darcsFormatDir t = BL8.fromChunks . concat <$> + mapM string (sortBy cmp $ listImmediate t) + where cmp (Name a, _) (Name b, _) = compare a b + string (Name name, item) = + do header <- case item of + File _ -> Just $ BS8.pack "file:\n" + _ -> Just $ BS8.pack "directory:\n" + hash <- case itemHash item of + NoHash -> Nothing + x -> Just $ encodeBase16 x + return [ header + , darcsEncodeWhiteBS name + , BS8.singleton '\n' + , hash, BS8.singleton '\n' ] + +darcsParseDir :: BL8.ByteString -> [(ItemType, Name, Maybe Int, Hash)] +darcsParseDir content = parse (BL8.split '\n' content) + where + parse (t:n:h':r) = (header t, + Name $ BS8.pack $ decodeWhite (BL8.unpack n), + decodeDarcsSize hash, + decodeDarcsHash hash) : parse r + where hash = BS8.concat $ BL8.toChunks h' + parse _ = [] + header x + | x == BL8.pack "file:" = BlobType + | x == BL8.pack "directory:" = TreeType + | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL8.unpack x + +---------------------------------------- +-- Utilities. +-- + +-- | Compute a darcs-compatible hash value for a tree-like structure. +darcsTreeHash :: Tree m -> Hash +darcsTreeHash t = case darcsFormatDir t of + Nothing -> NoHash + Just x -> sha256 x + +-- The following two are mostly for experimental use in Packed. + +darcsUpdateDirHashes :: Tree m -> Tree m +darcsUpdateDirHashes = updateSubtrees update + where update t = t { treeHash = darcsTreeHash t } + +darcsUpdateHashes :: (Monad m, Functor m) => Tree m -> m (Tree m) +darcsUpdateHashes = updateTree update + where update (SubTree t) = return . SubTree $ t { treeHash = darcsTreeHash t } + update (File blob@(Blob con _)) = + do hash <- sha256 <$> readBlob blob + return $ File (Blob con hash) + update stub = return stub + +darcsHash :: (Monad m, Functor m) => TreeItem m -> m Hash +darcsHash (SubTree t) = return $ darcsTreeHash t +darcsHash (File blob) = sha256 <$> readBlob blob +darcsHash _ = return NoHash + +darcsAddMissingHashes :: (Monad m, Functor m) => Tree m -> m (Tree m) +darcsAddMissingHashes = addMissingHashes darcsHash + +------------------------------------------- +-- Reading darcs pristine data +-- + +-- | Read and parse a darcs-style hashed directory listing from a given @dir@ +-- and with a given @hash@. +readDarcsHashedDir :: FilePath -> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)] +readDarcsHashedDir dir h = do + exist <- doesFileExist $ fst (darcsLocation dir h) + unless exist $ fail $ "error opening " ++ fst (darcsLocation dir h) + compressed <- readSegment $ darcsLocation dir h + let content = decompress compressed + return $ if BL8.null compressed + then [] + else darcsParseDir content + +-- | Read in a darcs-style hashed tree. This is mainly useful for reading +-- \"pristine.hashed\". You need to provide the root hash you are interested in +-- (found in _darcs/hashed_inventory). +readDarcsHashed' :: Bool -> FilePath -> (Maybe Int, Hash) -> IO (Tree IO) +readDarcsHashed' _ _ (_, NoHash) = fail "Cannot readDarcsHashed NoHash" +readDarcsHashed' sizefail dir root@(_, hash) = do + items' <- readDarcsHashedDir dir root + subs <- sequence [ + do when (sizefail && isJust s) $ + fail ("Unexpectedly encountered size-prefixed hash in " ++ dir) + case tp of + BlobType -> return (d, File $ + Blob (readBlob' (s, h)) h) + TreeType -> + do let t = readDarcsHashed dir (s, h) + return (d, Stub t h) + | (tp, d, s, h) <- items' ] + return $ makeTreeWithHash subs hash + where readBlob' = fmap decompress . readSegment . darcsLocation dir + +readDarcsHashed :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO) +readDarcsHashed = readDarcsHashed' False + +readDarcsHashedNosize :: FilePath -> Hash -> IO (Tree IO) +readDarcsHashedNosize dir hash = readDarcsHashed' True dir (Nothing, hash) + +---------------------------------------------------- +-- Writing darcs-style hashed trees. +-- + +-- | Write a Tree into a darcs-style hashed directory. +writeDarcsHashed :: Tree IO -> FilePath -> IO Hash +writeDarcsHashed tree' dir = + do t <- darcsUpdateDirHashes <$> expand tree' + sequence_ [ dump =<< readBlob b | (_, File b) <- list t ] + let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ] + _ <- mapM (dump . fromJust) dirs + return $ darcsTreeHash t + where dump bits = + do let name = dir BS8.unpack (encodeBase16 $ sha256 bits) + exist <- doesFileExist name + unless exist $ BL.writeFile name (compress bits) + +-- | Create a hashed file from a 'FilePath' and content. In case the file exists +-- it is kept untouched and is assumed to have the right content. XXX Corrupt +-- files should be probably renamed out of the way automatically or something +-- (probably when they are being read though). +fsCreateHashedFile :: FilePath -> BL8.ByteString -> TreeIO () +fsCreateHashedFile fn content = + liftIO $ do + exist <- doesFileExist fn + unless exist $ BL.writeFile fn content + +-- | Run a 'TreeIO' @action@ in a hashed setting. The @initial@ tree is assumed +-- to be fully available from the @directory@, and any changes will be written +-- out to same. Please note that actual filesystem files are never removed. +hashedTreeIO :: TreeIO a -- ^ action + -> Tree IO -- ^ initial + -> FilePath -- ^ directory + -> IO (a, Tree IO) +hashedTreeIO action t dir = + runTreeMonad action $ initialState t darcsHash updateItem + where updateItem _ (File b) = File <$> updateFile b + updateItem _ (SubTree s) = SubTree <$> updateSub s + updateItem _ x = return x + + updateFile b@(Blob _ !h) = do + content <- liftIO $ readBlob b + let fn = dir BS8.unpack (encodeBase16 h) + nblob = Blob (decompress <$> rblob) h + rblob = BL.fromChunks . return <$> BS.readFile fn + newcontent = compress content + fsCreateHashedFile fn newcontent + return nblob + updateSub s = do + let !hash = treeHash s + Just dirdata = darcsFormatDir s + fn = dir BS8.unpack (encodeBase16 hash) + fsCreateHashedFile fn (compress dirdata) + return s + diff --git a/src/Darcs/Util/Tree/Monad.hs b/src/Darcs/Util/Tree/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Util/Tree/Monad.hs @@ -0,0 +1,280 @@ +-- Copyright (C) 2009-2011 Petr Rockai +-- +-- BSD3 +{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances, FlexibleInstances #-} + +-- | An experimental monadic interface to Tree mutation. The main idea is to +-- simulate IO-ish manipulation of real filesystem (that's the state part of +-- the monad), and to keep memory usage down by reasonably often dumping the +-- intermediate data to disk and forgetting it. The monad interface itself is +-- generic, and a number of actual implementations can be used. This module +-- provides just 'virtualTreeIO' that never writes any changes, but may trigger +-- filesystem reads as appropriate. +module Darcs.Util.Tree.Monad + ( virtualTreeIO, virtualTreeMonad + , readFile, writeFile, createDirectory, rename, copy, unlink + , fileExists, directoryExists, exists, withDirectory + , currentDirectory + , tree, TreeState, TreeMonad, TreeIO, runTreeMonad + , initialState, replaceItem + , findM, findFileM, findTreeM + , TreeRO, TreeRW + ) where + +import Prelude hiding ( readFile, writeFile, (<$>) ) + +import Darcs.Util.Path +import Darcs.Util.Tree + +import Control.Applicative( (<$>) ) + +import Data.List( sortBy ) +import Data.Int( Int64 ) +import Data.Maybe( isNothing, isJust ) + +import qualified Data.ByteString.Lazy.Char8 as BL +import Control.Monad.RWS.Strict +import qualified Data.Map as M + +type Changed = M.Map AnchoredPath (Int64, Int64) -- size, age + +-- | Internal state of the 'TreeIO' monad. Keeps track of the current Tree +-- content, unsync'd changes and a current working directory (of the monad). +data TreeState m = TreeState { tree :: !(Tree m) + , changed :: !Changed + , changesize :: !Int64 + , maxage :: !Int64 + , updateHash :: TreeItem m -> m Hash + , update :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m) } + +-- | A 'TreeIO' monad. A sort of like IO but it keeps a 'TreeState' around as well, +-- which is a sort of virtual filesystem. Depending on how you obtained your +-- 'TreeIO', the actions in your virtual filesystem get somehow reflected in the +-- actual real filesystem. For 'virtualTreeIO', nothing happens in real +-- filesystem, however with 'plainTreeIO', the plain tree will be updated every +-- now and then, and with 'hashedTreeIO' a darcs-style hashed tree will get +-- updated. +type TreeMonad m = RWST AnchoredPath () (TreeState m) m +type TreeIO = TreeMonad IO + +class (Functor m, Monad m) => TreeRO m where + currentDirectory :: m AnchoredPath + withDirectory :: AnchoredPath -> m a -> m a + expandTo :: AnchoredPath -> m AnchoredPath + -- | Grab content of a file in the current Tree at the given path. + readFile :: AnchoredPath -> m BL.ByteString + -- | Check for existence of a node (file or directory, doesn't matter). + exists :: AnchoredPath -> m Bool + -- | Check for existence of a directory. + directoryExists ::AnchoredPath -> m Bool + -- | Check for existence of a file. + fileExists :: AnchoredPath -> m Bool + +class TreeRO m => TreeRW m where + -- | Change content of a file at a given path. The change will be + -- eventually flushed to disk, but might be buffered for some time. + writeFile :: AnchoredPath -> BL.ByteString -> m () + createDirectory :: AnchoredPath -> m () + unlink :: AnchoredPath -> m () + rename :: AnchoredPath -> AnchoredPath -> m () + copy :: AnchoredPath -> AnchoredPath -> m () + +initialState :: Tree m -> (TreeItem m -> m Hash) + -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)) -> TreeState m +initialState t uh u = TreeState { tree = t + , changed = M.empty + , changesize = 0 + , updateHash = uh + , maxage = 0 + , update = u } + +flush :: (Functor m, Monad m) => TreeMonad m () +flush = do changed' <- map fst . M.toList <$> gets changed + dirs' <- gets tree >>= \t -> return [ path | (path, SubTree _) <- list t ] + modify $ \st -> st { changed = M.empty, changesize = 0 } + forM_ (changed' ++ dirs' ++ [AnchoredPath []]) flushItem + +runTreeMonad' :: (Functor m, Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m) +runTreeMonad' action initial = do + (out, final, _) <- runRWST action (AnchoredPath []) initial + return (out, tree final) + +runTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m) +runTreeMonad action initial = do + let action' = do x <- action + flush + return x + runTreeMonad' action' initial + +-- | Run a TreeIO action without storing any changes. This is useful for +-- running monadic tree mutations for obtaining the resulting Tree (as opposed +-- to their effect of writing a modified tree to disk). The actions can do both +-- read and write -- reads are passed through to the actual filesystem, but the +-- writes are held in memory in a form of modified Tree. +virtualTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m) +virtualTreeMonad action t = runTreeMonad' action $ + initialState t (\_ -> return NoHash) (\_ x -> return x) + +virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO) +virtualTreeIO = virtualTreeMonad + +-- | Modifies an item in the current Tree. This action keeps an account of the +-- modified data, in changed and changesize, for subsequent flush +-- operations. Any modifications (as in "modifyTree") are allowed. +modifyItem :: (Functor m, Monad m) + => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m () +modifyItem path item = do + path' <- (`catPaths` path) `fmap` currentDirectory + age <- gets maxage + changed' <- gets changed + let getsize (Just (File b)) = lift (BL.length `fmap` readBlob b) + getsize _ = return 0 + size <- getsize item + let change = case M.lookup path' changed' of + Nothing -> size + Just (oldsize, _) -> size - oldsize + + modify $ \st -> st { tree = modifyTree (tree st) path' item + , changed = M.insert path' (size, age) (changed st) + , maxage = age + 1 + , changesize = changesize st + change } + +renameChanged :: (Functor m, Monad m) + => AnchoredPath -> AnchoredPath -> TreeMonad m () +renameChanged from to = modify $ \st -> st { changed = rename' $ changed st } + where rename' = M.fromList . map renameone . M.toList + renameone (x, d) | from `isPrefix` x = (to `catPaths` relative from x, d) + | otherwise = (x, d) + relative (AnchoredPath from') (AnchoredPath x) = AnchoredPath $ drop (length from') x + +-- | Replace an item with a new version without modifying the content of the +-- tree. This does not do any change tracking. Ought to be only used from a +-- 'sync' implementation for a particular storage format. The presumed use-case +-- is that an existing in-memory Blob is replaced with a one referring to an +-- on-disk file. +replaceItem :: (Functor m, Monad m) + => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m () +replaceItem path item = do + path' <- (`catPaths` path) `fmap` currentDirectory + modify $ \st -> st { tree = modifyTree (tree st) path' item } + +flushItem :: forall m. (Monad m, Functor m) => AnchoredPath -> TreeMonad m () +flushItem path = + do current <- gets tree + case find current path of + Nothing -> return () -- vanished, do nothing + Just x -> do y <- fixHash x + new <- gets update >>= ($ y) . ($ path) + replaceItem path (Just new) + where fixHash :: TreeItem m -> TreeMonad m (TreeItem m) + fixHash f@(File (Blob con NoHash)) = do + hash <- gets updateHash >>= \x -> lift $ x f + return $ File $ Blob con hash + fixHash (SubTree s) | treeHash s == NoHash = + gets updateHash >>= \f -> SubTree <$> lift (addMissingHashes f s) + fixHash x = return x + + +-- | If buffers are becoming large, sync, otherwise do nothing. +flushSome :: (Monad m, Functor m) => TreeMonad m () +flushSome = do x <- gets changesize + when (x > megs 100) $ do + remaining <- go =<< sortBy age . M.toList <$> gets changed + modify $ \s -> s { changed = M.fromList remaining } + where go [] = return [] + go ((path, (size, _)):chs) = do + x <- (\s -> s - size) <$> gets changesize + flushItem path + modify $ \s -> s { changesize = x } + if x > megs 50 then go chs + else return chs + megs = (* (1024 * 1024)) + age (_, (_, a)) (_, (_, b)) = compare a b + +instance (Functor m, Monad m) => TreeRO (TreeMonad m) where + expandTo p = + do t <- gets tree + p' <- (`catPaths` p) `fmap` ask + t' <- lift $ expandPath t p' + modify $ \st -> st { tree = t' } + return p' + + fileExists p = + do p' <- expandTo p + (isJust . (`findFile` p')) `fmap` gets tree + + directoryExists p = + do p' <- expandTo p + (isJust . (`findTree` p')) `fmap` gets tree + + exists p = + do p' <- expandTo p + (isJust . (`find` p')) `fmap` gets tree + + readFile p = + do p' <- expandTo p + t <- gets tree + let f = findFile t p' + case f of + Nothing -> fail $ "No such file " ++ show p' + Just x -> lift (readBlob x) + + currentDirectory = ask + withDirectory dir act = do + dir' <- expandTo dir + local (const dir') act + +instance (Functor m, Monad m) => TreeRW (TreeMonad m) where + writeFile p con = + do _ <- expandTo p + modifyItem p (Just blob) + flushSome + where blob = File $ Blob (return con) hash + hash = NoHash -- we would like to say "sha256 con" here, but due + -- to strictness of Hash in Blob, this would often + -- lead to unnecessary computation which would then + -- be discarded anyway; we rely on the sync + -- implementation to fix up any NoHash occurrences + + createDirectory p = + do _ <- expandTo p + modifyItem p $ Just $ SubTree emptyTree + + unlink p = + do _ <- expandTo p + modifyItem p Nothing + + rename from to = + do from' <- expandTo from + to' <- expandTo to + tr <- gets tree + let item = find tr from' + found_to = find tr to' + unless (isNothing found_to) $ + fail $ "Error renaming: destination " ++ show to ++ " exists." + unless (isNothing item) $ do + modifyItem from Nothing + modifyItem to item + renameChanged from to + + copy from to = + do from' <- expandTo from + _ <- expandTo to + tr <- gets tree + let item = find tr from' + unless (isNothing item) $ modifyItem to item + +findM' :: forall m a. (Monad m, Functor m) + => (Tree m -> AnchoredPath -> a) -> Tree m -> AnchoredPath -> m a +findM' what t path = fst <$> virtualTreeMonad (look path) t + where look :: AnchoredPath -> TreeMonad m a + look = expandTo >=> \p' -> flip what p' <$> gets tree + +findM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (TreeItem m)) +findM = findM' find + +findTreeM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (Tree m)) +findTreeM = findM' findTree + +findFileM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (Blob m)) +findFileM = findM' findFile diff --git a/src/Darcs/Util/Tree/Plain.hs b/src/Darcs/Util/Tree/Plain.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Util/Tree/Plain.hs @@ -0,0 +1,76 @@ +-- Copyright (C) 2009-2011 Petr Rockai +-- +-- BSD3 +-- | The plain format implementation resides in this module. The plain format +-- does not use any hashing and basically just wraps a normal filesystem tree +-- in the hashed-storage API. +-- +-- NB. The 'read' function on Blobs coming from a plain tree is susceptible to +-- file content changes. Since we use mmap in 'read', this will break +-- referential transparency and produce unexpected results. Please always make +-- sure that all parallel access to the underlying filesystem tree never +-- mutates files. Unlink + recreate is fine though (in other words, the +-- 'writePlainTree' implemented in this module is safe in this respect). +module Darcs.Util.Tree.Plain + ( -- * Obtaining Trees. + -- + -- | Please note that Trees obtained this way will contain Stub + -- items. These need to be executed (they are IO actions) in order to be + -- accessed. Use 'expand' to do this. However, many operations are + -- perfectly fine to be used on a stubbed Tree (and it is often more + -- efficient to do everything that can be done before expanding a Tree). + readPlainTree + + -- * Writing trees. + , writePlainTree + ) where + +import Data.Maybe( catMaybes ) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import System.FilePath( () ) +import System.Directory( getDirectoryContents + , createDirectoryIfMissing ) +import Bundled.Posix( getFileStatus, isDirectory, isRegularFile, FileStatus ) + +import Darcs.Util.Path +import Darcs.Util.File ( withCurrentDirectory ) +import Darcs.Util.ByteString ( readSegment ) +import Darcs.Util.Hash( Hash( NoHash) ) +import Darcs.Util.Tree( Tree(), TreeItem(..) + , Blob(..), makeTree + , list, readBlob, expand ) + +readPlainDir :: FilePath -> IO [(FilePath, FileStatus)] +readPlainDir dir = + withCurrentDirectory dir $ do + items <- getDirectoryContents "." + sequence [ do st <- getFileStatus s + return (s, st) + | s <- items, s `notElem` [ ".", ".." ] ] + +readPlainTree :: FilePath -> IO (Tree IO) +readPlainTree dir = do + items <- readPlainDir dir + let subs = catMaybes [ + let name = Name (BS8.pack name') + in case status of + _ | isDirectory status -> Just (name, Stub (readPlainTree (dir name')) NoHash) + _ | isRegularFile status -> Just (name, File $ Blob (readBlob' name) NoHash) + _ -> Nothing + | (name', status) <- items ] + return $ makeTree subs + where readBlob' (Name name) = readSegment (dir BS8.unpack name, Nothing) + +-- | Write out /full/ tree to a plain directory structure. If you instead want +-- to make incremental updates, refer to "Darcs.Util.Tree.Monad". +writePlainTree :: Tree IO -> FilePath -> IO () +writePlainTree t dir = do + createDirectoryIfMissing True dir + expand t >>= mapM_ write . list + where write (p, File b) = write' p b + write (p, SubTree _) = + createDirectoryIfMissing True (anchorPath dir p) + write _ = return () + write' p b = readBlob b >>= BL.writeFile (anchorPath dir p) + diff --git a/src/Darcs/Util/URL.hs b/src/Darcs/Util/URL.hs --- a/src/Darcs/Util/URL.hs +++ b/src/Darcs/Util/URL.hs @@ -45,17 +45,24 @@ unless a username is provided. Perhaps ssh-paths should use @\"ssh:\/\/user\@host\/path\"@-syntax instead? + + TODO: This whole module should be re-written using a regex matching library! + The way we do this here is error-prone and inefficient. -} module Darcs.Util.URL ( isValidLocalPath, isHttpUrl, isSshUrl, isRelative, isAbsolute, - isSshNopath, SshFilePath, sshRepo, sshUhost, sshFile, urlOf, splitSshUrl + isSshNopath, SshFilePath, sshRepo, sshUhost, sshFile, sshFilePathOf, splitSshUrl ) where -import Darcs.Util.Global(darcsdir) +import Prelude () +import Darcs.Prelude + +import Darcs.Util.Global ( darcsdir ) import Data.List ( isPrefixOf, isInfixOf ) import Data.Char ( isSpace ) -import qualified System.FilePath as FP (isRelative, isAbsolute, isValid) +import qualified System.FilePath as FP ( isRelative, isAbsolute, isValid ) +import System.FilePath ( () ) #include "impossible.h" @@ -91,7 +98,8 @@ ':':x@(_:_:_) -> ':' `notElem` x _ -> False --- | Gives the (user, host, dir) out of an ssh url +-- | Given an ssh URL or file path, split it into +-- user@host, repodir, and the file (with any _darcs/ prefix removed) splitSshUrl :: String -> SshFilePath splitSshUrl s | "ssh://" `isPrefixOf` s = let s' = drop (length "ssh://") $ dropWhile isSpace s @@ -106,7 +114,6 @@ , sshRepo = dir , sshFile = file } - cleanrepourl :: String -> (String, String) cleanrepourl zzz | dd `isPrefixOf` zzz = ([], drop (length dd) zzz) where dd = darcsdir++"/" @@ -119,8 +126,8 @@ cleanrepodir sep = cleanrepourl . drop 1 . dropWhile (/= sep) data SshFilePath = SshFP { sshUhost :: String - , sshRepo :: String - , sshFile :: String} + , sshRepo :: String + , sshFile :: String } -urlOf :: SshFilePath -> String -urlOf (SshFP uhost dir file) = uhost ++ ":" ++ dir ++ "/" ++ darcsdir ++ "/" ++ file +sshFilePathOf :: SshFilePath -> String +sshFilePathOf (SshFP uhost dir file) = uhost ++ ":" ++ (dir darcsdir file) diff --git a/src/Darcs/Util/Workaround.hs b/src/Darcs/Util/Workaround.hs --- a/src/Darcs/Util/Workaround.hs +++ b/src/Darcs/Util/Workaround.hs @@ -25,7 +25,8 @@ , sigPIPE ) where -import Prelude hiding ( catch ) +import Prelude () +import Darcs.Prelude #ifdef WIN32 diff --git a/src/win32/System/Posix.hs b/src/win32/System/Posix.hs --- a/src/win32/System/Posix.hs +++ b/src/win32/System/Posix.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE ForeignFunctionInterface #-} module System.Posix ( sleep ) where diff --git a/src/win32/System/Posix/Files.hsc b/src/win32/System/Posix/Files.hsc --- a/src/win32/System/Posix/Files.hsc +++ b/src/win32/System/Posix/Files.hsc @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE CPP, ForeignFunctionInterface #-} module System.Posix.Files( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink , getFdStatus, getFileStatus, getSymbolicLinkStatus diff --git a/tests/add-formerly-pl.sh b/tests/add-formerly-pl.sh deleted file mode 100644 --- a/tests/add-formerly-pl.sh +++ /dev/null @@ -1,58 +0,0 @@ -#!/usr/bin/env bash - -# Some tests for 'darcs add' - -. lib - -rm -rf temp1 temp2 - -# set up the repository -mkdir temp1 -cd temp1 -darcs init - -# Make sure that messages about directories call them directories -mkdir foo.d -mkdir oof.d -darcs add foo.d -darcs add oof.d -not darcs add -v foo.d 2>&1 | grep -i directory -# Try adding the same directory when it's already in the repo -not darcs add -v foo.d oof.d 2>&1 | grep -i directories - -# Make sure that messages about files call them files -touch bar -touch baz -darcs add bar -darcs add baz -not darcs add -v bar 2>&1 | grep -i "following file is" -not darcs add -v bar baz 2>&1 | grep -i "following files are" - -# Make sure that messages about both files and directories say so -not darcs add -v bar foo.d 2>&1 | grep -i 'files and directories' - - -# Make sure that parent directories are added for files -mkdir -p a.d/aa.d/aaa.d -mkdir -p b.d/bb.d -touch a.d/aa.d/aaa.d/baz -touch a.d/aa.d/aaa.d/bar -darcs add -v a.d/aa.d/aaa.d/bar a.d/aa.d/aaa.d/baz b.d/bb.d 2> log -test ! -s log # no output - -# Make sure that darcs doesn\'t complains about duplicate adds when adding parent dirs. -mkdir c.d -touch c.d/baz -darcs add -v c.d/baz c.d 2> log -test ! -s log # no output - -# Make sure that add output looks good when adding files in subdir -mkdir d.d -touch d.d/foo -darcs add -rv d.d | grep 'd.d/foo' - -# 'adding a non-existent dir and file gives the expected message -not darcs add -v notadir/notafile 2>&1 | grep -i 'does not exist' - -cd .. -rm -rf temp1 diff --git a/tests/add.sh b/tests/add.sh --- a/tests/add.sh +++ b/tests/add.sh @@ -17,3 +17,99 @@ rm -rf temp1 +# add in subdir + +darcs init temp1 +cd temp1 + +mkdir dir +echo zig > dir/foo +darcs add dir dir/foo +darcs record -am add_foo +cd .. +rm -rf temp1 + +# addrm + +darcs init temp1 +cd temp1 +touch foo +darcs add foo +darcs record -a -m add_foo -A x +darcs remove foo +darcs record -a -m del_foo -A x +cd .. +rm -rf temp1 + +# issue184: recording files in directories that haven't explicity been added + +darcs init temp1 +cd temp1 + +mkdir new +mkdir new/dir +touch new/dir/t.t +darcs add new/dir/t.t +darcs record -am test new/dir/t.t > log +not grep "don't want to record" log +cd .. + +rm -rf temp1 + +# Make sure that parent directories are added for files +darcs init temp1 +cd temp1 + +mkdir -p a.d/aa.d/aaa.d +mkdir -p b.d/bb.d +touch a.d/aa.d/aaa.d/baz +touch a.d/aa.d/aaa.d/bar +darcs add -v a.d/aa.d/aaa.d/bar a.d/aa.d/aaa.d/baz b.d/bb.d 2> log +test ! -s log # no output + +# Make sure that darcs doesn\'t complains about duplicate adds when adding parent dirs. +mkdir c.d +touch c.d/baz +darcs add -v c.d/baz c.d 2> log +test ! -s log # no output + +# Make sure that add output looks good when adding files in subdir +mkdir d.d +touch d.d/foo +darcs add -rv d.d | grep 'd.d/foo' + +# 'adding a non-existent dir and file gives the expected message +not darcs add -v notadir/notafile 2>&1 | grep -i 'does not exist' + +cd .. +rm -rf temp1 + +# test for darcs add behaviour on missing files. + +darcs init temp1 +cd temp1 + +empty='test ! -s' +nonempty='test -s' + +rm -f foo +darcs add foo >stdout 2>stderr && exit 1 || true +$empty stdout +$nonempty stderr + +>foo +darcs add foo >stdout 2>stderr +$nonempty stdout # confirmation message of added file +$empty stderr + +darcs add foo >stdout 2>stderr && exit 1 || true +$empty stdout +$nonempty stderr + +rm foo +darcs add foo >stdout 2>stderr && exit 1 || true +$empty stdout +$nonempty stderr + +cd .. +rm -rf temp1 diff --git a/tests/add_in_subdir.sh b/tests/add_in_subdir.sh deleted file mode 100644 --- a/tests/add_in_subdir.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/usr/bin/env bash - -. lib - -rm -rf temp1 temp2 -mkdir temp1 -cd temp1 -darcs init -mkdir dir -echo zig > dir/foo -darcs add dir dir/foo -darcs record -a -m add_foo -# Create second repo inside the first -darcs init --repodir=temp2 -cd temp2 -darcs pull -a ../../temp1 -darcs changes -s | grep "A ./dir/foo" -# no differences -diff ../../temp1/dir/foo dir/foo -cd .. - -rm -rf temp1 diff --git a/tests/addexitval.sh b/tests/addexitval.sh deleted file mode 100644 --- a/tests/addexitval.sh +++ /dev/null @@ -1,33 +0,0 @@ -#!/usr/bin/env bash - -. ./lib - -rm -rf tmp -mkdir tmp -cd tmp -darcs init - -empty='test ! -s' -nonempty='test -s' - -rm -f foo -darcs add foo >stdout 2>stderr && exit 1 || true -$empty stdout -$nonempty stderr - ->foo -darcs add foo >stdout 2>stderr -$nonempty stdout # print confirmation message of added file -$empty stderr - -darcs add foo >stdout 2>stderr && exit 1 || true -$empty stdout -$nonempty stderr - -rm foo -darcs add foo >stdout 2>stderr && exit 1 || true -$empty stdout -$nonempty stderr - -cd .. -rm -rf tmp diff --git a/tests/addmv.sh b/tests/addmv.sh deleted file mode 100644 --- a/tests/addmv.sh +++ /dev/null @@ -1,20 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf temp1 temp2 -mkdir temp1 temp2 -cd temp1 -darcs init -touch foo bar -darcs add foo bar -darcs record -a -m add_foo_bar -A x -darcs mv foo zig -darcs mv bar foo -darcs mv zig bar -darcs record -a -m swap_foo_bar -A x -cd ../temp2 -darcs init -darcs pull -v -a ../temp1 -cd .. -rm -rf temp1 temp2 - diff --git a/tests/addrace.sh b/tests/addrace.sh deleted file mode 100644 --- a/tests/addrace.sh +++ /dev/null @@ -1,18 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf temp1 temp2 -mkdir temp1 temp2 -cd temp1 -darcs init -echo zig > foo -darcs add foo -#sleep 1 -darcs record -a -m add_foo -A x -cd ../temp2 -darcs init -darcs pull -a ../temp1 -cd .. -cmp temp1/foo temp2/foo -rm -rf temp1 temp2 - diff --git a/tests/addrm.sh b/tests/addrm.sh deleted file mode 100644 --- a/tests/addrm.sh +++ /dev/null @@ -1,18 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf temp1 temp2 -mkdir temp1 temp2 -cd temp1 -darcs init -touch foo -darcs add foo -darcs record -a -m add_foo -A x -darcs remove foo -darcs record -a -m del_foo -A x -cd ../temp2 -darcs init -darcs pull --all ../temp1 -cd .. -rm -rf temp1 temp2 - diff --git a/tests/amend-cancelling.sh b/tests/amend-cancelling.sh deleted file mode 100644 --- a/tests/amend-cancelling.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -# This checks for a possible bug in patch selection where the no available -# patches case is hit. - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -touch A -darcs add A -darcs record -am A -echo 'l1' >> A -darcs record -am l1 -darcs amend -a --patch 'A' - -cd .. -rm -rf temp1 diff --git a/tests/amend-record-back-up.sh b/tests/amend-record-back-up.sh deleted file mode 100644 --- a/tests/amend-record-back-up.sh +++ /dev/null @@ -1,39 +0,0 @@ -#!/usr/bin/env bash -## Copyright (C) 2011 Ganesh Sittampalam -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - - - -. lib # Load some portability helpers. -darcs init --repo amend - -cd amend -echo 'file1' > file1 -darcs record -lam 'file1' - -echo 'file2' > file2 -darcs record -lam 'file2' - -echo 'file2:amended' > file2 -echo 'nkya' | darcs amend - -darcs changes -p 'file2' -v | grep amended diff --git a/tests/amend-unrecord.sh b/tests/amend-unrecord.sh deleted file mode 100644 --- a/tests/amend-unrecord.sh +++ /dev/null @@ -1,57 +0,0 @@ -#!/usr/bin/env bash -## Test for amend --unrecord -## -## Copyright (C) 2012 Ganesh Sittampalam -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -darcs init --repo R # Create our test repo. - -cd R - -(echo x ; echo y) > foo -darcs add foo -darcs rec -am "add foo" - -(echo 1 ; echo x ; echo y ; echo 2) > foo -darcs rec -am "insert 1 and 2" - -(echo yyny) | darcs amend --unrecord -(echo x ; echo y ; echo 2) > foo.expected -darcs show contents foo | diff -q foo.expected - - -(echo yenyy) | DARCS_EDITOR="sed -i -e s/2/2j/" darcs amend --unrecord -(echo x ; echo y ; echo 2j) > foo.expected -darcs show contents foo | diff -q foo.expected - - -echo 'ugh' > bar -darcs add bar -# use amend to check it's still a short form for amend-record -# if we make amend-unrecord visible rather than hidden that would change -echo y | darcs amend -a -darcs show contents bar | diff -q bar - - -# test that amend --unrecord --all and specifying files works -echo y | darcs amend --unrecord -a foo -(echo x ; echo y) > foo.expected -darcs show contents foo | diff -q foo.expected - -darcs show contents bar | diff -q bar - diff --git a/tests/amend.sh b/tests/amend.sh --- a/tests/amend.sh +++ b/tests/amend.sh @@ -74,5 +74,73 @@ cd .. - rm -rf temp1 temp2 + + +# This checks for a possible bug in patch selection where the no available +# patches case is hit. + +darcs init temp1 +cd temp1 +touch A +darcs record -lam A +echo 'l1' >> A +darcs record -am l1 +darcs amend -a --patch 'A' + +cd .. +rm -rf temp1 + +## Copyright (C) 2011 Ganesh Sittampalam + +darcs init temp1 +cd temp1 + +echo 'file1' > file1 +darcs record -lam 'file1' + +echo 'file2' > file2 +darcs record -lam 'file2' + +echo 'file2:amended' > file2 +echo 'nkya' | darcs amend + +darcs log -p 'file2' -v | grep amended +cd .. +rm -rf temp1 + +## Test for amend --unrecord +## Copyright (C) 2012 Ganesh Sittampalam + +darcs init temp1 +cd temp1 + +echo -e "x\ny" > foo +darcs rec -lam "add foo" + +echo -e "1\nx\ny\n2" > foo +darcs rec -am "insert 1 and 2" + +echo yyny | darcs amend --unrecord +echo -e "x\ny\n2" > foo.expected +darcs show contents foo | diff -q foo.expected - + +echo yenyy | DARCS_EDITOR="sed -i -e s/2/2j/" darcs amend --unrecord +echo -e "x\ny\n2j" > foo.expected +darcs show contents foo | diff -q foo.expected - + +echo 'ugh' > bar +darcs add bar +# use amend to check it's still a short form for amend-record +# if we make amend-unrecord visible rather than hidden that would change +echo y | darcs amend -a +darcs show contents bar | diff -q bar - + +# test that amend --unrecord --all and specifying files works +echo y | darcs amend --unrecord -a foo +echo -e "x\ny" > foo.expected +darcs show contents foo | diff -q foo.expected - +darcs show contents bar | diff -q bar - + +cd .. +rm -rf temp1 diff --git a/tests/apply_skip_conflicts.sh b/tests/apply_skip_conflicts.sh new file mode 100644 --- /dev/null +++ b/tests/apply_skip_conflicts.sh @@ -0,0 +1,59 @@ +#!/usr/bin/env bash +## Test that apply --skip-conflicts filters the conflicts +## appropriately. +## +## Copyright (C) 2009 Ganesh Sittampalam +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. + +mkdir R +cd R +darcs init +echo 'foo' > foo +echo 'bar' > bar +darcs rec -lam 'Add foo and bar' +cd .. + +darcs get R S + +cd R +echo 'foo2' > foo +darcs rec -lam 'Change foo (2)' +echo 'bar2' > bar +darcs rec -lam 'Change bar (2)' +cd .. + +cd S +echo 'foo3' > foo +darcs rec -lam 'Change foo (3)' +cd .. + +cd R +darcs send -a ../S -o ../S/applyme.dpatch +cd .. + +cd S +darcs apply --skip-conflicts applyme.dpatch +test `darcs changes --count` -eq 3 +cd .. diff --git a/tests/ask_deps.sh b/tests/ask_deps.sh --- a/tests/ask_deps.sh +++ b/tests/ask_deps.sh @@ -18,13 +18,13 @@ touch a darcs add a echo q | darcs rec -am a0 -darcs ann -p a0 +darcs log -p a0 -v --machine | cat echo 1 > a echo q | darcs rec -am a1 -darcs ann -p a1 +darcs log -p a1 -v --machine | cat echo 2 > a echo q | darcs rec -am a2 -darcs ann -p a2 +darcs log -p a2 -v --machine | cat # add some patches for file 'b' # expect no dependency questions for file 'b', @@ -36,19 +36,21 @@ darcs add b # test 0 echo nnnY | tr '[A-Z]' '[a-z]' | darcs rec -am b0 -darcs ann -p b0 +darcs log -p b0 -v --machine | cat # test 1 echo 1 > b echo nnyY | tr '[A-Z]' '[a-z]' | darcs rec -am b1 -darcs ann -p b1 | grep '^\[a0' +darcs log -p b1 -v --machine | cat +darcs log -p b1 -v --machine | grep '\[a0' # test 2 echo 2 > b echo nyY | tr '[A-Z]' '[a-z]' | darcs rec -am b2 -darcs ann -p b2 | grep '^\[a1' +darcs log -p b2 -v --machine | grep '\[a1' # test 3 echo 3 > b echo yY | tr '[A-Z]' '[a-z]' | darcs rec -am b3 -darcs ann -p b3 | grep '^\[a2' +darcs log -p b3 -v --machine | cat +darcs log -p b3 -v --machine | grep '\[a2' cd .. rm -rf temp diff --git a/tests/bad_pending_after_pull.sh b/tests/bad_pending_after_pull.sh deleted file mode 100644 --- a/tests/bad_pending_after_pull.sh +++ /dev/null @@ -1,51 +0,0 @@ -#!/usr/bin/env bash - -. ./lib - -rm -fr temp1 temp2 - -mkdir temp1 -cd temp1 -darcs init - -echo abc > A -darcs add A -echo def > B1 -darcs add B1 -# darcs record -all --name patch1 # this way it doesn't trigger the bug -for i in 1 2 3 4 5 6 7 8 9 11; do echo y; done | darcs record --name patch1 - -darcs mv B1 B2 -darcs record --all --name patch2 -cd .. - -mkdir temp2 -cd temp2 -darcs init -darcs pull --all ../temp1 -not darcs whatsnew -cd .. - -rm -fr temp1 temp2 - -# issue494: note that in this test, we deliberately select filenames -# with a backwards sorting order -mkdir temp1 -cd temp1 -darcs init -echo abc > b -darcs add b -darcs record --all -m patch1 -darcs mv b a -echo def > a -darcs record --all -m patch2 -cd .. - -mkdir temp2 -cd temp2 -darcs init -darcs pull --all ../temp1 -not darcs whatsnew -cd .. - -rm -fr temp1 temp2 diff --git a/tests/changes-duplicate.sh b/tests/changes-duplicate.sh deleted file mode 100644 --- a/tests/changes-duplicate.sh +++ /dev/null @@ -1,49 +0,0 @@ -#!/usr/bin/env bash -## Test for patch index automation - -## -## Copyright (C) 2012 BSRK Aditya -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -#pragma repo-format darcs-2 - -. lib -grep darcs-2 $HOME/.darcs/defaults || exit 200 - -rm -rf R S -darcs init --repo R -darcs init --repo S - -cd R -touch f -darcs record -lam 'p1' - -cd ../S -touch f -darcs record -lam 'p2' -darcs send -ao p2.dpatch ../R - -cd ../R -darcs apply -a ../S/p2.dpatch -darcs changes --verbose -darcs changes --verbose | grep -q 'duplicate' -darcs changes f --verbose | not grep -q 'duplicate' diff --git a/tests/changes.sh b/tests/changes.sh deleted file mode 100644 --- a/tests/changes.sh +++ /dev/null @@ -1,71 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -# Some tests for 'darcs changes -a' - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init - -date >> date.t -darcs add date.t - -darcs record -A 'Mark Stosberg ' -a -m foo date.t - -#### - -darcs changes date.t > out # trivial case first -cat out -grep foo out - -darcs changes --last=1 date.t > out -cat out -grep foo out - -darcs changes --last 1 --summary date.t > out -cat out -grep foo out - -darcs changes --last=1 --xml > out -cat out -grep '<a@b.com>' out # check that --xml encodes < and > - -### - -# Add 6 records and try again -for i in 0 1 2 3 4 5; do - date >> date.t - darcs record -a -m "foo record num $i" date.t -done - -darcs changes date.t > out -cat out -grep foo out - -darcs changes --last=1 date.t > out -cat out -grep foo out - -darcs changes --last 1 --summary date.t > out -cat out -grep foo out - -### - -darcs changes --context --from-patch='num 1' --to-patch 'num 4' > out -cat out -grep 'num 4' out -grep 'num 3' out -grep 'num 2' out -grep 'num 1' out - -### - -date >> second_file.t -darcs add second_file.t - -darcs record -a -m adding_second_file second_file.t - -cd .. -rm -rf temp1 diff --git a/tests/changes_send_context.sh b/tests/changes_send_context.sh deleted file mode 100644 --- a/tests/changes_send_context.sh +++ /dev/null @@ -1,18 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -# RT#544 using context created with 8-bit chars; -rm -rf temp1 - -mkdir temp1 - -cd temp1 -darcs init -touch foo -darcs record -la -m 'add\212 foo' | grep 'Finished record' -darcs changes --context >context -date > foo -darcs record -a -m 'date foo' | grep 'Finished record' -darcs send -a -o patch --context context . | grep 'Wrote patch to' -cd .. -rm -rf temp1 diff --git a/tests/changes_with_move.sh b/tests/changes_with_move.sh deleted file mode 100644 --- a/tests/changes_with_move.sh +++ /dev/null @@ -1,34 +0,0 @@ -#!/usr/bin/env bash - -# Some tests for the output of changes when combined with move. - -. lib - -darcs init -date > foo -darcs add foo -darcs record -m 'add foo' -a -mkdir d -darcs add d -darcs record -m 'add d' -a -darcs mv foo d -darcs record -m 'mv foo to d' -a -darcs mv d directory -darcs record -m 'mv d to directory' -a -echo 'How beauteous mankind is' > directory/foo -darcs record -m 'modify directory/foo' -a -darcs changes directory/foo > log -grep 'add foo' log -grep 'mv foo to d' log -echo 'O brave new world' > directory/foo -# darcs should also take unrecorded moves into account -darcs mv directory/foo directory/bar -darcs changes directory/foo > log -grep 'mv foo to d' log -echo 'That has such people in it' > directory/foo -darcs add directory/foo -darcs record -m 'mv foo then add new foo' -a -darcs annotate directory/bar | tee log -grep 'O brave new world' log -grep "mv foo then add new foo" log -not grep "unknown" log diff --git a/tests/conflict-reporting.sh b/tests/conflict-reporting.sh new file mode 100644 --- /dev/null +++ b/tests/conflict-reporting.sh @@ -0,0 +1,97 @@ +#!/bin/sh -e +## +## General tests for the conflict UI: +## - conflict reporting on pull etc ("We have conflicts in the following files:") +## - conflict reporting in summaries of changes ("M! foo.txt") +## - conflict marking in files +## +## Copyright (C) 2016 Ganesh Sittampalam +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +#pragma repo-format darcs-1,darcs-2 + +. lib + +rm -rf R1 R2 +mkdir R1 +cd R1 +darcs init +cat > file1 < file2 < file1 < file2 < file1 < file2 < pull-output +grep "We have conflicts in the following files" pull-output +grep "file1" pull-output +not grep "file2" pull-output + +cat > file1-expected < changes-output +grep "M! ./file1 -1 +1" changes-output +grep "M ./file2 -1 +1" changes-output + diff --git a/tests/dist-v.sh b/tests/dist-v.sh deleted file mode 100644 --- a/tests/dist-v.sh +++ /dev/null @@ -1,18 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -# tests for "darcs dist" - -not () { "$@" && exit 1 || :; } - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -# needs fixed on FreeBSD -darcs dist -v 2> log -not grep error log -cd .. - -rm -rf temp1 - diff --git a/tests/double-unrevert.sh b/tests/double-unrevert.sh deleted file mode 100644 --- a/tests/double-unrevert.sh +++ /dev/null @@ -1,29 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -# This demonstrates a bug that happens if you revert followed by -# a partial unrevert and a full unrevert. It requires that -# the second unrevert is working with patches who's contents need -# to be modified by the commute in the first unrevert. - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -echo line1 >> A -echo line2 >> A -echo line3 >> A -echo line4 >> A -echo line5 >> A -echo line6 >> A -darcs add A -darcs record -am A -sed 's/line2/Line2/' A > A1; rm A; mv A1 A -sed '4d' A > A1; rm A; mv A1 A -sed 's/line6/Line6/' A > A1; rm A; mv A1 A -darcs revert -a -echo nyny | darcs unrev -darcs unrev -a - -cd .. -rm -rf temp1 diff --git a/tests/failing-haskell_policy.sh b/tests/failing-haskell_policy.sh deleted file mode 100644 --- a/tests/failing-haskell_policy.sh +++ /dev/null @@ -1,41 +0,0 @@ -#!/usr/bin/env bash -## This is a pseudo-test that runs tweaked hlint on the source code. -## -## Copyright (C) 2009 Petr Rockai -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib - -explain() { - echo >&2 - echo "## It seems that hlint has found errors. This usually means that you" >&2 - echo "## have used a forbidden function. See contrib/darcs-errors.hlint for" >&2 - echo "## explanation. Please also disregard any possible parse errors." >&2 -} - -trap explain ERR - -hlint >& /dev/null || exit 200 # skip if there's no hlint - -wd="`pwd`" -cd .. -hlint --hint=contrib/darcs-errors.hlint src diff --git a/tests/failing-index-argument.sh b/tests/failing-index-argument.sh --- a/tests/failing-index-argument.sh +++ b/tests/failing-index-argument.sh @@ -36,11 +36,10 @@ darcs add a echo "test" >> a darcs record -a -m "record a" a -darcs annotate --index 1 darcs changes --index 1 darcs diff --index 1 +darcs dist --index 1 darcs show contents --index 1 a #### failing tests darcs show files --index 1 a -darcs dist --index 1 diff --git a/tests/failing-issue1013_either_dependency.sh b/tests/failing-issue1013_either_dependency.sh deleted file mode 100644 --- a/tests/failing-issue1013_either_dependency.sh +++ /dev/null @@ -1,53 +0,0 @@ -#!/usr/bin/env bash -. ./lib -export DARCS_EMAIL=test -rm -rf tmp_d1 tmp_d2 tmp_d -# Preparations: -# Set up two repos, each with a patch (d1 and d2 respectively) with both -# an individual change and a change that is identical in both repos, -# and thus auto-merge, i.e., they don't conflict in darcs2. Pull them -# together and record a patch (problem) on top of the auto-merged change, -# so that it depends on EITHER of two patches. - -mkdir tmp_d1; cd tmp_d1 -darcs init --darcs-2 -echo a > a -echo b > b -echo c > c -darcs rec -alm init -echo a-independent > a -echo c-common > c -darcs rec -am d1 -cd .. -darcs get --to-patch init tmp_d1 tmp_d2 -cd tmp_d2 -echo b-independent > b -echo c-common > c -darcs rec -am d2 -darcs pull -a ../tmp_d1 -# no conflicts -- c-common is identical -echo c-problem > c -darcs rec -am problem -cd .. - -# I want to pull the 'problem' patch, but expect darcs to get confused -# because it doesn't know how to select one of the two dependent patches. - -darcs get --to-patch init tmp_d2 tmp_d -cd tmp_d -echo n/n/y |tr / \\012 |darcs pull ../tmp_d2 -darcs cha - -# This is weird, we got d2 though we said No. I would have expected -# darcs to skip the 'problem' patch in this case. - -# Try to pull d1 and unpull d2. - -darcs pull -a ../tmp_d1 -exit 1 # darcs hangs here (2.0.2+77)! -echo n/y/d |tr / \\012 |darcs obl -p d2 - -# The obliterate fails with: patches to commute_to_end does not commutex (1) - -cd .. -rm -rf tmp_d1 tmp_d2 tmp_d diff --git a/tests/failing-issue1196_whatsnew_falsely_lists_all_changes.sh b/tests/failing-issue1196_whatsnew_falsely_lists_all_changes.sh deleted file mode 100644 --- a/tests/failing-issue1196_whatsnew_falsely_lists_all_changes.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -not () { "$@" && exit 1 || :; } - -rm -rf temp1 -mkdir temp1 -cd temp1 - -darcs init -touch aargh -darcs add aargh -echo utrecht > aargh - -darcs wh foo foo/../foo/. > out -cat out -not grep utrecht out - -cd .. -rm -rf temp1 - diff --git a/tests/failing-issue1316-2.sh b/tests/failing-issue1316-2.sh --- a/tests/failing-issue1316-2.sh +++ b/tests/failing-issue1316-2.sh @@ -38,7 +38,7 @@ darcs rec -am 'Y' rm Y -echo 'y' | darcs amend-rec -a +echo 'y' | darcs amend -a # the bug is that addfile Y shows up in pending # if pending is empty as it should be, then since diff --git a/tests/failing-issue1332_add_r_boring.sh b/tests/failing-issue1332_add_r_boring.sh deleted file mode 100644 --- a/tests/failing-issue1332_add_r_boring.sh +++ /dev/null @@ -1,45 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1332 - add -r ignores --boring -## -## Copyright (C) 2009 Eric Kow -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -rm -rf R # Another script may have left a mess. -darcs init --repo R # Create our test repos. - -cd R -mkdir d -touch core f -# this is already known to work -darcs add --boring core f -darcs whatsnew > log -grep 'addfile ./f' log -grep 'addfile ./core' log -rm _darcs/patches/pending -touch _darcs/index_invalid - -# this fails for issue1332 -darcs add -r --boring . -darcs whatsnew > log -grep 'addfile ./f' log -grep 'addfile ./core' log diff --git a/tests/failing-issue1401_bug_in_get_extra.sh b/tests/failing-issue1401_bug_in_get_extra.sh --- a/tests/failing-issue1401_bug_in_get_extra.sh +++ b/tests/failing-issue1401_bug_in_get_extra.sh @@ -30,7 +30,7 @@ . lib ## This bug only affects darcs-2 repositories. -fgrep darcs-2 ~/.darcs/defaults &>/dev/null || exit 0 +fgrep darcs-2 ~/.darcs/defaults &>/dev/null || exit 200 rm -rf d e # Another script may have left a mess. darcs initialize --repodir d/ diff --git a/tests/failing-issue1609_ot_convergence.sh b/tests/failing-issue1609_ot_convergence.sh deleted file mode 100644 --- a/tests/failing-issue1609_ot_convergence.sh +++ /dev/null @@ -1,104 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1609 - standard test for the TP2 property -## in the Operational Transformation literature. -## -## According to Wikipedia: -## For every three concurrent operations op1,op2 and op3 defined on the same -## document state, the transformation function T satisfies CP2/TP2 property -## if and only if: -## T(op_3, op_1 \circ T(op_2,op_1)) = T(op_3, op_2 \circ T(op_1,op_2)). -## -## Copyright (C) 2009 Eric Kow -## Copyright (C) 2009 Pascal Molli -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -rm -rf S1 S2 S3 # Another script may have left a mess. -darcs init --repo S1 # Create our test repos. - -cd S1 -cat > f << END -1 -2 -3 -4 -5 -END -darcs add f -darcs record -am init -cd .. - -darcs get S1 S2 -darcs get S1 S3 - -cd S1 -cat > f << END -1 -2 -X -3 -4 -5 -END -darcs record -am 'insert X before line 3' -cd .. - -cd S2 -cat > f << END -1 -2 -4 -5 -END -darcs record -am 'delete line 3' -cd .. - -cd S3 -cat > f << END -1 -2 -3 -Y -4 -5 -END -darcs record -am 'insert Y after line 3' -cd .. - -darcs pull --allow-conflicts -a --repo S1 S2 -darcs pull --allow-conflicts -a --repo S2 S1 - -darcs pull --allow-conflicts -a --repo S1 S3 -darcs pull --allow-conflicts -a --repo S2 S3 - -darcs pull --allow-conflicts -a --repo S3 S1 - -# TP2 is just fine for conflict resolution itself... -diff S1/f S2/f # no difference -diff S2/f S3/f # no difference - -# But what about the conflict marking? -darcs mark-conflicts --repo S1 -darcs mark-conflicts --repo S2 -darcs mark-conflicts --repo S3 -diff S1/f S2/f # no difference -diff S2/f S3/f # no difference diff --git a/tests/failing-issue1632_changes_nonexisting.sh b/tests/failing-issue1632_changes_nonexisting.sh deleted file mode 100644 --- a/tests/failing-issue1632_changes_nonexisting.sh +++ /dev/null @@ -1,40 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1632 - 'darcs changes d/f' should not list any changes, -## where d is part of the repo and f is a non-existent file. -## -## Copyright (C) 2009 Ben Franksen -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -rm -rf R # Another script may have left a mess. -darcs init --repo R # Create our test repos. - -cd R -mkdir d -darcs record -lam 'added directory d' -# darcs should not list any changes here: -darcs changes non-existent-file > log -not grep 'added directory d' log -# ...and neither here: -darcs changes d/non-existent-file > log -not grep 'added directory d' log -cd .. diff --git a/tests/failing-issue1702-optimize-relink-vs-cache.sh b/tests/failing-issue1702-optimize-relink-vs-cache.sh deleted file mode 100644 --- a/tests/failing-issue1702-optimize-relink-vs-cache.sh +++ /dev/null @@ -1,77 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1702 - an optimize --relink does not relink the files -## in ~/.darcs/cache. -## -## Copyright (C) 2009 Trent W. Buck -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -rm -rf R S # Another script may have left a mess. -darcs init --repo R # Create our test repos. - -## Create a patch. -echo 'Example content.' > R/f -darcs record -lam 'Add f.' --repodir R - -## Get a hard link into the cache. -darcs get R S - -## Are hard links available? -x=(R/_darcs/patches/*-*) -x=${x#R/_darcs/patches/} -if [[ ! R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] -then - echo This test requires filesystem support for hard links. - echo This test requires the hashed (or darcs-2) repo format. - exit 200 -fi - -## IMPORTANT! In bash [[ ]] is neither a builtin nor a command; it is -## a keyword. This means it can fail without tripping ./lib's set -e. -## This is why all invocations below have the form [[ ... ]] || false. - -## Confirm that all three are hard linked. -ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging -[[ R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false -[[ S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false -[[ R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false - -## Break all hard links. -rm -rf S -cp -r R S -rm -rf R -cp -r S R - -## Confirm that there are no hard links. -ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging -[[ ! R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false -[[ ! S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false -[[ ! R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false - -## Optimize *should* hard-link all three together. -darcs optimize relink --repodir R --sibling S - -## Confirm that all three are hard linked. -ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging -[[ R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false -[[ S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false -[[ R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false diff --git a/tests/failing-issue1829-inconsistent-conflictor.sh b/tests/failing-issue1829-inconsistent-conflictor.sh --- a/tests/failing-issue1829-inconsistent-conflictor.sh +++ b/tests/failing-issue1829-inconsistent-conflictor.sh @@ -26,8 +26,9 @@ ## SOFTWARE. . lib -rm -rf r1 r2 +grep darcs-2 $HOME/.darcs/defaults || exit 200 +rm -rf r1 r2 mkdir r1 cd r1 darcs init diff --git a/tests/failing-issue1928-file-dir-replace.sh b/tests/failing-issue1928-file-dir-replace.sh deleted file mode 100644 --- a/tests/failing-issue1928-file-dir-replace.sh +++ /dev/null @@ -1,36 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1913 - test for directory diffing -## -## Copyright (C) 2010 Ganesh Sittampalam -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -rm -rf R # Another script may have left a mess. -darcs init --repo R # Create our test repos. - -cd R -touch foo -darcs rec -l -a -m "foo file patch" -rm foo -mkdir foo -darcs rec -l -a -m "foo dir patch" -cd .. diff --git a/tests/failing-issue2017-missing-tag.sh b/tests/failing-issue2017-missing-tag.sh deleted file mode 100644 --- a/tests/failing-issue2017-missing-tag.sh +++ /dev/null @@ -1,85 +0,0 @@ -#!/usr/bin/env bash -## Test for issue2017 - apply should gracefully handle tag missing -## from context (complain, not crash) -## -## Copyright (C) 2010 Eric Kow -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -darcs init --repo R # Create our test repos. - -cd R -echo 'Example content.' > f -darcs record -lam 'Add f' -cd .. - -# variant 0 - this passes trivially -darcs get R R0 -darcs get R0 S0 -darcs tag 's' --repo S0 -darcs get S0 T0 -cd T0 -echo 'More content.' > f -darcs record -lam 'Modify f' -darcs send -o foo.dpatch -a -cd .. -not darcs apply --repo R0 T0/foo.dpatch > log 2>&1 -not grep bug log -grep missing log - -# variant 1 - tag in shared context -darcs get R R1 -darcs tag '1' --repo R1 -darcs get R1 S1 -darcs tag 's1' --repo S1 -darcs get S1 T1 -cd T1 -echo 'More content.' > f -darcs record -lam 'Modify f' -darcs send -o foo.dpatch -a -cd .. -# sanity check: should be able to cherry pick -darcs get R1 R1b -cd R1b -[ `darcs changes --count` -eq 2 ] -darcs pull ../T1 --match 'touch f' --all -[ `darcs changes --count` -eq 3 ] -cd .. -# the test: can't apply this due to incorrect context -not darcs apply --repo R1 T1/foo.dpatch > log 2>&1 -not grep 'bug' log -grep missing log - -# variant 2 - tag created after the fact -darcs get R R2 -darcs get R2 S2 -darcs tag 's2' --repo S2 -darcs get S2 T2 -cd T2 -echo 'More content.' > f -darcs record -lam 'Modify f' -darcs send -o foo.dpatch -a -cd .. -darcs tag '2' --repo R2 # only tag after -not darcs apply --repo R2 T2/foo.dpatch > log 2>&1 -not grep 'bug' log -grep missing log diff --git a/tests/failing-issue2047_duplicate_conflictor_recommute_fail.sh b/tests/failing-issue2047_duplicate_conflictor_recommute_fail.sh --- a/tests/failing-issue2047_duplicate_conflictor_recommute_fail.sh +++ b/tests/failing-issue2047_duplicate_conflictor_recommute_fail.sh @@ -43,6 +43,8 @@ # # See issue2047 on the BTS for more information. +. ./lib + rm -rf R1* R2 R3* darcs init --repo R1 diff --git a/tests/failing-issue2086-index-permissions.sh b/tests/failing-issue2086-index-permissions.sh deleted file mode 100644 --- a/tests/failing-issue2086-index-permissions.sh +++ /dev/null @@ -1,38 +0,0 @@ -#!/usr/bin/env bash -## Test for issue2086 - _darcs/index permissions are not preserved -## -## Copyright (C) 2011 Eric Kow -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -darcs init --repo R # Create our test repos. - -cd R -echo 'Example content.' > f -darcs record -lam 'Add f' --umask 022 -ls -l _darcs/index | grep '^.rw..--...' -chmod g+w _darcs/index -ls -l _darcs/index | grep '^.rw.rw....' -echo 'Example content 2.' > f -darcs record -lam 'Tweak f' -ls -l _darcs/index | grep '^.rw.rw....' -cd .. diff --git a/tests/failing-issue2138-whatsnew-s.sh b/tests/failing-issue2138-whatsnew-s.sh deleted file mode 100644 --- a/tests/failing-issue2138-whatsnew-s.sh +++ /dev/null @@ -1,59 +0,0 @@ -#!/usr/bin/env bash -## Test for issue2138 - whatsnew --summary does not show conflicts -## -## Copyright (C) 2012 Lele Gaifax -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. - -rm -rf R S - -darcs init --repo R - -cd R -echo 'Example content.' > f -darcs record -lam 'Add f' -cd .. - -darcs get R S - -# Create a deliberate conflict -cd R -echo "Conflict on side R" >> f -darcs record -am 'CR' - -cd ../S -echo "Conflict on side S" >> f -darcs record -am 'CS' - -darcs pull -a ../R - -darcs whatsnew > out -cat out -grep "side R" out | wc -l | grep 1 -grep "side S" out | wc -l | grep 1 - -darcs whatsnew --summary > out -grep "^M!" out | wc -l | grep 1 - -cd .. -rm -rf R S diff --git a/tests/failing-issue2186-apply--reply-conflict.sh b/tests/failing-issue2186-apply--reply-conflict.sh --- a/tests/failing-issue2186-apply--reply-conflict.sh +++ b/tests/failing-issue2186-apply--reply-conflict.sh @@ -40,7 +40,7 @@ echo 'Example content.' >file1 darcs add file1 darcs rec -a --name patch1 -darcs send --dont-edit-description --to noreply@example.net --sendmail-command '../dummy-sendmail %<' -a ../S +darcs send --dont-edit-description --to noreply@example.net --mail --sendmail-command '../dummy-sendmail %<' -a ../S mv message patch-set1 # Create the same file in the target repository to trigger a conflict. @@ -51,5 +51,5 @@ # Apply the patch set. darcs should email a report. If it does our dummy-sendmail script will # create file "message". -darcs apply --reply noreply@example.net --sendmail-command '../dummy-sendmail %<' ../R/patch-set1 || :; -[ -f ./message ] || exit 1 +darcs apply --reply noreply@example.net --mail --sendmail-command '../dummy-sendmail %<' ../R/patch-set1 || true; +test -f ./message diff --git a/tests/failing-issue2186-apply--reply-ok.sh b/tests/failing-issue2186-apply--reply-ok.sh --- a/tests/failing-issue2186-apply--reply-ok.sh +++ b/tests/failing-issue2186-apply--reply-ok.sh @@ -40,11 +40,11 @@ echo 'Example content.' >file1 darcs add file1 darcs rec -a --name patch1 -darcs send --dont-edit-description --to noreply@example.net --sendmail-command '../dummy-sendmail %<' -a ../S +darcs send --dont-edit-description --to noreply@example.net --mail --sendmail-command '../dummy-sendmail %<' -a ../S mv message patch-set1 # Apply the patch set. darcs should email a report. If it does our dummy-sendmail script will # create file "message". cd ../S -darcs apply --reply noreply@example.net --sendmail-command '../dummy-sendmail %<' ../R/patch-set1 -[ -f ./message ] || exit 1 +darcs apply --reply noreply@example.net --mail --sendmail-command '../dummy-sendmail %<' ../R/patch-set1 +test -f ./message diff --git a/tests/failing-issue2219-no-working.sh b/tests/failing-issue2219-no-working.sh --- a/tests/failing-issue2219-no-working.sh +++ b/tests/failing-issue2219-no-working.sh @@ -48,22 +48,23 @@ darcs pull ../R1b -a # NB: not sure if this test expresses what I really intend DIFFCOUNT=$(darcs diff | wc -l) -test [ $DIFFCOUNT -eq 0 ] +test $DIFFCOUNT -eq 0 -# 2011-12-27: unclear on what should happen here +# add should not work mkdir S1 cd S1 darcs init --no-working-dir echo "bonjour" > a -darcs add a -darcs record -a -m 'a file' a +not darcs add a cd .. +# move and remove should not work +darcs clone R1 R1m --no-working-dir +cd R1m +not darcs remove a +not darcs move a b + # --no-working-dir --working-dir flags should trump each other in the # same fashion as the rest of darcs -# -## 2011-12-27: fails -darcs get --no-working-dir --with-working-dir R1 R3 -test -e R3/a -darcs get --with-working-dir --no-working-dir R1 R4 -test ! -e R4 +not darcs clone --no-working-dir --with-working-dir R1 R3 +not darcs clone --with-working-dir --no-working-dir R1 R4 diff --git a/tests/failing-issue2238-unadded-files-showing-added.sh b/tests/failing-issue2238-unadded-files-showing-added.sh deleted file mode 100644 --- a/tests/failing-issue2238-unadded-files-showing-added.sh +++ /dev/null @@ -1,37 +0,0 @@ -#!/usr/bin/env bash -## Test for issue2238 - passing -l twice to whatsnew reports unadded files as -## already added. -## -## Copyright (C) 2012 Owen Stephens -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib - -rm -rf R -darcs init --repo R -cd R - -touch foo - -darcs wh -l | grep 'a \./foo' -darcs wh -ll | grep 'a \./foo' -darcs wh -ll | not grep 'A \./foo' diff --git a/tests/failing-issue2242-rollback-mv.sh b/tests/failing-issue2242-rollback-mv.sh deleted file mode 100644 --- a/tests/failing-issue2242-rollback-mv.sh +++ /dev/null @@ -1,46 +0,0 @@ -#!/usr/bin/env bash -## Test for issue2242 - rollback of a mv patch generates bogus changes -## -## Copyright (C) 2012 Owen Stephens -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib - -rm -rf R -darcs init --repo R -cd R - -# Setup dir with empty file in it -mkdir A -touch A/foo -darcs rec -alm 'Add A' - -# Mv dir and add content to file -darcs mv A B -echo -e 'line1\nline2' > B/foo -darcs rec -alm 'Move A -> B and change foo' - -# Rollback everything in the move/change patch -echo ynya | darcs roll - -# We shouldn't see any rm'd dirs/files (just a move and line removal hunk) -darcs wh | not grep rm diff --git a/tests/failing-issue2293-laziness-amend.sh b/tests/failing-issue2293-laziness-amend.sh --- a/tests/failing-issue2293-laziness-amend.sh +++ b/tests/failing-issue2293-laziness-amend.sh @@ -32,4 +32,4 @@ echo 'baz' > bar -echo yyyy | darcs amend-rec +echo yyyy | darcs amend diff --git a/tests/failing-issue2308-changes-missing-amend-edit.sh b/tests/failing-issue2308-changes-missing-amend-edit.sh deleted file mode 100644 --- a/tests/failing-issue2308-changes-missing-amend-edit.sh +++ /dev/null @@ -1,54 +0,0 @@ -#!/usr/bin/env bash -## Test for issue2308 changes aren't listed when using amend --edit -## -## Copyright (C) 2013 Owen Stephens -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. - -rm -rf R - -darcs init --repo R - -cd R -echo -e 'a\nb\nc' > file -darcs rec -alm 'Add file' - -cat > expected < actual - -not diff expected actual diff --git a/tests/failing-issue2380-rename-to-deleted-file.sh b/tests/failing-issue2380-rename-to-deleted-file.sh deleted file mode 100644 --- a/tests/failing-issue2380-rename-to-deleted-file.sh +++ /dev/null @@ -1,47 +0,0 @@ -#!/usr/bin/env bash -## Test for issue2380 - darcs won't rename a file to a file that has been -## deleted in the working dir. -## -## Copyright (C) 2014 Owen Stephens -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -rm -rf R && darcs init --repo R - -. lib - -cd R -echo foostuff > foo -echo otherstuff > other -darcs rec -alm 'Add foo and other' - -rm foo -darcs mv other foo - -# foo should exist, with the correct contents, and other should not -[[ -e foo && ! -e other && $( expected -darcs wh > actual - -diff expected actual - -darcs rev -a - -[[ -e foo && -e other && $(> t.t -darcs record -am "new patch" -not darcs push -a ../temp1 2> log -grep failed log - diff --git a/tests/failing-issue68_broken_pipe.sh b/tests/failing-issue68_broken_pipe.sh deleted file mode 100644 --- a/tests/failing-issue68_broken_pipe.sh +++ /dev/null @@ -1,27 +0,0 @@ -#!/usr/bin/env bash - -# For issue68, 'don't report "resource vanished" when stdout pipe is broken.' - -. ./lib - -rm -rf temp1 # Another script may have left a mess. - -darcs init --repodir temp1 - -cd temp1 - -date > f -darcs add f -darcs rec -am firstp -for (( i=0 ; i < 500; i=i+1 )); do - echo $i >> f; - darcs rec -am p$i -done - -darcs changes 2> err | head - -touch correcterr - -diff correcterr err - -cd .. diff --git a/tests/failing-look_for_moves.sh b/tests/failing-look_for_moves.sh deleted file mode 100644 --- a/tests/failing-look_for_moves.sh +++ /dev/null @@ -1,39 +0,0 @@ -#!/usr/bin/env bash - -. ./lib - -rm -rf temp1 temp2 -mkdir temp1 temp2 -cd temp1 - -# # exchange of dirs with contents and exchange filenames inside - -darcs init -mkdir dir dir2 -touch dir/foo dir2/foo dir2/foo2 -darcs record -a -m add_files_and_dirs -A x --look-for-adds -mv dir dir.tmp -mv dir2 dir -mv dir.tmp dir2 -mv dir/foo dir/foo.tmp -mv dir/foo2 dir/foo -mv dir/foo.tmp dir/foo2 -darcs wh --summary --look-for-moves > log 2>&1 -cat > log.expected < ./dir.tmp~ - ./dir2 -> ./dir - ./dir.tmp~ -> ./dir2 - ./dir/foo -> ./dir/foo.tmp~ - ./dir/foo2 -> ./dir/foo - ./dir/foo.tmp~ -> ./dir/foo2 -EOF -diff -u log log.expected -rm log log.expected -darcs record -a -m move_dirs -A x --look-for-moves -darcs wh --look-for-moves --look-for-adds >log 2>&1 -grep -vE "(^ *$|^\+|No changes!)" log -rm -rf * - - -cd .. -rm -rf temp1 diff --git a/tests/failing-merging_newlines.sh b/tests/failing-merging_newlines.sh --- a/tests/failing-merging_newlines.sh +++ b/tests/failing-merging_newlines.sh @@ -33,7 +33,6 @@ echo "in tmp2" >> one.txt darcs whatsnew -s | grep M darcs record -A bar -am "add extra line" -darcs annotate -p . -u darcs push -av > log cat log not grep -i conflicts log diff --git a/tests/get-http-packed-detect.sh b/tests/get-http-packed-detect.sh deleted file mode 100644 --- a/tests/get-http-packed-detect.sh +++ /dev/null @@ -1,40 +0,0 @@ -#!/usr/bin/env bash -# 2011, by Petr Rockai, Guillaume Hoffmann, public domain - -# Tets that darcs get --verbose reports getting a pack when there is one, -# and does not report when there is none or when --no-packs is passed. - -#pragma repo-format darcs-1,darcs-2 - -. lib - -rm -rf S - -if grep darcs-1 .darcs/defaults; then -format=hashed -elif grep darcs-2 .darcs/defaults; then -format=darcs-2 -else format=ERROR; fi - -gunzip -c $TESTDATA/many-files--${format}.tgz | tar xf - - -cd many* - -darcs optimize http -test -e _darcs/packs/basic.tar.gz -test -e _darcs/packs/patches.tar.gz -cd .. - -serve_http # sets baseurl - -# check that default behaviour is to get packs -darcs get $baseurl/many-files--${format} S --verbose |grep "Cloning packed basic repository" - -# check that it does really not get packs when --no-packs is passed -rm -rf S -darcs get $baseurl/many-files--${format} S --no-packs --verbose |not grep "Cloning packed basic repository" - -# check that it does not clam getting packs when there are not -rm -rf S -rm -rf many-files--${format}/_darcs/packs/ -darcs get $baseurl/many-files--${format} S --verbose |not grep "Cloning packed basic repository" diff --git a/tests/get-http-packed.sh b/tests/get-http-packed.sh deleted file mode 100644 --- a/tests/get-http-packed.sh +++ /dev/null @@ -1,29 +0,0 @@ -#!/usr/bin/env bash -# Written in 2010 by Petr Rockai, placed in public domain - -#pragma repo-format darcs-1,darcs-2 - -. lib - -rm -rf S - -if grep darcs-1 .darcs/defaults; then -format=hashed -elif grep darcs-2 .darcs/defaults; then -format=darcs-2 -else format=ERROR; fi - -gunzip -c $TESTDATA/many-files--${format}.tgz | tar xf - - -cd many* - -darcs optimize http -test -e _darcs/packs/basic.tar.gz -test -e _darcs/packs/patches.tar.gz -cd .. - -serve_http # sets baseurl -darcs get --packs $baseurl/many-files--${format} S -cd S -rm _darcs/prefs/sources # avoid any further contact with the original repository -darcs check diff --git a/tests/get-http.sh b/tests/get-http.sh deleted file mode 100644 --- a/tests/get-http.sh +++ /dev/null @@ -1,41 +0,0 @@ -#!/usr/bin/env bash -# Written in 2010 by Petr Rockai, placed in public domain - -# This file is included as part of the Darcs test distribution, -# which is licensed to you under the following terms: -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib - -rm -rf R S && mkdir R -cd R -darcs init -echo a > a -darcs rec -lam a -cd .. - -serve_http # sets baseurl -darcs get $baseurl/R S -cd S -darcs pull ../R | tee log -grep "No remote" log -darcs check diff --git a/tests/git_import_delete_empty_directories.sh b/tests/git_import_delete_empty_directories.sh --- a/tests/git_import_delete_empty_directories.sh +++ b/tests/git_import_delete_empty_directories.sh @@ -109,4 +109,37 @@ } wcDiff gitsource darcsmirror +darcs check --repodir=darcsmirror # ensure repo is consistent +# ensure dir is deleted after a file move out of it (a common case) +# and that a dir is created when moving to it (also a common case) + +git init gitsource2 +cd gitsource2 +mkdir -p dir1/ +echo "i want to move" > dir1/f +echo "me too!!" > g +echo "12345" > h +echo "67890" > i +git add . +git commit -m "initial commit" +mv dir1/f f +git add --all . +git commit -m "move dir1/f to f" +mkdir dir2 +mv g dir2/g +git add --all . +git commit -m "move g to dir2/" +# the following commit could be problematic with darcs import, +# with the addfile hunk ending up between both move hunks. +mkdir dir3 +mv h dir3/h +mv i dir3/i +git add --all . +git commit -m "move h and i to dir2/" +git clean -fd +cd .. +(cd gitsource2 && git fast-export --all -M) | darcs convert import darcsmirror2 # -M to generate file moves data + +wcDiff gitsource2 darcsmirror2 +darcs check --repodir=darcsmirror2 # ensure repo is consistent diff --git a/tests/git_rename_and_copy_files.sh b/tests/git_rename_and_copy_files.sh new file mode 100644 --- /dev/null +++ b/tests/git_rename_and_copy_files.sh @@ -0,0 +1,63 @@ +#!/usr/bin/env bash +## ensure empty directories get deleted when importing from git +## +## Copyright (C) 2014 Owen Stephens +## 2016 Guillaume Hoffmann +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +! read -r -d '' DATA <<'EOF' +blob +mark :1 +data 8 +testing + +reset refs/heads/master +commit refs/heads/master +mark :2 +author CommiterName 1307452813 +0100 +committer CommiterName 1307452813 +0100 +data 6 +add a +M 100644 :1 a + +commit refs/heads/master +mark :3 +author CommiterName 1307452821 +0100 +committer CommiterName 1307452821 +0100 +data 19 +Copy, rename, copy +from :2 +C "a" "c" +R "a" "b" +C b d +C b a path/with spaces + +EOF + +rm -rf R +echo "$DATA" | darcs convert import R +cd R + +[[ -e c && -e b && -e d && ! -e a && -e "a path/with spaces" ]] +[[ $(darcs log --count) -eq 2 ]] diff --git a/tests/git_rename_dir.sh b/tests/git_rename_dir.sh new file mode 100644 --- /dev/null +++ b/tests/git_rename_dir.sh @@ -0,0 +1,62 @@ +#!/usr/bin/env bash +## ensure empty directories get deleted when importing from git +## +## Copyright (C) 2014 Owen Stephens +## 2016 Guillaume Hoffmann +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +! read -r -d '' DATA <<'EOF' +blob +mark :1 +data 8 +testing + +reset refs/heads/master +commit refs/heads/master +mark :2 +author CommiterName 1307452813 +0100 +committer CommiterName 1307452813 +0100 +data 10 +add dir/a +M 100644 :1 dir/a + +commit refs/heads/master +mark :3 +author CommiterName 1307452821 +0100 +committer CommiterName 1307452821 +0100 +data 24 +copy, rename, copy dirs +from :2 +C "dir" "dir2" +R "dir" "dir3/dir4" +C "dir3/dir4" "dir4" + +EOF + +rm -rf R +echo "$DATA" | darcs convert import R +cd R +[[ -e dir2 && -e dir3 && -e dir4 && (! -e dir) && -e dir2/a && -e dir3/dir4/a + && -e dir4/a ]] +[[ $(darcs log --count) -eq 2 ]] diff --git a/tests/hijack.sh b/tests/hijack.sh new file mode 100644 --- /dev/null +++ b/tests/hijack.sh @@ -0,0 +1,112 @@ +#!/usr/bin/env bash + +# Testing patch hijack interactions + +. lib + +rm -rf temp1 +# set up the repository +mkdir temp1 +cd temp1 +darcs init +cd .. + +# create some simple patches by somebody else +cd temp1 +touch 1 2 3 4 5 +darcs add * +darcs record -a --author you 1 -m 'patch1a' +darcs record -a --author you 2 -m 'patch2a' +darcs record -a --author you 3 -m 'patch3a' +darcs record -a --author you 4 -m 'patch4a' +darcs record -a --author you 5 -m 'patch5a' +cd .. + +# try amending a patch +cd temp1 +echo yn | darcs amend -p patch5 -m 'patch5b' | grep "Amend anyway" +darcs log | grep patch5 +darcs log | not grep patch5b +echo yy | darcs amend -p patch5 -m 'patch5b' | grep "Amend anyway" +darcs log | grep patch5b +cd .. + +# try some unsuspending +cd temp1 +# ...hijack one +# abort everywhere: need selectchanges for smarter behaviour +echo yyn | darcs rebase suspend --all +darcs log | grep 'patch1a' # nothing suspended +darcs log | grep 'patch5b' # nothing suspended +not darcs rebase unsuspend --all # not in progress +# ...hijack all +echo ya | darcs rebase suspend --all +darcs log | not grep 'patch1a' +darcs log | not grep 'patch5b' +darcs rebase unsuspend --all +darcs log | grep 'patch1a' +darcs log | grep 'patch5b' +cd .. + +# make some conflicting patches in another repo +mkdir temp2 +cd temp2 +darcs init +touch 1 2 3 4 5 +darcs add * +darcs record -a --author thirdperson 1 -m 'patch1c' +darcs record -a --author thirdperson 2 -m 'patch2c' +darcs record -a --author thirdperson 3 -m 'patch3c' +darcs record -a --author thirdperson 4 -m 'patch4c' +darcs record -a --author thirdperson 5 -m 'patch5c' +cd .. + +# try suspending via rebase pull +cd temp1 +# first 'y' is for a "repositories seem to be unrelated" prompt +echo yayyn | darcs rebase pull ../temp2 --all +darcs log | grep 'patch1a' # nothing suspended or pulled +darcs log | grep 'patch5b' # nothing suspended or pulled +not darcs rebase unsuspend --all # not in progress + +echo yayyyyyy | darcs rebase pull ../temp2 --all +darcs log | not grep 'patch1a' +darcs log | not grep 'patch5b' + +darcs obliterate -a -p 'patch1c' +darcs obliterate -a -p 'patch2c' +darcs obliterate -a -p 'patch3c' +darcs obliterate -a -p 'patch4c' +darcs obliterate -a -p 'patch5c' + +darcs rebase unsuspend --all +darcs log | grep 'patch1a' +darcs log | grep 'patch5b' +cd .. + +# try suspending via rebase apply + +cd temp2 +darcs obliterate -a -o c.dpatch +cd .. + +cd temp1 +echo ayyn | darcs rebase apply ../temp2/c.dpatch --all +darcs log | grep 'patch1a' # nothing suspended or pulled +darcs log | grep 'patch5b' # nothing suspended or pulled +not darcs rebase unsuspend --all # not in progress + +echo ayyyyyy | darcs rebase apply ../temp2/c.dpatch --all +darcs log | not grep 'patch1a' +darcs log | not grep 'patch5b' + +darcs obliterate -a -p 'patch1c' +darcs obliterate -a -p 'patch2c' +darcs obliterate -a -p 'patch3c' +darcs obliterate -a -p 'patch4c' +darcs obliterate -a -p 'patch5c' + +darcs rebase unsuspend --all +darcs log | grep 'patch1a' +darcs log | grep 'patch5b' +cd .. diff --git a/tests/illegal_mv.sh b/tests/illegal_mv.sh deleted file mode 100644 --- a/tests/illegal_mv.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf temp -mkdir temp -cd temp - -darcs initialize -echo text > afile.txt -darcs add afile.txt -darcs record --author me --all --no-test --name init -mkdir d -echo The following mv should fail, since d isnt in the repo. -if darcs mv afile.txt d/afile.txt; then -false -fi - -# Now clean up. -cd .. -rm -rf temp - diff --git a/tests/impossible_unrevert.sh b/tests/impossible_unrevert.sh deleted file mode 100644 --- a/tests/impossible_unrevert.sh +++ /dev/null @@ -1,33 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf temp -mkdir temp -cd temp -darcs init -echo ALL ignore-times > _darcs/prefs/defaults -echo a > foo -darcs add foo -darcs record -a -m aa -A test -echo b > foo -echo yy | darcs revert -a -echo ydyy | darcs unrecord -# since the unrevert is impossible, we should fail if it succeeds... -echo yy | darcs unrevert && exit 1 || true - -# now let's try a possible unrevert, just for fun... -echo b >> foo -darcs record -a -m bb -A test -echo f/b | tr / \\012 > foo -darcs record -a -m 'aaa becomes f' -A test -date >> foo -echo yy | darcs revert -a -echo ydyy | darcs unpull -# Now add the date back on at the end: -echo yy | darcs unrevert -echo 'M ./foo +1' > correct_summary -darcs whatsnew --dont-look-for-adds --summary > actual_summary -diff -c correct_summary actual_summary - -cd .. -rm -rf temp diff --git a/tests/issue1012_unrecord_remove.sh b/tests/issue1012_unrecord_remove.sh deleted file mode 100644 --- a/tests/issue1012_unrecord_remove.sh +++ /dev/null @@ -1,18 +0,0 @@ -#!/usr/bin/env bash -. ./lib -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs --version -darcs init -echo temp1 >File.hs -darcs add File.hs -darcs record File.hs -a -m "add File" -rm File.hs -darcs record -a -m "rm File" -darcs changes -darcs unrecord -p "rm File" -a -darcs changes -darcs record -a -m "re-rm File" -cd .. -rm -rf temp1 diff --git a/tests/issue1111-pull-intersection.sh b/tests/issue1111-pull-intersection.sh deleted file mode 100644 --- a/tests/issue1111-pull-intersection.sh +++ /dev/null @@ -1,66 +0,0 @@ -#!/usr/bin/env bash -# This file is included as part of the Darcs test distribution, -# which is licensed to you under the following terms: -# -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib -# This test script is in the public domain. -# This file is included as part of the Darcs test distribution, -# which is licensed to you under the following terms: -# - - -rm -rf temp1 temp2 temp3 - -mkdir temp1 -cd temp1 -darcs initialize -echo A > A -darcs add A -darcs record -a -m Aismyname -echo B > B -darcs add B -darcs record -a -m Bismyname - -cd .. -darcs get temp1 temp2 - -cd temp2 -darcs obliterate --last 1 -a -echo C > C -darcs add C -darcs record -a -m Cismyname -cd .. - -mkdir temp3 -cd temp3 -darcs init -darcs pull -a -v --intersection ../temp1 ../temp2 - -darcs changes > out -cat out -grep Aismyname out -not grep Bismyname out -not grep Cismyname out -cd .. - -rm -rf temp1 temp2 temp3 diff --git a/tests/issue1139-diff-last.sh b/tests/issue1139-diff-last.sh --- a/tests/issue1139-diff-last.sh +++ b/tests/issue1139-diff-last.sh @@ -9,7 +9,6 @@ echo text > foo darcs add foo darcs rec -am 'add foo' -darcs annotate -p . echo newtext > foo darcs record -am 'modify foo' diff --git a/tests/issue1196_whatsnew_falsely_lists_all_changes.sh b/tests/issue1196_whatsnew_falsely_lists_all_changes.sh new file mode 100644 --- /dev/null +++ b/tests/issue1196_whatsnew_falsely_lists_all_changes.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash +. ./lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +echo utrecht > aargh +darcs add aargh + +not darcs wh foo foo/../foo/. + +cd .. +rm -rf temp1 + diff --git a/tests/issue1332_add_r_boring.sh b/tests/issue1332_add_r_boring.sh new file mode 100644 --- /dev/null +++ b/tests/issue1332_add_r_boring.sh @@ -0,0 +1,45 @@ +#!/usr/bin/env bash +## Test for issue1332 - add -r ignores --boring +## +## Copyright (C) 2009 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +mkdir d +touch core f +# this is already known to work +darcs add --boring core f +darcs whatsnew > log +grep 'addfile ./f' log +grep 'addfile ./core' log +rm _darcs/patches/pending +touch _darcs/index_invalid + +# this fails for issue1332 +darcs add -r --boring . +darcs whatsnew > log +grep 'addfile ./f' log +grep 'addfile ./core' log diff --git a/tests/issue1337_darcs_changes_false_positives.sh b/tests/issue1337_darcs_changes_false_positives.sh deleted file mode 100644 --- a/tests/issue1337_darcs_changes_false_positives.sh +++ /dev/null @@ -1,37 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1337 - darcs changes shows unrelated patches -## Asking "darcs changes" about an unrecorded file d/f will list the -## patch that creates the parent directory d/ (instead of no patches). -## -## Copyright (C) 2009 Trent W. Buck -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib - -rm -rf temp1 -darcs init --repodir temp1 -cd temp1 -mkdir d -darcs record -lam d d -# We use --match 'touch d/f' instead of simply d/f because the latter -# prints "Changes to d/f:\n" before the count. -test 0 -eq "$(darcs changes --count --match 'touch d/f')" diff --git a/tests/issue142_record-log.sh b/tests/issue142_record-log.sh deleted file mode 100644 --- a/tests/issue142_record-log.sh +++ /dev/null @@ -1,34 +0,0 @@ -#!/usr/bin/env bash -## Test for issue142 - darcs record --logfile foo should not -## let you record a patch even when 'foo' is a missing file -## -## Copyright (C) 2009 Eric Kow -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -rm -rf R # Another script may have left a mess. -darcs init --repo R # Create our test repos. -cd R -touch f g -touch log -darcs record -alm f --logfile log f -not darcs record -alm g --logfile missing g diff --git a/tests/issue1599-automatically-expire-unused-caches.sh b/tests/issue1599-automatically-expire-unused-caches.sh deleted file mode 100644 --- a/tests/issue1599-automatically-expire-unused-caches.sh +++ /dev/null @@ -1,55 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1599 - 'Automatically expire unused caches' -## -## Copyright (C) 2010 Adolfo Builes -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. -. lib - -rm -rf R S log && mkdir R -cd R -darcs init -echo a > a -darcs rec -lam a -echo b > b -darcs rec -lam b -echo c > c -darcs rec -lam c -cd .. - -serve_http # sets baseurl -darcs get --lazy $baseurl/R S -rm S/_darcs/prefs/sources -if [ -z "$http_proxy" ]; then - echo "repo:http://10.1.2.3/S" >> S/_darcs/prefs/sources -fi -echo "repo:$baseurl/dummyRepo" >> S/_darcs/prefs/sources -echo "repo:~/test1599/S" >> S/_darcs/prefs/sources -echo "repo:$baseurl/R" >> S/_darcs/prefs/sources -export DARCS_CONNECTION_TIMEOUT=1 && darcs changes --repo S --debug --verbose --no-cache 2>&1 | tee log -if [ -z "$http_proxy" ]; then - c=`grep -c "URL.waitUrl http://10.1.2.3/S" log` - [ $c -eq 1 ] -fi -c1=`grep -c "URL.waitUrl $baseurl/dummyRepo" log` -[ $c1 -eq 2 ] -c2=`grep -c "~/test1599/S" log` -[ $c2 -eq 1 ] diff --git a/tests/issue1702-optimize-relink-vs-cache.sh b/tests/issue1702-optimize-relink-vs-cache.sh new file mode 100644 --- /dev/null +++ b/tests/issue1702-optimize-relink-vs-cache.sh @@ -0,0 +1,77 @@ +#!/usr/bin/env bash +## Test for issue1702 - an optimize --relink does not relink the files +## in ~/.darcs/cache. +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +## Create a patch. +echo 'Example content.' > R/f +darcs record -lam 'Add f.' --repodir R + +## Get a hard link into the cache. +darcs get R S + +## Are hard links available? +x=(R/_darcs/patches/*-*) +x=${x#R/_darcs/patches/} +if [[ ! R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] +then + echo This test requires filesystem support for hard links. + echo This test requires the hashed or darcs-2 repo format. + exit 200 +fi + +## IMPORTANT! In bash [[ ]] is neither a builtin nor a command; it is +## a keyword. This means it can fail without tripping ./lib's set -e. +## This is why all invocations below have the form [[ ... ]] || false. + +## Confirm that all three are hard linked. +ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging +[[ R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false +[[ S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false +[[ R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false + +## Break all hard links. +rm -rf S +cp -r R S +rm -rf R +cp -r S R + +## Confirm that there are no hard links. +ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging +[[ ! R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false +[[ ! S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false +[[ ! R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false + +## Optimize *should* hard-link all three together. +darcs optimize relink --repodir R --sibling S + +## Confirm that all three are hard linked. +ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging +[[ R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false +[[ S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false +[[ R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false diff --git a/tests/issue1765_recursive-remove-on-root.sh b/tests/issue1765_recursive-remove-on-root.sh deleted file mode 100644 --- a/tests/issue1765_recursive-remove-on-root.sh +++ /dev/null @@ -1,36 +0,0 @@ -#!/usr/bin/env bash -## Test for issueNNNN - -## -## Copyright (C) YEAR AUTHOR -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -rm -rf R S # Another script may have left a mess. -darcs init --repo R # Create our test repos. -darcs init --repo S - -cd R -mkdir d e # Change the working tree. -echo 'Example content.' > d/f -darcs record -lam 'Add d/f and e.' -darcs remove * -r diff --git a/tests/issue1825-remove-pending.sh b/tests/issue1825-remove-pending.sh --- a/tests/issue1825-remove-pending.sh +++ b/tests/issue1825-remove-pending.sh @@ -35,9 +35,5 @@ darcs add -r a darcs rec -am "add a/b" rm -r a -darcs add # NB. not darcs add per se, but any operation which - # causes the pending patch to be detected (eg. remove, - # record + unrecord) - -# We have a legitimate pending patch so far. Now what? +not darcs remove blahblah darcs revert -a a/b diff --git a/tests/issue1845-record-removed.sh b/tests/issue1845-record-removed.sh deleted file mode 100644 --- a/tests/issue1845-record-removed.sh +++ /dev/null @@ -1,16 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1871 - darcs record f, for f a removed file should work -## -## Public domain - 2010 Petr Rockai - -. lib # Load some portability helpers. -rm -rf R # Another script may have left a mess. -darcs init --repo R # Create our test repos. - -cd R -echo 'Example content.' > f -darcs rec -lam "first" -rm -f f -echo ny | darcs record f 2>&1 | tee log -not grep "None of the files" log -cd .. diff --git a/tests/issue184_add.sh b/tests/issue184_add.sh deleted file mode 100644 --- a/tests/issue184_add.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/env bash - -. lib - -# For issue184: recording files in directories that haven't explicity been added. - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -mkdir new -mkdir new/dir -touch new/dir/t.t -darcs add new/dir/t.t -darcs record -am test new/dir/t.t > log -not grep "don't want to record" log -cd .. - -rm -rf temp1 diff --git a/tests/issue1888-changes-context.sh b/tests/issue1888-changes-context.sh deleted file mode 100644 --- a/tests/issue1888-changes-context.sh +++ /dev/null @@ -1,43 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1888 - changes --context is broken when topmost patch is a -## clean tag. - -## Copyright (C) 2010 Petr Rockai -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -rm -rf R # Another script may have left a mess. -darcs init --repo R # Create our test repos. - -cd R - -echo a > a ; darcs rec -lam "patch_a" -darcs changes --context | grep patch_a - -darcs tag -m "tag_a" -darcs changes --context | not grep patch_a -darcs changes --context | grep tag_a - -echo b > a; darcs rec -lam "patch_b" -darcs changes --context | not grep patch_a -darcs changes --context | grep tag_a -darcs changes --context | grep patch_b diff --git a/tests/issue1923-cache-warning.sh b/tests/issue1923-cache-warning.sh deleted file mode 100644 --- a/tests/issue1923-cache-warning.sh +++ /dev/null @@ -1,53 +0,0 @@ -#!/usr/bin/env bash -## Test for issue1599 - 'Automatically expire unused caches' -## -## Copyright (C) 2010 Adolfo Builes -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. -. lib - -darcs init --repo R -cd R -echo a > a -darcs rec -lam a -cd .. - -serve_http -cat < fake-sources -repo:$baseurl/dummyRepo -repo:/some/bogus/local/path -repo:$baseurl/R -SOURCES -darcs get --lazy R S1 && cp fake-sources S1/_darcs/prefs/sources -darcs get --lazy R S2 && cp fake-sources S2/_darcs/prefs/sources - -# make sure we do warn about things that are under your control -darcs changes --verbose --repo S1 --no-cache 2>&1 | tee log-local -c1=`grep -c "$baseurl/dummyRepo" log-local` -[ $c1 -eq 1 ] -c2=`grep -c "/some/bogus/local/path" log-local` -[ $c2 -eq 1 ] - -# now what about things that aren't? -darcs changes --verbose --repo $baseurl/S2 --no-cache 2>&1 | tee log-remote -c1=`grep -c "$baseurl/dummyRepo" log-remote` -[ $c1 -eq 1 ] # always under your control -not grep -c "/some/bogus/local/path" log-remote diff --git a/tests/issue1928-file-dir-replace.sh b/tests/issue1928-file-dir-replace.sh new file mode 100644 --- /dev/null +++ b/tests/issue1928-file-dir-replace.sh @@ -0,0 +1,36 @@ +#!/usr/bin/env bash +## Test for issue1928 - removing a file and adding a directory with the same name +## +## Copyright (C) 2010 Ganesh Sittampalam +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +touch foo +darcs rec -l -a -m "foo file patch" +rm foo +mkdir foo +darcs rec -l -a -m "foo dir patch" +cd .. diff --git a/tests/issue1932-colon-breaks-add.sh b/tests/issue1932-colon-breaks-add.sh --- a/tests/issue1932-colon-breaks-add.sh +++ b/tests/issue1932-colon-breaks-add.sh @@ -25,6 +25,8 @@ . lib # Load some portability helpers. +abort_windows # Windows doesn't support ':' in filenames at all + rm -rf R # Another script may have left a mess. mkdir -p R # Create our test repo. @@ -36,16 +38,7 @@ # Colon in repo name is an indication of special case - remote repo. # Colon in the file could be there under unix and requires no special treatment. -# Repo name with ':' is either scp repo or http repo. -# Let's check scp repo first. -( darcs get user@invalid:path || true ) > log 2>&1 -[ -n "$(fgrep 'ssh: Could not resolve hostname invalid: Name or service not known' log)" ] - -# HTTP repo -( darcs get http://www.bogus.domain.so.it.will.surely.fail.com || true ) 2>&1 | tee log -egrep 'CouldNotResolveHost|host lookup failure' log - -abort_windows # Windows doesn't support ':' in filenames at all +# remote repos are tested by tests/network/issue1932-remote.sh # All following files should not be added unless "--reserved-ok" is specified, # but should be added with "--reserved-ok" just fine diff --git a/tests/issue2017-missing-tag.sh b/tests/issue2017-missing-tag.sh new file mode 100644 --- /dev/null +++ b/tests/issue2017-missing-tag.sh @@ -0,0 +1,85 @@ +#!/usr/bin/env bash +## Test for issue2017 - apply should gracefully handle tag missing +## from context (complain, not crash) +## +## Copyright (C) 2010 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +darcs init --repo R # Create our test repos. + +cd R +echo 'Example content.' > f +darcs record -lam 'Add f' +cd .. + +# variant 0 - this passes trivially +darcs get R R0 +darcs get R0 S0 +darcs tag 's' --repo S0 +darcs get S0 T0 +cd T0 +echo 'More content.' > f +darcs record -lam 'Modify f' +darcs send -o foo.dpatch -a +cd .. +not darcs apply --repo R0 T0/foo.dpatch > log 2>&1 +not grep bug log +grep missing log + +# variant 1 - tag in shared context +darcs get R R1 +darcs tag '1' --repo R1 +darcs get R1 S1 +darcs tag 's1' --repo S1 +darcs get S1 T1 +cd T1 +echo 'More content.' > f +darcs record -lam 'Modify f' +darcs send -o foo.dpatch -a +cd .. +# sanity check: should be able to cherry pick +darcs get R1 R1b +cd R1b +[ `darcs changes --count` -eq 2 ] +darcs pull ../T1 --match 'touch f' --all +[ `darcs changes --count` -eq 3 ] +cd .. +# the test: can't apply this due to incorrect context +not darcs apply --repo R1 T1/foo.dpatch > log 2>&1 +not grep 'bug' log +grep missing log + +# variant 2 - tag created after the fact +darcs get R R2 +darcs get R2 S2 +darcs tag 's2' --repo S2 +darcs get S2 T2 +cd T2 +echo 'More content.' > f +darcs record -lam 'Modify f' +darcs send -o foo.dpatch -a +cd .. +darcs tag '2' --repo R2 # only tag after +not darcs apply --repo R2 T2/foo.dpatch > log 2>&1 +not grep 'bug' log +grep missing log diff --git a/tests/issue2086-index-permissions.sh b/tests/issue2086-index-permissions.sh new file mode 100644 --- /dev/null +++ b/tests/issue2086-index-permissions.sh @@ -0,0 +1,40 @@ +#!/usr/bin/env bash +## Test for issue2086 - _darcs/index permissions are not preserved +## +## Copyright (C) 2011 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +darcs init --repo R # Create our test repos. + +abort_windows # umasks don't really work there + +cd R +echo 'Example content.' > f +darcs record -lam 'Add f' --umask 022 +ls -l _darcs/index | grep '^.rw..--...' +chmod g+w _darcs/index +ls -l _darcs/index | grep '^.rw.rw....' +echo 'Example content 2.' > f +darcs record -lam 'Tweak f' --umask 002 +ls -l _darcs/index | grep '^.rw.rw....' +cd .. diff --git a/tests/issue2136-changes_created_as_for_multiple_files.sh b/tests/issue2136-changes_created_as_for_multiple_files.sh deleted file mode 100644 --- a/tests/issue2136-changes_created_as_for_multiple_files.sh +++ /dev/null @@ -1,86 +0,0 @@ -#!/usr/bin/env bash - -## Ensure changes --xml reports correct original filenames for multiple files. -## -## Copyright (C) 2012 Owen Stephens -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib - -rm -rf R - -darcs init --repo R - -cd R - -mkdir tldir - -touch tldir/f1 -darcs rec -alm 'Add tldir/f1' -echo foo >> tldir/f1 -darcs rec -am 'Modify tldir/f1' -darcs move tldir/f1 tldir/f2 -darcs rec -am 'Move tldir/f1 -> tldir/f2' - -touch f3 -darcs rec -alm 'Add f3' -darcs move f3 f4 -darcs rec -am 'Move f3 -> f4' -darcs move f4 f5 -darcs rec -am 'Move f4 -> f5' -touch f6 -darcs rec -alm 'Add non-changing file f6' - -mkdir tldir/d1 -darcs rec -alm 'Add tldir/d1' -darcs move tldir/d1 tldir/d2 -darcs rec -am 'Move tldir/d1 -> tldir/d2' - -mkdir d3 -darcs rec -alm 'Add d3' -darcs move d3 d4 -darcs rec -am 'Move d3 -> d4' -darcs move d4 d5 -darcs rec -am 'Move d4 -> d5' - -# Ensure all original names are reported, both forwards, and reversed. -xmlChanges=$(darcs changes --xml tldir/f2 f5 tldir/d2 d5 f6) -xmlChangesRev=$(darcs changes --reverse --xml tldir/f2 f5 tldir/d2 d5 f6) - -# xmlChanges needs to be quoted everywhere, otherwise this hack to retrieve the -# 2 following lines won't work. -checkRename () { - echo "$1" | grep "" -C2 | tail -1 | grep "$4" -} - -checkInXML () { - checkRename "$1" "d5" "d3" "Add d3" - checkRename "$1" "f5" "f3" "Add f3" - checkRename "$1" "tldir/d2" "tldir/d1" "Add tldir/d1" - checkRename "$1" "tldir/f2" "tldir/f1" "Add tldir/f1" -} - -checkInXML "$xmlChanges" -checkInXML "$xmlChangesRev" - -# But don't mention unchanged files. -echo "$xmlChanges" | not grep "]*'\./f6'" diff --git a/tests/issue2136-log_created_as_for_multiple_files.sh b/tests/issue2136-log_created_as_for_multiple_files.sh new file mode 100644 --- /dev/null +++ b/tests/issue2136-log_created_as_for_multiple_files.sh @@ -0,0 +1,86 @@ +#!/usr/bin/env bash + +## Ensure log --xml reports correct original filenames for multiple files. +## +## Copyright (C) 2012 Owen Stephens +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +rm -rf R + +darcs init --repo R + +cd R + +mkdir tldir + +touch tldir/f1 +darcs rec -alm 'Add tldir/f1' +echo foo >> tldir/f1 +darcs rec -am 'Modify tldir/f1' +darcs move tldir/f1 tldir/f2 +darcs rec -am 'Move tldir/f1 -> tldir/f2' + +touch f3 +darcs rec -alm 'Add f3' +darcs move f3 f4 +darcs rec -am 'Move f3 -> f4' +darcs move f4 f5 +darcs rec -am 'Move f4 -> f5' +touch f6 +darcs rec -alm 'Add non-changing file f6' + +mkdir tldir/d1 +darcs rec -alm 'Add tldir/d1' +darcs move tldir/d1 tldir/d2 +darcs rec -am 'Move tldir/d1 -> tldir/d2' + +mkdir d3 +darcs rec -alm 'Add d3' +darcs move d3 d4 +darcs rec -am 'Move d3 -> d4' +darcs move d4 d5 +darcs rec -am 'Move d4 -> d5' + +# Ensure all original names are reported, both forwards, and reversed. +xmlLog=$(darcs log --xml tldir/f2 f5 tldir/d2 d5 f6) +xmlLogRev=$(darcs log --reverse --xml tldir/f2 f5 tldir/d2 d5 f6) + +# xmlLog needs to be quoted everywhere, otherwise this hack to retrieve the +# 2 following lines won't work. +checkRename () { + echo "$1" | grep "" -C2 | tail -1 | grep "$4" +} + +checkInXML () { + checkRename "$1" "d5" "d3" "Add d3" + checkRename "$1" "f5" "f3" "Add f3" + checkRename "$1" "tldir/d2" "tldir/d1" "Add tldir/d1" + checkRename "$1" "tldir/f2" "tldir/f1" "Add tldir/f1" +} + +checkInXML "$xmlLog" +checkInXML "$xmlLogRev" + +# But don't mention unchanged files. +echo "$xmlLog" | not grep "]*'\./f6'" diff --git a/tests/issue2138-whatsnew-s.sh b/tests/issue2138-whatsnew-s.sh new file mode 100644 --- /dev/null +++ b/tests/issue2138-whatsnew-s.sh @@ -0,0 +1,59 @@ +#!/usr/bin/env bash +## Test for issue2138 - whatsnew --summary does not show conflicts +## +## Copyright (C) 2012 Lele Gaifax +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. + +rm -rf R S + +darcs init --repo R + +cd R +echo 'Example content.' > f +darcs record -lam 'Add f' +cd .. + +darcs get R S + +# Create a deliberate conflict +cd R +echo "Conflict on side R" >> f +darcs record -am 'CR' + +cd ../S +echo "Conflict on side S" >> f +darcs record -am 'CS' + +darcs pull -a ../R + +darcs whatsnew > out +cat out +grep "side R" out | wc -l | grep 1 +grep "side S" out | wc -l | grep 1 + +darcs whatsnew --summary > out +grep "^M!" out | wc -l | grep 1 + +cd .. +rm -rf R S diff --git a/tests/issue2139-mv-to-dir.sh b/tests/issue2139-mv-to-dir.sh deleted file mode 100644 --- a/tests/issue2139-mv-to-dir.sh +++ /dev/null @@ -1,54 +0,0 @@ -#!/usr/bin/env bash -## Test for issue2139 - darcs should accept to mv to the -## current working directory -## -## Copyright (C) 2012 Eric Kow -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. - -darcs init --repo R # Create our test repos. - -cd R - -# move dir to root -mkdir a a/a2 a/a3 -darcs record -lam 'Some directories (a)' -darcs mv a/a2 . -test -d a2 -cd a -darcs mv a3 .. -not test -d a3 -cd .. -test -d a3 - -# move dir to non-root dir -mkdir b b2 b3 -darcs record -lam 'Some directories (b)' -darcs mv b2 b -test -d b/b2 -cd b -darcs mv ../b3 . -test -d b3 -cd .. - -cd .. diff --git a/tests/issue2209-look_for_replaces.sh b/tests/issue2209-look_for_replaces.sh --- a/tests/issue2209-look_for_replaces.sh +++ b/tests/issue2209-look_for_replaces.sh @@ -25,11 +25,9 @@ . lib -rm -rf R -mkdir R +darcs init R cd R # simple full complete replace (record) -darcs init echo "foo" > file darcs record -al -m "add file" echo "bar_longer" > file # replace by token of different length @@ -321,3 +319,47 @@ EOF diff -u log log.expected rm -rf * + +# 2 + +cd .. +darcs init S +cd S +echo 'Example content' > f +echo 'This is golden content , super interesting content' >> f + +echo 'Example content' > g +echo 'This is golden content , super interesting content' >> g +darcs record -lam 'Add f, g' + +sed -i "s/content/matter/g" f +sed -i "s/content/topic/g" g +darcs whatsnew --look-for-replace | grep replace +# replace same token differently in different files is OK + +# 3 + +cd .. +darcs init T +cd T +echo 'Example content' > f +echo 'This is golden content , super interesting content' >> f + +cp f g +cp f e + +darcs record -lam 'Add e, f, g' + +# change the file in the middle + +echo 'Example issue' > f +echo 'This is golden matter , super interesting matter' >> f # create inconsistent replace in f + +sed -i "s/content/stuff/g" e # consistent replace in e +sed -i "s/content/topic/g" g # consistent replace in g + +darcs whatsnew --look-for-replace > out + +grep "^replace ./e" out # 1 replace in e +not grep "^replace ./f" out # 0 replace in f +grep "^replace ./g" out # 1 replace in g diff --git a/tests/issue2242-rollback-mv.sh b/tests/issue2242-rollback-mv.sh new file mode 100644 --- /dev/null +++ b/tests/issue2242-rollback-mv.sh @@ -0,0 +1,46 @@ +#!/usr/bin/env bash +## Test for issue2242 - rollback of a mv patch generates bogus changes +## +## Copyright (C) 2012 Owen Stephens +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +rm -rf R +darcs init --repo R +cd R + +# Setup dir with empty file in it +mkdir A +touch A/foo +darcs rec -alm 'Add A' + +# Mv dir and add content to file +darcs mv A B +echo -e 'line1\nline2' > B/foo +darcs rec -alm 'Move A -> B and change foo' + +# Rollback everything in the move/change patch +echo ynya | darcs roll + +# We shouldn't see any rm'd dirs/files (just a move and line removal hunk) +darcs wh | not grep rm diff --git a/tests/issue2270-changes-interactive-only-to-files.sh b/tests/issue2270-changes-interactive-only-to-files.sh deleted file mode 100644 --- a/tests/issue2270-changes-interactive-only-to-files.sh +++ /dev/null @@ -1,139 +0,0 @@ -#!/usr/bin/env bash -## Test for issue2270 - -## darcs changes should only show changes to relevant files -## -## Copyright (C) 2013 Sebastian Fischer -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. - -rm -rf R -mkdir R -cd R -darcs init - -echo irrelevant > irrelevant -darcs add irrelevant -darcs record -am "recorded irrelevant file" - -echo relevant-initial > relevant -echo other > other -darcs add relevant other -darcs record -am "recorded relevant and other file" - - -# --interactive --only-to-files should only show relevant -(echo y | darcs changes -i --only-to-files relevant > out) || true -cat out -not grep "addfile ./irrelevant" out -grep "addfile ./relevant" out -not grep "addfile ./other" out - -# --verbose --only-to-files should only show relevant -(darcs changes -v --only-to-files relevant > out) || true -cat out -not grep "addfile ./irrelevant" out -grep "addfile ./relevant" out -not grep "addfile ./other" out - -# --interactive should only show relevant and other -(echo yy | darcs changes -i relevant > out) || true -cat out -not grep "addfile ./irrelevant" out -grep "addfile ./relevant" out -grep "addfile ./other" out - -# --verbose should only show relevant and other -(darcs changes -v relevant > out) || true -cat out -not grep "addfile ./irrelevant" out -grep "addfile ./relevant" out -grep "addfile ./other" out - -# --interactive --only-to-files should show old name of moved -darcs move relevant renamed-relevant -darcs record -am "renamed relevant file" - -(echo yy | darcs changes -i --only-to-files renamed-relevant > out) || true -cat out -grep "addfile ./relevant" out -not grep "addfile ./irrelevant" out -not grep "addfile ./other" out - -# --verbose --only-to-files should show old name of moved -(darcs changes -v --only-to-files renamed-relevant > out) || true -cat out -grep "addfile ./relevant" out -not grep "addfile ./irrelevant" out -not grep "addfile ./other" out - -# --interactive should show old name of moved -(echo yy | darcs changes -i renamed-relevant > out) || true -cat out -grep "addfile ./relevant" out -not grep "addfile ./irrelevant" out -grep "addfile ./other" out - -# --verbose should show old name of moved -(darcs changes -v renamed-relevant > out) || true -cat out -grep "addfile ./relevant" out -not grep "addfile ./irrelevant" out -grep "addfile ./other" out - -# adding a new file called 'relevant' : -# changes should now relate to that file and not to the original one -echo relevant-new > relevant -darcs add relevant -echo other-new > other -darcs record -am "recorded new add of relevant" - -(echo yy | darcs changes -i --only-to-files relevant > out) || true -cat out -grep "addfile ./relevant" out -grep 'relevant-new' out -not grep 'other-new' out -not grep 'relevant-initial' out - -(echo yy | darcs changes -v --only-to-files relevant > out) || true -cat out -grep "addfile ./relevant" out -grep 'relevant-new' out -not grep 'other-new' out -not grep 'relevant-initial' out - -(echo yy | darcs changes -i relevant > out) || true -cat out -grep "addfile ./relevant" out -grep 'relevant-new' out -grep 'other-new' out -not grep 'relevant-initial' out - -(echo yy | darcs changes -v relevant > out) || true -cat out -grep "addfile ./relevant" out -grep 'relevant-new' out -grep 'other-new' out -not grep 'relevant-initial' out - -cd .. -rm -rf R diff --git a/tests/issue2270-log-interactive-only-to-files.sh b/tests/issue2270-log-interactive-only-to-files.sh new file mode 100644 --- /dev/null +++ b/tests/issue2270-log-interactive-only-to-files.sh @@ -0,0 +1,139 @@ +#!/usr/bin/env bash +## Test for issue2270 - +## darcs log should only show changes to relevant files +## +## Copyright (C) 2013 Sebastian Fischer +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. + +rm -rf R +mkdir R +cd R +darcs init + +echo irrelevant > irrelevant +darcs add irrelevant +darcs record -am "recorded irrelevant file" + +echo relevant-initial > relevant +echo other > other +darcs add relevant other +darcs record -am "recorded relevant and other file" + + +# --interactive --only-to-files should only show relevant +(echo y | darcs log -i --only-to-files relevant > out) || true +cat out +not grep "addfile ./irrelevant" out +grep "addfile ./relevant" out +not grep "addfile ./other" out + +# --verbose --only-to-files should only show relevant +(darcs log -v --only-to-files relevant > out) || true +cat out +not grep "addfile ./irrelevant" out +grep "addfile ./relevant" out +not grep "addfile ./other" out + +# --interactive should only show relevant and other +(echo yy | darcs log -i relevant > out) || true +cat out +not grep "addfile ./irrelevant" out +grep "addfile ./relevant" out +grep "addfile ./other" out + +# --verbose should only show relevant and other +(darcs log -v relevant > out) || true +cat out +not grep "addfile ./irrelevant" out +grep "addfile ./relevant" out +grep "addfile ./other" out + +# --interactive --only-to-files should show old name of moved +darcs move relevant renamed-relevant +darcs record -am "renamed relevant file" + +(echo yy | darcs log -i --only-to-files renamed-relevant > out) || true +cat out +grep "addfile ./relevant" out +not grep "addfile ./irrelevant" out +not grep "addfile ./other" out + +# --verbose --only-to-files should show old name of moved +(darcs log -v --only-to-files renamed-relevant > out) || true +cat out +grep "addfile ./relevant" out +not grep "addfile ./irrelevant" out +not grep "addfile ./other" out + +# --interactive should show old name of moved +(echo yy | darcs log -i renamed-relevant > out) || true +cat out +grep "addfile ./relevant" out +not grep "addfile ./irrelevant" out +grep "addfile ./other" out + +# --verbose should show old name of moved +(darcs log -v renamed-relevant > out) || true +cat out +grep "addfile ./relevant" out +not grep "addfile ./irrelevant" out +grep "addfile ./other" out + +# adding a new file called 'relevant' : +# changes should now relate to that file and not to the original one +echo relevant-new > relevant +darcs add relevant +echo other-new > other +darcs record -am "recorded new add of relevant" + +(echo yy | darcs log -i --only-to-files relevant > out) || true +cat out +grep "addfile ./relevant" out +grep 'relevant-new' out +not grep 'other-new' out +not grep 'relevant-initial' out + +(echo yy | darcs log -v --only-to-files relevant > out) || true +cat out +grep "addfile ./relevant" out +grep 'relevant-new' out +not grep 'other-new' out +not grep 'relevant-initial' out + +(echo yy | darcs log -i relevant > out) || true +cat out +grep "addfile ./relevant" out +grep 'relevant-new' out +grep 'other-new' out +not grep 'relevant-initial' out + +(echo yy | darcs log -v relevant > out) || true +cat out +grep "addfile ./relevant" out +grep 'relevant-new' out +grep 'other-new' out +not grep 'relevant-initial' out + +cd .. +rm -rf R diff --git a/tests/issue2378-moving-directory-to-file.sh b/tests/issue2378-moving-directory-to-file.sh new file mode 100644 --- /dev/null +++ b/tests/issue2378-moving-directory-to-file.sh @@ -0,0 +1,14 @@ +darcs initialize +mkdir d +darcs add d +echo sometext > d/f +darcs add d/f +darcs record -am'added d/f' --skip-long-comment +darcs move d/f . +darcs record -am'moved d/f to .' --skip-long-comment +rmdir d +darcs record -am'removed d' --skip-long-comment +darcs move f d +darcs record -am'moved f to d' --skip-long-comment +darcs obliterate --last=3 --all +darcs whatsnew -l diff --git a/tests/issue2380-rename-to-deleted-file.sh b/tests/issue2380-rename-to-deleted-file.sh new file mode 100644 --- /dev/null +++ b/tests/issue2380-rename-to-deleted-file.sh @@ -0,0 +1,47 @@ +#!/usr/bin/env bash +## Test for issue2380 - darcs won't rename a file to a file that has been +## deleted in the working dir. +## +## Copyright (C) 2014 Owen Stephens +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +rm -rf R && darcs init --repo R + +. lib + +cd R +echo foostuff > foo +echo otherstuff > other +darcs rec -alm 'Add foo and other' + +rm foo +darcs mv other foo + +# foo should exist, with the correct contents, and other should not +[[ -e foo && ! -e other && $( expected +darcs wh > actual + +diff expected actual + +darcs rev -a + +[[ -e foo && -e other && $( b +darcs add b +darcs record -a -m 'added b' +mkdir a +not darcs move . ./b a 2>&1 | not grep -i bug diff --git a/tests/issue2494-output-of-record-with-file-arguments.sh b/tests/issue2494-output-of-record-with-file-arguments.sh new file mode 100644 --- /dev/null +++ b/tests/issue2494-output-of-record-with-file-arguments.sh @@ -0,0 +1,79 @@ +#!/usr/bin/env bash + +# Load some portability helpers +. lib + +echo added >> ../all_paths +echo not-added >> ../all_paths +echo recorded >> ../all_paths +echo removed >> ../all_paths +echo not-existing >> ../all_paths +echo /not-repo-path >> ../all_paths + +check_report() { + yes="$1" + log="$2" + pre="$3" + shift + shift + shift + paths="$@" + for arg in "$@"; do + grep $yes "$pre.\+$arg" "$log" + done +} + +check_report_yes() { + check_report '' "$@" +} + +check_report_no() { + check_report '-v' "$@" +} + +# Create and populate test repo +darcs init --repo R +cd R +touch recorded removed +darcs add recorded removed +darcs record -am'two files' +touch added not-added +rm removed +darcs add added + +# Now do the tests +echo q | darcs record added not-added recorded removed not-existing /not-repo-path > ../record.out 2>&1 + +check_report_yes ../record.out 'non-repository' /not-repo-path +check_report_no ../record.out 'non-repository' added not-added recorded removed not-existing + +check_report_yes ../record.out 'non-existing' not-added not-existing +check_report_no ../record.out 'non-existing' added recorded removed /not-repo-path + +check_report_yes ../record.out 'not.\+in.\+repository' added +check_report_no ../record.out 'not.\+in.\+repository' not-added recorded removed not-existing /not-repo-path + +check_report_yes ../record.out 'Recording' added recorded removed +check_report_no ../record.out 'Recording' not-added not-existing /not-repo-path + +echo q | darcs record -l added not-added recorded removed not-existing /not-repo-path > ../record-l.out 2>&1 + +check_report_yes ../record-l.out 'non-repository' /not-repo-path +check_report_no ../record-l.out 'non-repository' added not-added recorded removed not-existing + +check_report_yes ../record-l.out 'non-existing' not-existing +check_report_no ../record-l.out 'non-existing' added not-added recorded removed /not-repo-path + +check_report_no ../record-l.out 'not.\+in.\+repository' added not-added recorded removed not-existing /not-repo-path + +check_report_yes ../record-l.out 'Recording' added not-added recorded removed +check_report_no ../record-l.out 'Recording' not-existing /not-repo-path + +echo q | darcs record -l -q added not-added recorded removed not-existing /not-repo-path > ../record-l-q.stdout + +not grep 'paths' ../record-l-q.stdout +check_report_no ../record-l-q.stdout 'Recording' added not-added recorded removed not-existing /not-repo-path + +echo q | darcs record -q -a -m'patchname' added not-added recorded removed not-existing /not-repo-path > ../record-q-a.stdout + +not grep '.' ../record-q-a.stdout diff --git a/tests/issue612_repo_not_writable.sh b/tests/issue612_repo_not_writable.sh new file mode 100644 --- /dev/null +++ b/tests/issue612_repo_not_writable.sh @@ -0,0 +1,35 @@ +#!/usr/bin/env bash + +# Test that darcs fails appropriately when the target repo inventory file is not writable. +# See issue612 + +. lib + +abort_windows + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +touch t.t +darcs add t.t +darcs record -am "initial add" +if [ -e _darcs/inventories ]; then + chmod 0555 _darcs/inventories/* + chmod 0555 _darcs/inventories +fi +if [ -e _darcs/inventory ]; then + chmod 0555 _darcs/inventory +fi +cd .. + +darcs get temp1 temp2 +cd temp2 +# this block may fail so we'd better make sure we clean up after +# ourselves to avoid a permissions mess for other tests +trap "cd ..; chmod -R 0755 temp1; rm -rf temp1 temp2" EXIT +echo new >> t.t +darcs record -am "new patch" +not darcs push -a ../temp1 2> log +grep failed log + diff --git a/tests/issue68_broken_pipe.sh b/tests/issue68_broken_pipe.sh new file mode 100644 --- /dev/null +++ b/tests/issue68_broken_pipe.sh @@ -0,0 +1,25 @@ +#!/usr/bin/env bash + +# For issue68, 'don't report "resource vanished" when stdout pipe is broken.' + +. ./lib + +rm -rf temp1 # Another script may have left a mess. + +darcs init --repodir temp1 + +cd temp1 + +for i in {1..500} +do + echo $i >> f +done + +darcs changes 2> err | head +darcs rec -alm 'Add big f' + +# We recorded a big file add, so asking for the first n lines of the patch +# would trigger this bug. +darcs changes -v 2> err | head + +[[ ! -s err ]] diff --git a/tests/lib b/tests/lib --- a/tests/lib +++ b/tests/lib @@ -84,6 +84,13 @@ test -e "$1/light.pid" && kill `cat "$1/light.pid"` || true } +check_remote_http() { + if ! curl -fI "$1"; then + echo Cannot reach "$1" + exit 200 + fi +} + skip-formats() { for f in "$@"; do grep $f $HOME/.darcs/defaults && exit 200 || true; done } diff --git a/tests/log-duplicate.sh b/tests/log-duplicate.sh new file mode 100644 --- /dev/null +++ b/tests/log-duplicate.sh @@ -0,0 +1,46 @@ +#!/usr/bin/env bash +## Copyright (C) 2012 BSRK Aditya +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +#pragma repo-format darcs-2 + +. lib +grep darcs-2 $HOME/.darcs/defaults || exit 200 + +rm -rf R S +darcs init --repo R +darcs init --repo S + +cd R +touch f +darcs record -lam 'p1' + +cd ../S +touch f +darcs record -lam 'p2' +darcs send -ao p2.dpatch ../R + +cd ../R +darcs apply -a ../S/p2.dpatch +darcs log --verbose +darcs log --verbose | grep -q 'duplicate' +darcs log f --verbose | not grep -q 'duplicate' diff --git a/tests/log.sh b/tests/log.sh new file mode 100644 --- /dev/null +++ b/tests/log.sh @@ -0,0 +1,161 @@ +#!/usr/bin/env bash +. ./lib + +# Some tests for 'darcs log -a' + +rm -rf temp1 +darcs init temp1 +cd temp1 + +date >> date.t +darcs record -A 'Mark Stosberg ' -lam foo + +#### + +darcs log date.t > out # trivial case first +cat out +grep foo out + +darcs log --last=1 date.t > out +cat out +grep foo out + +darcs log --last 1 --summary date.t > out +cat out +grep foo out + +darcs log --last=1 --xml > out +cat out +grep '<a@b.com>' out # check that --xml encodes < and > + +### + +# Add 6 records and try again +for i in 0 1 2 3 4 5; do + date >> date.t + darcs record -a -m "foo record num $i" date.t +done + +darcs log date.t > out +cat out +grep foo out + +darcs log --last=1 date.t > out +cat out +grep foo out + +darcs log --last 1 --summary date.t > out +cat out +grep foo out + +### + +darcs log --context --from-patch='num 1' --to-patch 'num 4' > out +cat out +grep 'num 4' out +grep 'num 3' out +grep 'num 2' out +grep 'num 1' out + +cd .. +rm -rf temp1 + + +# Some tests for the output of log when combined with move. + +darcs init temp1 +cd temp1 +date > foo +darcs record -lam 'add foo' +mkdir d +darcs record -lam 'add d' +darcs mv foo d +darcs record -m 'mv foo to d' -a +darcs mv d directory +darcs record -m 'mv d to directory' -a +echo 'How beauteous mankind is' > directory/foo +darcs record -m 'modify directory/foo' -a +darcs log directory/foo > log +grep 'add foo' log +grep 'mv foo to d' log +echo 'O brave new world' > directory/foo +# darcs should also take unrecorded moves into account +darcs mv directory/foo directory/bar +darcs log directory/foo > log +grep 'mv foo to d' log +echo 'That has such people in it' > directory/foo +darcs add directory/foo +darcs record -m 'mv foo then add new foo' -a +darcs annotate directory/bar | tee log +grep 'O brave new world' log +grep "mv foo then add new foo" log +not grep "unknown" log +cd .. +rm -rf temp1 + +# Issue244 +# darcs changes should be able to pull up the history for a file +# using its moved and not-yet recorded new name + +darcs init temp1 +cd temp1 +touch b +darcs record -lam 11 +darcs mv b c +darcs log c | grep 11 +cd .. +rm -rf temp1 + +## issue1337 - darcs log shows unrelated patches +## Asking "darcs log" about an unrecorded file d/f will list the +## patch that creates the parent directory d/ (instead of no patches). + +darcs init temp1 +cd temp1 +mkdir d +darcs record -lam d d +# We use --match 'touch d/f' instead of simply d/f because the latter +# prints "Changes to d/f:\n" before the count. +test 0 -eq "$(darcs log --count --match 'touch d/f')" + +cd .. +rm -rf temp1 + +## issue1632 - 'darcs changes d/f' should not list any changes, +## where d is part of the repo and f is a non-existent file. + +darcs init temp1 +cd temp1 + +mkdir d +darcs record -lam 'added directory d' +# darcs should not list any changes here: +darcs changes non-existent-file > log +not grep 'added directory d' log +# ...and neither here: +darcs changes d/non-existent-file > log +not grep 'added directory d' log +cd .. +rm -rf temp1 + +## issue1888 - changes --context is broken when topmost patch +## is a clean tag. + +darcs init temp1 +cd temp1 + +echo a > a ; darcs rec -lam "patch_a" +darcs log --context | grep patch_a + +darcs tag -m "tag_a" +darcs log --context | not grep patch_a +darcs log --context | grep tag_a + +echo b > a; darcs rec -lam "patch_b" +darcs log --context | not grep patch_a +darcs log --context | grep tag_a +darcs log --context | grep patch_b +cd .. +rm -rf temp1 + + diff --git a/tests/log_send_context.sh b/tests/log_send_context.sh new file mode 100644 --- /dev/null +++ b/tests/log_send_context.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash +. ./lib + +# RT#544 using context created with 8-bit chars; +rm -rf temp1 + +mkdir temp1 + +cd temp1 +darcs init +touch foo +darcs record -la -m 'add\212 foo' | grep 'Finished record' +darcs log --context >context +date > foo +darcs record -a -m 'date foo' | grep 'Finished record' +darcs send -a -o patch --context context . | grep 'Wrote patch to' +cd .. +rm -rf temp1 diff --git a/tests/look_for_moves.sh b/tests/look_for_moves.sh --- a/tests/look_for_moves.sh +++ b/tests/look_for_moves.sh @@ -10,7 +10,7 @@ darcs init touch foo -darcs record -a -m add_file -A x --look-for-adds +darcs record -lam add_file mv foo foo2 darcs wh --summary --look-for-moves >log 2>&1 cat > log.expected <log 2>&1 grep -vE "(^ *$|^\+|No changes!)" log rm -rf * @@ -27,7 +27,7 @@ darcs init mkdir foo -darcs record -a -m add_dir -A x --look-for-adds +darcs record -lam add_dir mv foo foo2 darcs wh --summary --look-for-moves >log 2>&1 cat > log.expected <log 2>&1 grep -vE "(^ *$|^\+|No changes!)" log rm -rf * @@ -44,7 +44,7 @@ darcs init touch foo -darcs record -a -m add_file -A x --look-for-adds +darcs record -lam add_file mv foo foo2 touch foo darcs wh --summary --look-for-moves >log 2>&1 @@ -58,7 +58,7 @@ ./foo -> ./foo2 a ./foo EOF -darcs record -a -m move_file_add_file -A x --look-for-moves --look-for-adds +darcs record -am move_file_add_file --look-for-moves --look-for-adds grep -vE "(^ *$|^\+|No changes!)" log rm -rf * @@ -66,25 +66,25 @@ darcs init touch foo -darcs record -a -m add_file -A x --look-for-adds +darcs record -lam add_file mv foo foo2 -echo 'yyy' | darcs amend-record -p add_file -A x --look-for-moves +echo 'yyy' | darcs amend-record -p add_file --look-for-moves darcs wh --look-for-moves --look-for-adds >log 2>&1 grep -vE "(^ *$|^\+|No changes!)" log -darcs annotate --patch add_file | grep "] addfile ./foo2" +darcs log -v --machine -p add_file | grep "] addfile ./foo2" rm -rf * # add, move, add same name and amend-record darcs init touch foo -darcs record -a -m add_file -A x --look-for-adds +darcs record -lam add_file mv foo foo2 touch foo -echo 'yyyy' | darcs amend-record -p add_file -A x --look-for-moves --look-for-adds +echo 'yyyy' | darcs amend-record -p add_file --look-for-moves --look-for-adds darcs wh --look-for-moves --look-for-adds >log 2>&1 grep -vE "(^ *$|^\+|No changes!)" log -darcs annotate --patch add_file >log 2>&1 +darcs log -v --patch add_file >log 2>&1 grep "addfile ./foo" log grep "addfile ./foo2" log rm -rf * @@ -93,11 +93,11 @@ darcs init touch foo -darcs record -a -m add_file -A x --look-for-adds +darcs record -lam add_file mv foo foo2 -echo 'yyy' | darcs amend-record -p add_file -A x --look-for-moves +echo 'yyy' | darcs amend-record -p add_file --look-for-moves mv foo2 foo -echo 'yyy' | darcs amend-record -p add_file -A x --look-for-moves +echo 'yyy' | darcs amend-record -p add_file --look-for-moves darcs wh --look-for-moves --look-for-adds >log 2>&1 grep -vE "(^ *$|^\+|No changes!)" log rm -rf * @@ -108,7 +108,7 @@ touch foo # created before dir to get a lower inode mkdir dir mv foo dir -darcs record -a -m add_files -A x --look-for-adds +darcs record -lam add_files mv dir dir2 darcs wh --summary --look-for-moves > log 2>&1 cat > log.expected <log 2>&1 grep -vE "(^ *$|^\+|No changes!)" log rm -rf * @@ -125,30 +125,35 @@ darcs init touch foo foo2 -darcs record -lam add_file -A x +darcs record -lam add_file mv foo foo.tmp mv foo2 foo mv foo.tmp foo2 not darcs wh --look-for-moves rm -rf * -# dir swapping -- ignored +# dir swapping -- dir moves are ignored but inner files moves are considered darcs init mkdir dir dir2 touch dir/foo dir2/foo2 -darcs record -a -m add_files_and_dirs -A x --look-for-adds +darcs record -lam add_files_and_dirs mv dir dir.tmp mv dir2 dir mv dir.tmp dir2 -not darcs wh --summary --look-for-moves +darcs wh --summary --look-for-moves > log 2>&1 +cat > log.expected < ./dir2/foo + ./dir2/foo2 -> ./dir/foo2 +EOF +diff -u log log.expected rm -rf * # darcs mv before a plain mv darcs init touch foo -darcs record -a -m add_files_and_dirs -A x --look-for-adds +darcs record -lam add_files_and_dirs darcs mv foo foo2 mv foo2 foo3 darcs wh --summary --look-for-moves > log 2>&1 @@ -157,7 +162,7 @@ EOF diff -u log log.expected rm log log.expected -darcs record -a -m move_dirs -A x --look-for-moves +darcs record -a -m move_dirs --look-for-moves darcs wh --look-for-moves --look-for-adds >log 2>&1 grep -vE "(^ *$|^\+|No changes!)" log rm -rf * @@ -166,7 +171,7 @@ darcs init touch foo -darcs record -a -m add_files_and_dirs -A x --look-for-adds +darcs record -lam add_files_and_dirs mv foo foo~ darcs wh --summary --look-for-moves > log 2>&1 cat > log.expected <> one.txt darcs whatsnew -s | grep M darcs record -A bar -am "add extra line" -darcs annotate -p . -u darcs push -av > log cat log not grep -i conflicts log diff --git a/tests/mv-formerly-pl.sh b/tests/mv-formerly-pl.sh deleted file mode 100644 --- a/tests/mv-formerly-pl.sh +++ /dev/null @@ -1,123 +0,0 @@ -#!/usr/bin/env bash - -# Some tests for 'darcs mv' - -. lib - -rm -rf temp -mkdir temp -cd temp -darcs init - -### - -echo adding a directory with more than one .. in it should work. -mkdir foo.d -mkdir foo.d/second -mkdir foo.d/second/third -mkdir foo.d/other - - -touch ./foo.d/other/date.t -darcs add -r foo.d - -cd foo.d/second/third - -darcs mv ../../other/date.t ../../other/date_moved.t - -cd ../../.. -echo darcs refuses to move to an existing file -touch ping -touch pong -darcs add ping pong - -not darcs mv ping pong 2>&1 | grep "already exists" - -# case sensitivity series -# ----------------------- -# these are tests designed to check out darcs behave wrt to renames -# where the case of the file becomes important - -# are we on a case sensitive file system? -touch is_it_cs -rm -f IS_IT_CS - -if test -e is_it_cs; then - echo This is a case-sensitive file system. -else - echo This is NOT a case-sensitive file system. -fi - -# if the new file already exists - we don't allow it -# basically the same test as mv ping pong, except we do mv ping PING -# and both ping and PING exist on the filesystem -echo "case sensitivity - simply don't allow mv if new file exists" -touch 'cs-n-1'; touch 'CS-N-1'; -touch 'cs-y-1'; touch 'CS-Y-1'; -darcs add cs-n-1 cs-y-1 - -if test -e is_it_cs; then - # regardless of case-ok, we do NOT want this mv at all - not darcs mv cs-n-1 CS-Y-1 2>&1 | grep "already exists" - - not darcs mv --case-ok cs-n-1 CS-Y-1 2>&1 | grep "already exists" -fi - -# if the new file does not already exist - we allow it -echo "case sensitivity - the new file does *not* exist" -touch 'cs-n-2'; -touch 'cs-y-2'; -darcs add cs-n-2 cs-y-2 -# these mv's should be allowed regardless of flag or filesystem -darcs mv cs-n-2 CS-N-2 -darcs mv --case-ok cs-y-2 CS-Y-2 - -# parasites - do not accidentally overwrite a file just because it has a -# similar name and points to the same inode. We want to check if a file if the -# same NAME already exists - we shouldn't care about what the actual file is! -echo "case sensitivity - inode check"; -touch 'cs-n-3'; -touch 'cs-y-3'; -darcs add cs-n-3 cs-y-3 - -if ln cs-n-3 CS-N-3; then # checking if we support hard links - ln cs-y-3 CS-Y-3 - # regardless of case-ok, we do NOT want this mv at all - not darcs mv cs-n-3 CS-N-3 2>&1 | grep "already exists" - - not darcs mv --case-ok cs-y-3 CS-Y-3 2>&1 | grep "already exists" -fi - -# parasites - we don't allow weird stuff like mv foo bar/foo just because -# we opened up some crazy exception based on foo's name -echo 'refuses to move to an existing file with same name, different path' -touch 'cs-n-4'; touch 'foo.d/cs-n-4'; -touch 'cs-y-4'; touch 'foo.d/cs-y-4'; -darcs add cs-n-4 -# regardless of case-ok, we do NOT want this mv at all -not darcs mv cs-n-4 foo.d/cs-n-4 2>&1 | grep "already exists" - -not darcs mv --case-ok cs-y-4 foo.d/cs-y-4 2>&1 | grep "unadded" - -# --------------------------- -# end case sensitivity series - -touch abs_path.t -darcs add abs_path.t -REPO_ABS=`pwd` -darcs mv "$REPO_ABS/abs_path.t" abs_path_new.t -darcs mv abs_path_new.t "$REPO_ABS/abs_path.t" - - -# issue608 - - touch 'gonna_be_deleted'; - darcs add gonna_be_deleted - darcs record -am 'added doomed file' - rm gonna_be_deleted - darcs record -am 'deleted file' - touch 'new_file'; - darcs add new_file - darcs mv new_file gonna_be_deleted - - diff --git a/tests/mv-test-suite.sh b/tests/mv-test-suite.sh deleted file mode 100644 --- a/tests/mv-test-suite.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/env bash - -. ./lib - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init - -date > foo -darcs record -a -m add_foo -A x --look-for-adds - -# add a test file -echo 'test ! -e foo' > test.sh -darcs add test.sh -darcs record -a -m add_test - -darcs setpref test 'ls && bash test.sh' -darcs record -a -m settest -A x --no-test - -darcs mv foo bar -darcs record --debug -a -m mvfoo -A x - -darcs check - -cd .. -rm -rf temp1 - diff --git a/tests/mv.sh b/tests/mv.sh --- a/tests/mv.sh +++ b/tests/mv.sh @@ -1,10 +1,9 @@ #!/usr/bin/env bash . ./lib -rm -rf temp -mkdir temp -cd temp -darcs init +darcs init temp1 +cd temp1 + echo hi world > temp.c darcs add temp.c darcs record --all -A test --name=hi @@ -32,22 +31,247 @@ grep 'Cannot rename a file or directory onto itself' stderr cd .. +rm -rf temp1 -rm -rf temp -mkdir temp -cd temp -darcs init +darcs init temp1 +cd temp1 + echo hi world > a -darcs add a -darcs record --all -m lower +darcs record -lam lower cd .. -darcs get temp temp1 -cd temp +darcs clone temp1 temp2 +cd temp1 darcs mv a A echo goodbye > A darcs record --all -m 'to upper' -cd ../temp1 +cd ../temp2 darcs pull -a cd .. -rm -rf temp temp1 +rm -rf temp1 temp2 + +# Part 2 + +darcs init temp1 +cd temp1 + +echo adding a directory with more than one .. in it should work. +mkdir foo.d +mkdir foo.d/second +mkdir foo.d/second/third +mkdir foo.d/other + +touch ./foo.d/other/date.t +darcs add -r foo.d + +cd foo.d/second/third + +darcs mv ../../other/date.t ../../other/date_moved.t + +cd ../../.. +echo darcs refuses to move to an existing file +touch ping pong +darcs add ping pong + +not darcs mv ping pong 2>&1 | grep "already exists" + +# case sensitivity series +# ----------------------- +# these are tests designed to check out darcs behave wrt to renames +# where the case of the file becomes important + +# are we on a case sensitive file system? +touch is_it_cs +rm -f IS_IT_CS + +if test -e is_it_cs; then + echo This is a case-sensitive file system. +else + echo This is NOT a case-sensitive file system. +fi + +# if the new file already exists - we don't allow it +# basically the same test as mv ping pong, except we do mv ping PING +# and both ping and PING exist on the filesystem +echo "case sensitivity - simply don't allow mv if new file exists" +touch 'cs-n-1'; touch 'CS-N-1'; +touch 'cs-y-1'; touch 'CS-Y-1'; +darcs add cs-n-1 cs-y-1 + +if test -e is_it_cs; then + # regardless of case-ok, we do NOT want this mv at all + not darcs mv cs-n-1 CS-Y-1 2>&1 | grep "already exists" + + not darcs mv --case-ok cs-n-1 CS-Y-1 2>&1 | grep "already exists" +fi + +# if the new file does not already exist - we allow it +echo "case sensitivity - the new file does *not* exist" +touch 'cs-n-2'; +touch 'cs-y-2'; +darcs add cs-n-2 cs-y-2 +# these mv's should be allowed regardless of flag or filesystem +darcs mv cs-n-2 CS-N-2 +darcs mv --case-ok cs-y-2 CS-Y-2 + +# parasites - do not accidentally overwrite a file just because it has a +# similar name and points to the same inode. We want to check if a file if the +# same NAME already exists - we shouldn't care about what the actual file is! +echo "case sensitivity - inode check"; +touch 'cs-n-3'; +touch 'cs-y-3'; +darcs add cs-n-3 cs-y-3 + +if ln cs-n-3 CS-N-3; then # checking if we support hard links + ln cs-y-3 CS-Y-3 + # regardless of case-ok, we do NOT want this mv at all + not darcs mv cs-n-3 CS-N-3 2>&1 | grep "already exists" + + not darcs mv --case-ok cs-y-3 CS-Y-3 2>&1 | grep "already exists" +fi + +# parasites - we don't allow weird stuff like mv foo bar/foo just because +# we opened up some crazy exception based on foo's name +echo 'refuses to move to an existing file with same name, different path' +touch 'cs-n-4'; touch 'foo.d/cs-n-4'; +touch 'cs-y-4'; touch 'foo.d/cs-y-4'; +darcs add cs-n-4 +# regardless of case-ok, we do NOT want this mv at all +not darcs mv cs-n-4 foo.d/cs-n-4 2>&1 | grep "already exists" + +not darcs mv --case-ok cs-y-4 foo.d/cs-y-4 2>&1 | grep "unadded" + +# --------------------------- +# end case sensitivity series + +touch abs_path.t +darcs add abs_path.t +REPO_ABS=`pwd` +darcs mv "$REPO_ABS/abs_path.t" abs_path_new.t +darcs mv abs_path_new.t "$REPO_ABS/abs_path.t" + +# issue608 + +touch 'gonna_be_deleted'; +darcs add gonna_be_deleted +darcs record -am 'added doomed file' +rm gonna_be_deleted +darcs record -am 'deleted file' +touch 'new_file'; +darcs add new_file +darcs mv new_file gonna_be_deleted + +cd .. +rm -rf temp1 + +# mv and test suite + +darcs init temp1 +cd temp1 + +date > foo +darcs record -lam add_foo + +echo 'test ! -e foo' > test.sh # "foo should not exist" +darcs record -lam add_test + +darcs setpref test 'ls && bash test.sh' +darcs record -a -m settest --no-test + +darcs mv foo bar +darcs record --debug -a -m mvfoo + +cd .. +rm -rf temp1 + +# mv then ad + +darcs init temp1 +cd temp1 + +touch fee fi fo fum +darcs record -lam add +darcs mv fee foo +touch fee +darcs add fee +darcs record -a -m newfee +darcs mv fi fib +darcs record -a -m mvfi +date > fi +darcs add fi +darcs record -a -m newfi + +cd .. +rm -rf temp1 + +# illegal mv + +darcs init temp1 +cd temp1 + +echo text > afile.txt +darcs record -lam init +mkdir d +not darcs mv afile.txt d/afile.txt # should fail, since d not in repo + +cd .. +rm -rf temp1 + +# swapping files + +darcs init temp1 +cd temp1 + +touch foo bar +darcs record -lam add_foo_bar +darcs mv foo zig +darcs mv bar foo +darcs mv zig bar +darcs record -a -m swap_foo_bar +cd .. +rm -rf temp1 + + +## issue2139 - darcs should accept to mv to the current working directory +## Copyright (C) 2012 Eric Kow + +darcs init temp1 +cd temp1 + +# move dir to root +mkdir a a/a2 a/a3 +darcs record -lam 'Some directories (a)' +darcs mv a/a2 . +test -d a2 +cd a +darcs mv a3 .. +not test -d a3 +cd .. +test -d a3 + +# move dir to non-root dir +mkdir b b2 b3 +darcs record -lam 'Some directories (b)' +darcs mv b2 b +test -d b/b2 +cd b +darcs mv ../b3 . +test -d b3 +cd .. + +cd .. +rm -rf temp1 + +# issue1740 - darcs mv on directories should work after the fact + +darcs init temp1 +cd temp1 + +mkdir d +echo 'Example content.' > d/f +darcs record -lam 'Add d/f' +mv d d2 +darcs mv d d2 # oops, I meant to darcs mv that +darcs what | grep "move ./d ./d2" +cd .. +rm -rf temp1 diff --git a/tests/mv_then_add.sh b/tests/mv_then_add.sh deleted file mode 100644 --- a/tests/mv_then_add.sh +++ /dev/null @@ -1,25 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf temp -mkdir temp -cd temp - -darcs init -touch fee fi fo fum -darcs add f* -darcs record --author me --all --no-test --name add -darcs mv fee foo -touch fee -darcs add fee -darcs record --author me --all --no-test --name newfee -darcs mv fi fib -darcs record --author me --all --no-test --name mvfi -date > fi -darcs add fi -darcs record --author me --all --no-test --name newfi - -cd .. - -rm -rf temp - diff --git a/tests/network/clone-http-packed-detect.sh b/tests/network/clone-http-packed-detect.sh new file mode 100644 --- /dev/null +++ b/tests/network/clone-http-packed-detect.sh @@ -0,0 +1,40 @@ +#!/usr/bin/env bash +# 2011, by Petr Rockai, Guillaume Hoffmann, public domain + +# Tests that darcs clone --verbose reports getting a pack when there is one, +# and does not report when there is none or when --no-packs is passed. + +#pragma repo-format darcs-1,darcs-2 + +. lib + +rm -rf S + +if grep darcs-1 .darcs/defaults; then +format=hashed +elif grep darcs-2 .darcs/defaults; then +format=darcs-2 +else format=ERROR; fi + +gunzip -c $TESTDATA/many-files--${format}.tgz | tar xf - + +cd many* + +darcs optimize http +test -e _darcs/packs/basic.tar.gz +test -e _darcs/packs/patches.tar.gz +cd .. + +serve_http # sets baseurl + +# check that default behaviour is to get packs +darcs clone $baseurl/many-files--${format} S --verbose |grep "Cloning packed basic repository" + +# check that it does really not get packs when --no-packs is passed +rm -rf S +darcs clone $baseurl/many-files--${format} S --no-packs --verbose |not grep "Cloning packed basic repository" + +# check that it does not clam getting packs when there are not +rm -rf S +rm -rf many-files--${format}/_darcs/packs/ +darcs clone $baseurl/many-files--${format} S --verbose |not grep "Cloning packed basic repository" diff --git a/tests/network/clone-http-packed.sh b/tests/network/clone-http-packed.sh new file mode 100644 --- /dev/null +++ b/tests/network/clone-http-packed.sh @@ -0,0 +1,29 @@ +#!/usr/bin/env bash +# Written in 2010 by Petr Rockai, placed in public domain + +#pragma repo-format darcs-1,darcs-2 + +. lib + +rm -rf S + +if grep darcs-1 .darcs/defaults; then +format=hashed +elif grep darcs-2 .darcs/defaults; then +format=darcs-2 +else format=ERROR; fi + +gunzip -c $TESTDATA/many-files--${format}.tgz | tar xf - + +cd many* + +darcs optimize http +test -e _darcs/packs/basic.tar.gz +test -e _darcs/packs/patches.tar.gz +cd .. + +serve_http # sets baseurl +darcs clone --packs $baseurl/many-files--${format} S +cd S +rm _darcs/prefs/sources # avoid any further contact with the original repository +darcs check diff --git a/tests/network/clone-http.sh b/tests/network/clone-http.sh new file mode 100644 --- /dev/null +++ b/tests/network/clone-http.sh @@ -0,0 +1,41 @@ +#!/usr/bin/env bash +# Written in 2010 by Petr Rockai, placed in public domain + +# This file is included as part of the Darcs test distribution, +# which is licensed to you under the following terms: +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +rm -rf R S && mkdir R +cd R +darcs init +echo a > a +darcs rec -lam a +cd .. + +serve_http # sets baseurl +darcs clone $baseurl/R S +cd S +darcs pull ../R | tee log +grep "No remote" log +darcs check diff --git a/tests/network/clone.sh b/tests/network/clone.sh --- a/tests/network/clone.sh +++ b/tests/network/clone.sh @@ -1,6 +1,9 @@ #!/usr/bin/env bash -set -ev +. lib + +check_remote_http http://hub.darcs.net/kowey/tabular + rm -rf temp temp2 temp3 #"$DARCS" clone http://hub.darcs.net/kowey/tabular temp @@ -15,5 +18,3 @@ cd .. diff -u temp2/_darcs/hashed_inventory temp3/_darcs/hashed_inventory - -rm -rf temp temp2 temp3 diff --git a/tests/network/issue1503_prefer_local_caches_to_remote_one.sh b/tests/network/issue1503_prefer_local_caches_to_remote_one.sh --- a/tests/network/issue1503_prefer_local_caches_to_remote_one.sh +++ b/tests/network/issue1503_prefer_local_caches_to_remote_one.sh @@ -25,6 +25,8 @@ . lib +check_remote_http http://darcs.net/testing/repo1 + rm -rf S T darcs clone --lazy http://darcs.net/testing/repo1 S darcs tag --repo S -m 2 diff --git a/tests/network/issue1599-automatically-expire-unused-caches.sh b/tests/network/issue1599-automatically-expire-unused-caches.sh new file mode 100644 --- /dev/null +++ b/tests/network/issue1599-automatically-expire-unused-caches.sh @@ -0,0 +1,55 @@ +#!/usr/bin/env bash +## Test for issue1599 - 'Automatically expire unused caches' +## +## Copyright (C) 2010 Adolfo Builes +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. +. lib + +rm -rf R S log && mkdir R +cd R +darcs init +echo a > a +darcs rec -lam a +echo b > b +darcs rec -lam b +echo c > c +darcs rec -lam c +cd .. + +serve_http # sets baseurl +darcs clone --lazy $baseurl/R S +rm S/_darcs/prefs/sources +if [ -z "$http_proxy" ]; then + echo "repo:http://10.1.2.3/S" >> S/_darcs/prefs/sources +fi +echo "repo:$baseurl/dummyRepo" >> S/_darcs/prefs/sources +echo "repo:~/test1599/S" >> S/_darcs/prefs/sources +echo "repo:$baseurl/R" >> S/_darcs/prefs/sources +export DARCS_CONNECTION_TIMEOUT=1 && darcs log --repo S --debug --verbose --no-cache 2>&1 | tee log +if [ -z "$http_proxy" ]; then + c=`grep -c "URL.waitUrl http://10.1.2.3/S" log` + [ $c -eq 1 ] +fi +c1=`grep -c "URL.waitUrl $baseurl/dummyRepo" log` +[ $c1 -eq 2 ] +c2=`grep -c "~/test1599/S" log` +[ $c2 -eq 1 ] diff --git a/tests/network/issue1923-cache-warning.sh b/tests/network/issue1923-cache-warning.sh new file mode 100644 --- /dev/null +++ b/tests/network/issue1923-cache-warning.sh @@ -0,0 +1,53 @@ +#!/usr/bin/env bash +## Test for issue1599 - 'Automatically expire unused caches' +## +## Copyright (C) 2010 Adolfo Builes +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. +. lib + +darcs init --repo R +cd R +echo a > a +darcs rec -lam a +cd .. + +serve_http +cat < fake-sources +repo:$baseurl/dummyRepo +repo:/some/bogus/local/path +repo:$baseurl/R +SOURCES +darcs clone --lazy R S1 && cp fake-sources S1/_darcs/prefs/sources +darcs clone --lazy R S2 && cp fake-sources S2/_darcs/prefs/sources + +# make sure we do warn about things that are under your control +darcs log --verbose --repo S1 --no-cache 2>&1 | tee log-local +c1=`grep -c "$baseurl/dummyRepo" log-local` +[ $c1 -eq 1 ] +c2=`grep -c "/some/bogus/local/path" log-local` +[ $c2 -eq 1 ] + +# now what about things that aren't? +darcs log --verbose --repo $baseurl/S2 --no-cache 2>&1 | tee log-remote +c1=`grep -c "$baseurl/dummyRepo" log-remote` +[ $c1 -eq 1 ] # always under your control +not grep -c "/some/bogus/local/path" log-remote diff --git a/tests/network/issue1932-remote.sh b/tests/network/issue1932-remote.sh new file mode 100644 --- /dev/null +++ b/tests/network/issue1932-remote.sh @@ -0,0 +1,41 @@ +#!/usr/bin/env bash +## Test for issue1932 - "darcs add -qr ." should not break on files with colons +## +## Copyright(C) 2010 Dmitry Astapov +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. + +# Colons could be in repo names and in file name. +# Colon in repo name is an indication of special case - remote repo. +# Colon in the file could be there under unix and requires no special treatment. + +# Repo name with ':' is either scp repo or http repo. +# Let's check scp repo first. +( darcs clone user@invalid:path || true ) > log 2>&1 +[ -n "$(fgrep 'ssh: Could not resolve hostname invalid: Name or service not known' log)" ] + +# HTTP repo +( darcs clone http://www.bogus.domain.so.it.will.surely.fail.com || true ) 2>&1 | tee log +egrep 'CouldNotResolveHost|host lookup failure' log + +# local repos are tested by tests/issue1932-colon-breaks-add.sh diff --git a/tests/network/issue2090-transfer-mode.sh b/tests/network/issue2090-transfer-mode.sh --- a/tests/network/issue2090-transfer-mode.sh +++ b/tests/network/issue2090-transfer-mode.sh @@ -23,10 +23,13 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -echo 'Comment this line out and run the script by hand'; exit 200 +# echo 'Comment this line out and run the script by hand'; exit 200 -. $(dirname $0)/../lib -. $(dirname $0)/sshlib +# . $(dirname $0)/../lib +# . $(dirname $0)/sshlib + +. lib +. sshlib # Clean up after previous remote runs ${SSH} ${REMOTE} "\ diff --git a/tests/network/lazy-clone.sh b/tests/network/lazy-clone.sh --- a/tests/network/lazy-clone.sh +++ b/tests/network/lazy-clone.sh @@ -1,6 +1,9 @@ #!/usr/bin/env bash -set -ev +. lib + +check_remote_http http://hub.darcs.net/kowey/tabular + rm -rf temp temp2 temp3 darcs clone --lazy http://hub.darcs.net/kowey/tabular temp @@ -13,7 +16,7 @@ test ! -f _darcs/patches/0000005705-178beaf653578703e32346b4d68c8ee2f84aeef548633b2dafe3a5974d763bf2 -darcs annotate -p 'Initial version' +darcs log -p 'Initial version' -v | cat test -f _darcs/patches/0000005705-178beaf653578703e32346b4d68c8ee2f84aeef548633b2dafe3a5974d763bf2 diff --git a/tests/network/log.sh b/tests/network/log.sh --- a/tests/network/log.sh +++ b/tests/network/log.sh @@ -2,6 +2,8 @@ . lib +check_remote_http http://darcs.net + # Demonstrates issue385 and others darcs log --repo=http://darcs.net GNUmakefile --last 300 @@ -10,8 +12,11 @@ # no _darcs should remain test ! -d _darcs # go to a directory where we have no write access +# (I dearly hope nobody tries to run the tests as root!) cd / # and try again (with less patches to fetch) darcs log --repo=http://darcs.net GNUmakefile --last 3 # an absolute path should give an error not darcs log --repo=http://darcs.net /GNUmakefile --last 3 +# also test that it works without any filename arguments +darcs log --repo=http://darcs.net --last 1 diff --git a/tests/network/show_tags-remote.sh b/tests/network/show_tags-remote.sh new file mode 100644 --- /dev/null +++ b/tests/network/show_tags-remote.sh @@ -0,0 +1,46 @@ +#!/usr/bin/env bash +## Test for show tags --repo +## +## Copyright (C) 2010 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +darcs init --repo R # Create our test repos. +darcs init --repo S + +cd R +echo 'Example content.' > f +darcs record -lam 'Add f' +darcs tag 't0' +darcs tag 't1' +darcs show tags | grep t0 +cd .. +serve_http # sets baseurl + +cd S +darcs log --repo ../R +darcs show tags --repo ../R | grep t0 +darcs show tags --repo $baseurl/R | grep t0 +cd .. + +darcs show tags --repo R | grep t0 +darcs show tags --repo $baseurl/R | grep t0 diff --git a/tests/network/ssh.sh b/tests/network/ssh.sh --- a/tests/network/ssh.sh +++ b/tests/network/ssh.sh @@ -1,31 +1,36 @@ #!/bin/bash -echo 'Comment this line out and run the script by hand'; exit 200 +# echo 'Comment this line out and run the script by hand'; exit 200 -. $(dirname $0)/../lib -. $(dirname $0)/sshlib +# . $(dirname $0)/../lib +# . $(dirname $0)/sshlib +. lib +. sshlib + # ================ Setting up remote repositories =============== -${SSH} ${REMOTE} "\ -rm -rf ${REMOTE_DIR}; \ -mkdir ${REMOTE_DIR}; \ -cd ${REMOTE_DIR}; \ -\ -mkdir testrepo; cd testrepo; \ -darcs init; \ -echo moi > _darcs/prefs/author; \ -touch a; darcs add a; darcs record a --ignore-times -am 'add file a'; \ -echo 'first line' > a; darcs record a --ignore-times -am 'add first line to a'; \ -cd ..; \ -\ -darcs clone testrepo testrepo-pull; \ -cd testrepo-pull; \ -echo moi > _darcs/prefs/author; \ -touch b; darcs add b; darcs record b --ignore-times -am 'add file b'; \ -echo 'other line' > b; darcs record b --ignore-times -am 'add other line to b'; \ -cd ..; \ -\ -darcs clone testrepo testrepo-push; \ -darcs clone testrepo testrepo-send; \ +${SSH} ${REMOTE} " +rm -rf ${REMOTE_DIR} +mkdir ${REMOTE_DIR} +cd ${REMOTE_DIR} + +mkdir testrepo; cd testrepo +darcs init +echo moi > _darcs/prefs/author +touch a; darcs add a +darcs record --skip-long-comment a --ignore-times -am 'add file a' +echo 'first line' > a +darcs record --skip-long-comment a --ignore-times -am 'add first line to a' +cd .. + +darcs clone testrepo testrepo-pull +cd testrepo-pull +echo moi > _darcs/prefs/author +touch b; darcs add b; darcs record --skip-long-comment b --ignore-times -am 'add file b' +echo 'other line' > b; darcs record --skip-long-comment b --ignore-times -am 'add other line to b' +cd .. + +darcs clone testrepo testrepo-push +darcs clone testrepo testrepo-send " # ================ Settings =============== @@ -63,9 +68,10 @@ darcs clone ${DARCS_SSH_FLAGS} testrepo testrepo-push cd testrepo-push echo moi > _darcs/prefs/author -echo "second line" >> a; darcs record a --ignore-times -am "add second line to a" +echo "second line" >> a +darcs record --skip-long-comment a --ignore-times -am "add second line to a" touch c; darcs add c -darcs record --ignore-times -am "add file c" c +darcs record --skip-long-comment --ignore-times -am "add file c" c echo yyy | darcs push ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-push # check that the file c got pushed over ${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/testrepo-push/c ]" @@ -88,11 +94,11 @@ cd testrepo echo moi > _darcs/prefs/author echo 'change for remote' > a -darcs record --ignore-times -am 'change for remote' +darcs record --skip-long-comment --ignore-times -am 'change for remote' darcs push -a darcs ob --last 1 -a echo 'change for local' > a -darcs record --ignore-times -am 'change for local' +darcs record --skip-long-comment --ignore-times -am 'change for local' darcs push -a > log 2>&1 || : grep -q 'conflicts options to apply' log diff --git a/tests/obliterate-add.sh b/tests/obliterate-add.sh deleted file mode 100644 --- a/tests/obliterate-add.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/env bash - -. lib - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -echo foo > foo -darcs add foo - -darcs record -a -m 'addfoo' - -darcs obliterate -a - -not darcs whatsnew - -cd .. -rm -rf temp1 diff --git a/tests/obliterate-formerly-pl.sh b/tests/obliterate-formerly-pl.sh deleted file mode 100644 --- a/tests/obliterate-formerly-pl.sh +++ /dev/null @@ -1,32 +0,0 @@ -#!/usr/bin/env bash -# Some tests for 'darcs obliterate' - -. lib - -rm -rf temp1 - -# set up the repository -mkdir temp1 -cd temp1 -darcs init -cd .. - -cd temp1 -touch a.txt -darcs add a.txt -darcs record -a -m 'adding a' a.txt -touch b.txt -darcs add b.txt -darcs record -a -m 'adding b' b.txt -# extra confirmation for --all -echo an | darcs obliterate -p add | grep -i "really obliterate" -# --last=1 -echo nyy | darcs obliterate --last 1 | grep -i adding -# automatically getting dependencies -date >> a.txt -darcs record -a -m 'modifying a' a.txt -echo ny | darcs obliterate -p 'adding a' > log -grep -i "modifying a" log -grep -i "No patches selected" log -cd .. -rm -rf temp1 diff --git a/tests/obliterate.sh b/tests/obliterate.sh --- a/tests/obliterate.sh +++ b/tests/obliterate.sh @@ -1,29 +1,24 @@ #!/usr/bin/env bash . ./lib -rm -rf tempA -mkdir tempA -cd tempA -darcs initialize -echo hello world > foo -darcs add foo -darcs record -a -m hellofoo +# Part 1 +rm -rf temp1 +darcs initialize temp1 +cd temp1 + +echo hello world > foo +darcs record -l -a -m hellofoo echo goodbye world >> foo darcs record -a -m goodbyefoo - darcs replace world bar foo echo Hi there foo > bar -darcs add bar -darcs record -a -m addbar - +darcs record -l -a -m addbar darcs mv bar baz darcs replace bar baz foo darcs record -a -m bar2baz - echo Do not love the baz, or anything in the baz. >> foo darcs record -a -m nolove - darcs mv baz world darcs replace baz world foo darcs record -a -m baz2world @@ -47,5 +42,65 @@ grep 'love' foo && exit 1 || true cd .. -rm -rf tempA +rm -rf temp1 +# Part 2 + +darcs init temp1 +cd temp1 + +touch a.txt +darcs add a.txt +darcs record -a -m 'adding a' a.txt +touch b.txt +darcs add b.txt +darcs record -a -m 'adding b' b.txt +# extra confirmation for --all +echo an | darcs obliterate -p add | grep -i "really obliterate" +# --last=1 +echo nyy | darcs obliterate --last 1 | grep -i adding +# automatically getting dependencies +date >> a.txt +darcs record -a -m 'modifying a' a.txt +echo ny | darcs obliterate -p 'adding a' > log +grep -i "modifying a" log +grep -i "No patches selected" log +cd .. +rm -rf temp1 + +# Part 3 + +darcs init temp1 +cd temp1 + +echo foo > foo +darcs record -l -a -m 'addfoo' + +darcs obliterate -a + +not darcs whatsnew + +cd .. +rm -rf temp1 + +# Part 4 + +darcs init temp1 +cd temp1 + +cat > f < f < f darcs record -lam 'Another update by newer darcs' # Still good? -darcs show patch-index-status | grep 'Patch Index is in sync with repo.' +darcs show patch-index | grep 'Patch Index is in sync with repo.' # Clean up. cd .. diff --git a/tests/patch-index-rename.sh b/tests/patch-index-rename.sh --- a/tests/patch-index-rename.sh +++ b/tests/patch-index-rename.sh @@ -34,5 +34,5 @@ darcs mv file1 file2 darcs rec -am "move" -darcs show patch-index-test +darcs show patch-index --verbose diff --git a/tests/patch-index-spans.sh b/tests/patch-index-spans.sh --- a/tests/patch-index-spans.sh +++ b/tests/patch-index-spans.sh @@ -31,7 +31,7 @@ mkdir d e # Change the working tree. echo 'Example content.' > d/f darcs record -lam 'Add d/f and e.' -darcs show patch-index-all > pi +darcs show patch-index --verbose > pi grep -F "./d -> 1#./d" pi grep -F "./d/f -> 1#./d/f" pi @@ -42,7 +42,7 @@ darcs mv d/f e/ darcs record -am 'Move d/f to e/f.' -darcs show patch-index-all > pi +darcs show patch-index --verbose > pi grep -F "./d -> 1#./d" pi grep -F "./d/f -> 1#./d/f" pi @@ -55,7 +55,7 @@ echo 'File 2' > d/f darcs record -lam 'Add d/f' -darcs show patch-index-all > pi +darcs show patch-index --verbose > pi grep -F "./d -> 1#./d" pi grep -F "./d/f -> 2#./d/f" pi diff --git a/tests/patch-index-sync.sh b/tests/patch-index-sync.sh --- a/tests/patch-index-sync.sh +++ b/tests/patch-index-sync.sh @@ -29,42 +29,42 @@ darcs init --repo R --with-patch-index darcs init --repo S --with-patch-index cd R -darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test init +darcs show patch-index | grep 'Patch Index is in sync with repo.' # test init mkdir d e echo 'Example content.' > d/f darcs record -lam 'Add d/f and e.' -darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test record +darcs show patch-index | grep 'Patch Index is in sync with repo.' # test record echo 'New line.' >> d/f echo "y" | darcs amend-record -p 'Add d/f and e.' -a -darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test amend-record +darcs show patch-index | grep 'Patch Index is in sync with repo.' # test amend-record darcs push -a ../S cd ../S -darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test push +darcs show patch-index | grep 'Patch Index is in sync with repo.' # test push echo 'Changed Content' > d/f darcs record -am 'Change d/f' -darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test record 2 +darcs show patch-index | grep 'Patch Index is in sync with repo.' # test record 2 darcs send -ao test.dpatch ../R cd .. darcs clone R T --with-patch-index cd T -darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test clone +darcs show patch-index | grep 'Patch Index is in sync with repo.' # test clone darcs pull -a ../S -darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test pull +darcs show patch-index | grep 'Patch Index is in sync with repo.' # test pull darcs obliterate -p 'Add d/f and e.' -a -darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test obliterate +darcs show patch-index | grep 'Patch Index is in sync with repo.' # test obliterate cd ../R darcs apply -a ../S/test.dpatch -darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test apply +darcs show patch-index | grep 'Patch Index is in sync with repo.' # test apply darcs unrecord -a -p 'Change d/f' -darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test unrecord +darcs show patch-index | grep 'Patch Index is in sync with repo.' # test unrecord darcs tag -m 'tag R' -darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test tag +darcs show patch-index | grep 'Patch Index is in sync with repo.' # test tag cd .. rm -rf R S T diff --git a/tests/pull-union.sh b/tests/pull-union.sh deleted file mode 100644 --- a/tests/pull-union.sh +++ /dev/null @@ -1,42 +0,0 @@ -#!/usr/bin/env bash - -. lib - -# This test script is in the public domain. - - -rm -rf temp1 temp2 temp3 - -mkdir temp1 -cd temp1 -darcs initialize -echo A > A -darcs add A -darcs record -a -m A -echo B > B -darcs add B -darcs record -a -m B - -cd .. -darcs get temp1 temp2 - -cd temp2 -darcs obliterate --last 1 -a -echo C > C -darcs add C -darcs record -a -m C -cd .. - -mkdir temp3 -cd temp3 -darcs init -darcs pull -a -v ../temp1 ../temp2 - -darcs changes > out -cat out -grep A out -grep B out -grep C out -cd .. - -rm -rf temp1 temp2 temp3 diff --git a/tests/pull.sh b/tests/pull.sh --- a/tests/pull.sh +++ b/tests/pull.sh @@ -4,23 +4,21 @@ rm -rf temp1 temp2 -mkdir temp1 +darcs init temp1 cd temp1 -darcs init cd .. -mkdir temp2 +darcs init temp2 cd temp2 -darcs init mkdir one cd one mkdir two cd two -echo darcs pull should work relative to the current directory +# darcs pull should work relative to the current directory darcs pull -a ../../../temp1 | grep -i 'No remote patches to pull in' -echo -- darcs pull should pull into repo specified with --repo +# darcs pull should pull into repo specified with --repo cd ../.. # now in temp2 darcs add one; darcs record --name uno --all @@ -42,7 +40,6 @@ chmod a-rwx ./temp1/one # remove all permissions not darcs pull --repodir ./temp1 -a 2> err chmod u+rwx temp1/one # restore permission - cat err grep 'permission denied' err rm -rf temp1/one fi @@ -55,11 +52,9 @@ #return special message when you try to pull from yourself DIR="`pwd`" not darcs pull --debug -a "$DIR" 2> out -cat out grep 'Can.t pull from current repository' out not darcs pull --debug -a . 2> out -cat out grep 'Can.t pull from current repository' out # and do not update the default repo to be the current di @@ -73,7 +68,6 @@ grep 'Can.t pull from current repository' err not darcs pull --debug ../* 2> out -cat out not grep 'Can.t pull from current repository' out cd .. # now outside of any repo @@ -121,7 +115,6 @@ cd ../temp2 mkdir newdir darcs pull -a --set-default ../temp1 &> out2 -cat out grep Backing out2 grep 'Finished pulling' out2 grep newdir out2 @@ -130,26 +123,200 @@ rm -rf temp1 temp2 -# A test for issue662, which triggered: +# issue662, which triggered: # darcs failed: Error applying hunk to file ./t.t # Error applying patch to the working directory. -rm -rf tmp; -darcs init --darcs-1 --repodir=tmp -touch tmp/t.t -cd tmp -darcs add t.t -echo 'content'>t.t -darcs record -am 'initial add' --ignore -echo 'content: remote change'>t.t +darcs init temp1 +cd temp1 + +touch t.t +echo 'content'> t.t +darcs record -lam 'initial add' +echo 'content: remote change'> t.t darcs record -am 'remote change' --ignore -darcs get . tmp2 -cd tmp2 -darcs obliterate --last 1 --all; +cd .. +darcs clone temp1 temp2 +cd temp2 +darcs obliterate --last 1 --all echo 'content: local change'> t.t -darcs pull -a ../ +darcs pull -a ../temp1 darcs w -s darcs revert -a +cd .. +rm -rf temp1 temp2 -cd ../.. -rm -rf tmp +# pull with conflicts + +darcs initialize temp1 +cd temp1 +echo foo > bar +darcs record -lam addbar + +cd .. +darcs clone temp1 temp2 +cd temp1 +date > bar +darcs record -a -m datebar +cd ../temp2 +echo aack >> bar +darcs record -a -m aackbar +darcs pull -a +darcs check + +cd .. +rm -rf temp1 temp2 + +# pull --union + +rm -rf temp1 temp2 temp3 + +darcs init temp1 +cd temp1 +echo A > A +darcs record -lam A +echo B > B +darcs record -lam B + +cd .. +darcs clone temp1 temp2 + +cd temp2 +darcs obliterate --last 1 -a +echo C > C +darcs record -lam C +cd .. + +darcs init temp3 +cd temp3 +darcs pull -a ../temp1 ../temp2 + +darcs log > out +grep A out +grep B out +grep C out + +cd .. +rm -rf temp1 temp2 temp3 + +# pull --intersection + +darcs init temp1 +cd temp1 +echo A > A +darcs record -lam Aismyname +echo B > B +darcs record -lam Bismyname + +cd .. +darcs clone temp1 temp2 +cd temp2 +darcs obliterate --last 1 -a +echo C > C +darcs record -lam Cismyname + +cd .. +darcs init temp3 +cd temp3 +darcs pull -a --intersection ../temp1 ../temp2 +darcs log > out +grep Aismyname out +not grep Bismyname out +not grep Cismyname out + +cd .. +rm -rf temp1 temp2 temp3 + + +# pull --skip-conflicts +rm -rf R S +darcs init R +cd R +echo 'foo' > foo +echo 'bar' > bar +darcs rec -lam 'Add foo and bar' +cd .. + +darcs clone R S + +cd R +echo 'foo2' > foo +darcs rec -lam 'Change foo (2)' +echo 'bar2' > bar +darcs rec -lam 'Change bar (2)' +cd .. + +cd S +echo 'foo3' > foo +darcs rec -lam 'Change foo (3)' +darcs pull --skip-conflicts -a ../R +test `darcs log --count` -eq 3 +cd .. + +cd S +darcs pull -a ../R +test `darcs log --count` -eq 4 +cd .. +rm -rf R S + +# bad pending after pull + +rm -fr temp1 temp2 + +darcs init temp1 +cd temp1 +echo abc > A +echo def > B1 +darcs record -lam patch1 +darcs mv B1 B2 +darcs record -am patch2 +cd .. + +darcs init temp2 +cd temp2 +darcs pull -a ../temp1 +not darcs whatsnew +cd .. + +rm -fr temp1 temp2 + +# issue494: note that in this test, we deliberately select filenames +# with a backwards sorting order +darcs init temp1 +cd temp1 +echo abc > b +darcs record -lam patch1 +darcs mv b a +echo def > a +darcs record -am patch2 +cd .. + +darcs init temp2 +cd temp2 +darcs pull --all ../temp1 +not darcs whatsnew +cd .. + +rm -fr temp1 temp2 + +# pull binary + +rm -rf temp1 temp2 + +darcs init temp1 +cd temp1 +printf "%01048576d" 0 > foo +darcs record -l -a -m xx +rm foo +darcs record -a -m yy +cd .. + +darcs init temp2 +cd temp2 +echo yny | darcs pull --set-default ../temp1 +rm foo +darcs pull -a +cd .. + +rm -rf temp1 temp2 + diff --git a/tests/pull_binary.sh b/tests/pull_binary.sh deleted file mode 100644 --- a/tests/pull_binary.sh +++ /dev/null @@ -1,50 +0,0 @@ -#!/usr/bin/env bash - -# This test script, originally written by David Roundy and Ian Lynagh is in -# the public domain. -# -# This file is included as part of the Darcs test distribution, -# which is licensed to you under the following terms: -# -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. ./lib - -rm -rf temp1 temp2 - -mkdir temp1 -cd temp1 -darcs init -printf "%01048576d" 0 > foo -darcs record -l -a -A author -m xx -rm foo -darcs record -a -A author -m yy -cd .. - -mkdir temp2 -cd temp2 -darcs init -echo yny | darcs pull --set-default ../temp1 -rm foo -darcs pull -a -cd .. - -rm -rf temp1 temp2 diff --git a/tests/pull_compl.sh b/tests/pull_compl.sh deleted file mode 100644 --- a/tests/pull_compl.sh +++ /dev/null @@ -1,145 +0,0 @@ -#!/usr/bin/env bash - -## Public domain 2007 Kevin Quick -## -## This file is included as part of the Darcs test distribution, -## which is licensed to you under the following terms: -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - - -. ./lib - -rm -rf temp1 temp2 temp3 temp4 temp5 - -mkdir temp1 -cd temp1 -cat > foo < foo.tmp - mv foo.tmp foo - darcs record -a --ignore-times -m "$2" -} - -cd temp1 -chgrec 's/line2/line2\nline2.1\nline2.2/' inssub2 -chgrec 's/line4/Line 4/' Line4 - -darcs changes | grep ' \*' -echo done with changes on temp1 > /dev/null - -cd .. -darcs get temp1 temp2 -darcs get temp1 temp3 -cd temp1 - -chgrec 's/line1/line0\nline1/' line0 -chgrec 's/Line 4/LINE FOUR/' LINE4 -chgrec 's/line7/line7\nLastLine/' LastLine -chgrec 's/LINE FOUR/LINE FOUR\nline4.1/' line4.1 - -darcs changes | grep ' \*' -echo done with changes on temp1 > /dev/null - -cd ../temp3 -darcs pull -p LastLine -av -chgrec 's/line1$/FirstLine/' FirstLine - -cd ../temp4 - -darcs changes | grep ' \*' -echo done with changes on temp4 > /dev/null - -darcs pull ../temp1 --dry-run | grep ' \*' -darcs pull ../temp1 --dry-run | grep ' \*' > p1.out -cat > p1.req < p2.out -diff p1.out p2.out - -darcs pull --dry-run --complement ../temp1 ../temp2 | grep ' \*' > p3.out -cat > p3.req < p4.out -cat > p4.req < p5.out -diff p4.out p5.out - -darcs pull --dry-run --complement ../temp1 ../temp2 ../temp3 ../temp2 ../temp2 ../temp3 ../temp3 ../temp2 | grep ' \*' > p6.out -diff p4.out p6.out - -darcs pull --dry-run --complement ../temp3 ../temp2 | grep ' \*' > p7.out -cat > p7.req < p8.out -grep "No remote patches to pull in!" p8.out - -# because duplicates are stripped before performing action, -# this is the same as: darcs pull ../temp1 -darcs pull --dry-run --complement ../temp1 ../temp1 > fooout -cat fooout -grep ' \*' fooout > p9.out -diff p1.req p9.out - -# so the "null" pull must be tested this way: -darcs get ../temp1 ../temp5 -darcs pull --dry-run --complement ../temp1 ../temp5 > p9.out -grep "No remote patches to pull in!" p9.out - -darcs pull -av --complement ../temp1 ../temp3 -darcs check - -cd .. -rm -rf temp1 temp2 temp3 temp4 temp5 diff --git a/tests/pull_complement.sh b/tests/pull_complement.sh new file mode 100644 --- /dev/null +++ b/tests/pull_complement.sh @@ -0,0 +1,145 @@ +#!/usr/bin/env bash + +## Public domain 2007 Kevin Quick +## +## This file is included as part of the Darcs test distribution, +## which is licensed to you under the following terms: +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + + +. ./lib + +rm -rf temp1 temp2 temp3 temp4 temp5 + +mkdir temp1 +cd temp1 +cat > foo < foo.tmp + mv foo.tmp foo + darcs record -a --ignore-times -m "$2" +} + +cd temp1 +chgrec 's/line2/line2\nline2.1\nline2.2/' inssub2 +chgrec 's/line4/Line 4/' Line4 + +darcs changes | grep ' \*' +echo done with changes on temp1 > /dev/null + +cd .. +darcs get temp1 temp2 +darcs get temp1 temp3 +cd temp1 + +chgrec 's/line1/line0\nline1/' line0 +chgrec 's/Line 4/LINE FOUR/' LINE4 +chgrec 's/line7/line7\nLastLine/' LastLine +chgrec 's/LINE FOUR/LINE FOUR\nline4.1/' line4.1 + +darcs changes | grep ' \*' +echo done with changes on temp1 > /dev/null + +cd ../temp3 +darcs pull -p LastLine -av +chgrec 's/line1$/FirstLine/' FirstLine + +cd ../temp4 + +darcs changes | grep ' \*' +echo done with changes on temp4 > /dev/null + +darcs pull ../temp1 --dry-run | grep ' \*' +darcs pull ../temp1 --dry-run | grep ' \*' > p1.out +cat > p1.req < p2.out +diff p1.out p2.out + +darcs pull --dry-run --complement ../temp1 ../temp2 | grep ' \*' > p3.out +cat > p3.req < p4.out +cat > p4.req < p5.out +diff p4.out p5.out + +darcs pull --dry-run --complement ../temp1 ../temp2 ../temp3 ../temp2 ../temp2 ../temp3 ../temp3 ../temp2 | grep ' \*' > p6.out +diff p4.out p6.out + +darcs pull --dry-run --complement ../temp3 ../temp2 | grep ' \*' > p7.out +cat > p7.req < p8.out +grep "No remote patches to pull in!" p8.out + +# because duplicates are stripped before performing action, +# this is the same as: darcs pull ../temp1 +darcs pull --dry-run --complement ../temp1 ../temp1 > fooout +cat fooout +grep ' \*' fooout > p9.out +diff p1.req p9.out + +# so the "null" pull must be tested this way: +darcs get ../temp1 ../temp5 +darcs pull --dry-run --complement ../temp1 ../temp5 > p9.out +grep "No remote patches to pull in!" p9.out + +darcs pull -av --complement ../temp1 ../temp3 +darcs check + +cd .. +rm -rf temp1 temp2 temp3 temp4 temp5 diff --git a/tests/pull_conflicts.sh b/tests/pull_conflicts.sh deleted file mode 100644 --- a/tests/pull_conflicts.sh +++ /dev/null @@ -1,57 +0,0 @@ -#!/usr/bin/env bash -## Test that pull --skip-conflicts filters the conflicts -## appropriately. -## -## Copyright (C) 2009 Ganesh Sittampalam -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -rm -rf R S # Another script may have left a mess. - -mkdir R -cd R -darcs init -echo 'foo' > foo -echo 'bar' > bar -darcs rec -lam 'Add foo and bar' -cd .. - -darcs get R S - -cd R -echo 'foo2' > foo -darcs rec -lam 'Change foo (2)' -echo 'bar2' > bar -darcs rec -lam 'Change bar (2)' -cd .. - -cd S -echo 'foo3' > foo -darcs rec -lam 'Change foo (3)' -darcs pull --skip-conflicts -a ../R -test `darcs changes --count` -eq 3 -cd .. - -cd S -darcs pull -a ../R -test `darcs changes --count` -eq 4 -cd .. diff --git a/tests/pull_two.sh b/tests/pull_two.sh deleted file mode 100644 --- a/tests/pull_two.sh +++ /dev/null @@ -1,34 +0,0 @@ -#!/usr/bin/env bash - -# This test script, originally written by David Roundy is in the public -# domain. - -. ./lib - -rm -rf temp1 temp2 - -mkdir temp1 -cd temp1 -echo foo > bar -darcs initialize -echo record author me > _darcs/prefs/defaults -darcs add bar -darcs record -a -m addbar - -cd .. -darcs get temp1 temp2 -cd temp1 -date > bar -darcs record -a -m datebar - -cd ../temp1 -echo aack >> bar -darcs record -a -m aackbar - -cd ../temp2 - -darcs pull -av -darcs check - -cd .. -rm -rf temp1 temp2 diff --git a/tests/push-dont-prompt-deps.sh b/tests/push-dont-prompt-deps.sh deleted file mode 100644 --- a/tests/push-dont-prompt-deps.sh +++ /dev/null @@ -1,32 +0,0 @@ -#!/usr/bin/env bash - -. ./lib - -# Check that the right patches get pushed using --dont-prompt-for-dependencies - -rm -rf temp1 -rm -rf temp2 -mkdir temp2 -mkdir temp1 -cd temp2 -darcs init -cd .. -cd temp1 -darcs init -echo foo > f -darcs record -Ax -alm foo1 -echo bar > b -darcs rec -Ax -alm bar1 -echo foo2 > f -darcs record -Ax -alm foo2 -echo bar2 > b -darcs record -Ax -alm bar2 -echo yy | darcs push ../temp2 --dont-prompt-for-dependencies -p foo2 --dry-run -i > toto -#on the previous line, we get asked about foo2, and we take it -grep foo2 toto | wc -l | grep 2 -#we don't get asked about foo1, but we take it anyway, so -grep foo1 toto | wc -l | grep 1 -#and we don't send bar -not grep bar toto -cd .. -rm -rf temp1 temp2 diff --git a/tests/push-dry-run.sh b/tests/push-dry-run.sh --- a/tests/push-dry-run.sh +++ b/tests/push-dry-run.sh @@ -4,16 +4,11 @@ # For issue855: wish: avoid taking lock if using --dry-run chmod -R u+w temp2 || : rm -rf temp1 temp2 -mkdir temp1 -cd temp1 -darcs init -cd .. -mkdir temp2 +darcs init temp1 +darcs init temp2 cd temp2 -darcs init touch x -darcs add x -darcs record -am "test" +darcs record -lam test cd .. chmod -R u-w temp2 cd temp2 diff --git a/tests/push-formerly-pl.sh b/tests/push-formerly-pl.sh deleted file mode 100644 --- a/tests/push-formerly-pl.sh +++ /dev/null @@ -1,57 +0,0 @@ -#!/usr/bin/env bash - -# Some tests for 'darcs push' - -. lib - -slash() { -if echo $OS | grep -q -i windows; then - echo -n \\ -else - echo -n / -fi -} - -DIR="`pwd`" - -rm -rf temp1 temp2 -mkdir temp1 -cd temp1 -darcs init -cd .. -mkdir temp2 -cd temp2 -darcs init -cd .. - -# push without a repo gives an error -cd temp1 -not darcs push -p 123 2> log -grep -i 'missing argument' log -cd .. - -mkdir -p temp2/one/two -cd temp2/one/two -# darcs push should work relative to the current directory -darcs push -a ../../../temp1 | grep -i 'No recorded local patches to push' -cd ../../../ - -# darcs push should push into repo specified with --repo -cd temp2 -darcs add one -darcs record --name uno --all -cd .. - -darcs push --repodir temp2 --all temp1 | grep -i 'Finished apply' - -cd temp1 -# Before trying to pull from self, defaultrepo does not exist -test ! -e _darcs/prefs/defaultrepo -# return special message when you try to push to yourself -not darcs push -a "$DIR`slash`temp1" 2> log -grep -i "cannot push from repository to itself" log -# and don't update the default repo to be the current dir -test ! -e _darcs/prefs/defaultrepo -cd .. - -rm -rf temp1 temp2 diff --git a/tests/push.sh b/tests/push.sh --- a/tests/push.sh +++ b/tests/push.sh @@ -1,21 +1,101 @@ #!/usr/bin/env bash -. ./lib -rm -rf temp temp_0 -mkdir temp -cd temp +# Some tests for 'darcs push' + +. lib + +slash() { +if echo $OS | grep -q -i windows; then + echo -n \\ +else + echo -n / +fi +} + +DIR="`pwd`" + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 darcs init -echo tester > _darcs/prefs/author -date > bla -darcs add bla -darcs record -a --name=11 cd .. -darcs get temp -cd temp -date > bla2 -darcs add bla2 -darcs record -a --name=22 -darcs push -a ../temp_0 +mkdir temp2 +cd temp2 +darcs init cd .. -rm -rf temp temp_0 +# push without a repo gives an error +cd temp1 +not darcs push -p 123 2> log +grep -i 'missing argument' log +cd .. + +mkdir -p temp2/one/two +cd temp2/one/two +# darcs push should work relative to the current directory +darcs push -a ../../../temp1 | grep -i 'No recorded local patches to push' +cd ../../../ + +# darcs push should push into repo specified with --repo +cd temp2 +darcs add one +darcs record --name uno --all +cd .. + +darcs push --repodir temp2 --all temp1 | grep -i 'Finished apply' + +cd temp1 +# Before trying to pull from self, defaultrepo does not exist +test ! -e _darcs/prefs/defaultrepo +# return special message when you try to push to yourself +not darcs push -a "$DIR`slash`temp1" 2> log +grep -i "cannot push from repository to itself" log +# and don't update the default repo to be the current dir +test ! -e _darcs/prefs/defaultrepo +cd .. + +rm -rf temp1 temp2 + +# Check that the right patches get pushed using --dont-prompt-for-dependencies + +rm -rf temp1 temp2 +darcs init temp2 +darcs init temp1 + +cd temp1 +echo foo > f +darcs record -alm foo1 +echo bar > b +darcs rec -alm bar1 +echo foo2 > f +darcs record -alm foo2 +echo bar2 > b +darcs record -alm bar2 +echo yy | darcs push ../temp2 --dont-prompt-for-dependencies -p foo2 --dry-run -i > toto +#on the previous line, we get asked about foo2, and we take it +grep foo2 toto | wc -l | grep 2 +#we don't get asked about foo1, but we take it anyway, so +grep foo1 toto | wc -l | grep 1 +#and we don't send bar +not grep bar toto +cd .. +rm -rf temp1 temp2 + +# For issue257: push => incorrect return code when couldn't get lock + +rm -rf temp1 temp2 +darcs init temp1 +cd temp1 +echo foo > foo.c +darcs rec -alm init +cd .. +darcs clone temp1 temp2 +cd temp2 +echo server >> foo.c +darcs rec -alm server +cd ../temp1 +echo client >> foo.c +darcs rec -alm client +not darcs push -a ../temp2 +cd .. +rm -rf temp1 temp2 diff --git a/tests/push_conflicts.sh b/tests/push_conflicts.sh deleted file mode 100644 --- a/tests/push_conflicts.sh +++ /dev/null @@ -1,59 +0,0 @@ -#!/usr/bin/env bash -## Test that apply --skip-conflicts filters the conflicts -## appropriately. -## -## Copyright (C) 2009 Ganesh Sittampalam -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -rm -rf R S # Another script may have left a mess. - -mkdir R -cd R -darcs init -echo 'foo' > foo -echo 'bar' > bar -darcs rec -lam 'Add foo and bar' -cd .. - -darcs get R S - -cd R -echo 'foo2' > foo -darcs rec -lam 'Change foo (2)' -echo 'bar2' > bar -darcs rec -lam 'Change bar (2)' -cd .. - -cd S -echo 'foo3' > foo -darcs rec -lam 'Change foo (3)' -cd .. - -cd R -darcs send -a ../S -o ../S/applyme.dpatch -cd .. - -cd S -darcs apply --skip-conflicts applyme.dpatch -test `darcs changes --count` -eq 3 -cd .. diff --git a/tests/push_lock.sh b/tests/push_lock.sh deleted file mode 100644 --- a/tests/push_lock.sh +++ /dev/null @@ -1,26 +0,0 @@ -#!/usr/bin/env bash - -# For issue257: push => incorrect return code when couldn't get lock - -. ./lib - -rm -rf tempc -mkdir tempc -cd tempc -darcs init -echo foo > foo.c -darcs rec -Ax -alm init -cd .. -rm -rf temps -darcs get tempc temps -cd temps -echo server >> foo.c -darcs rec -Ax -alm server -cd ../tempc -echo client >> foo.c -darcs rec -Ax -alm client -if darcs push -a ../temps; then - false -fi -cd .. -rm -rf tempc temps diff --git a/tests/query_manifest.sh b/tests/query_manifest.sh deleted file mode 100644 --- a/tests/query_manifest.sh +++ /dev/null @@ -1,91 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -check_manifest () { - : > files.tmp - echo . > dirs.tmp - echo . > files-dirs.tmp - for x in $1 ; do - echo "./$x" >> files.tmp - echo "./$x" >> files-dirs.tmp - done - for x in $2 ; do - echo "./$x" >> dirs.tmp - echo "./$x" >> files-dirs.tmp - done - darcs query manifest $3 --files --no-directories > darcsraw-files.tmp - darcs query manifest $3 --no-files --directories > darcsraw-dirs.tmp - darcs query manifest $3 --files --directories > darcsraw-files-dirs.tmp - for x in files dirs files-dirs ; do - sort $x.tmp | sed -e 's,\\,/,' > expected-$x.tmp - sort darcsraw-$x.tmp | sed -e 's,\\,/,' > darcs-$x.tmp - diff -u expected-$x.tmp darcs-$x.tmp - done } - -rm -rf temp -mkdir temp -cd temp -darcs init - -check_manifest "" "" "--no-pending" -check_manifest "" "" "--pending" -touch a b -darcs add a -check_manifest "" "" "--no-pending" -check_manifest "a" "" "--pending" -darcs add b -mkdir c -check_manifest "" "" "--no-pending" -check_manifest "a b" "" "--pending" -darcs add c -touch c/1 c/2 -check_manifest "" "" "--no-pending" -check_manifest "a b" "c" "--pending" -darcs add c/1 c/2 -check_manifest "" "" "--no-pending" -check_manifest "a b c/1 c/2" "c" "--pending" -mkdir d -touch d/3 d/4 -darcs add d/3 d/4 -check_manifest "" "" "--no-pending" -check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending" -darcs record -A test --all --name "patch 1" --skip-long-comment -check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" -check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending" - -darcs mv d e -check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" -check_manifest "a b c/1 c/2 e/3 e/4" "c e" "--pending" -rm c/1 -check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" -check_manifest "a b c/1 c/2 e/3 e/4" "c e" "--pending" -darcs remove c/1 -check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" -check_manifest "a b c/2 e/3 e/4" "c e" "--pending" -darcs mv c/2 c/1 -check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" -check_manifest "a b c/1 e/3 e/4" "c e" "--pending" -darcs record -A test --all --name "patch 2" --skip-long-comment -check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending" -check_manifest "a b c/1 e/3 e/4" "c e" "--pending" - -darcs remove c/1 -check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending" -check_manifest "a b e/3 e/4" "c e" "--pending" -darcs remove c -check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending" -check_manifest "a b e/3 e/4" "e" "--pending" -darcs record -A test --all --name "patch 3" --skip-long-comment -check_manifest "a b e/3 e/4" "e" "--no-pending" -check_manifest "a b e/3 e/4" "e" "--pending" - -darcs mv b b2 -darcs mv b2 b3 -check_manifest "a b e/3 e/4" "e" "--no-pending" -check_manifest "a b3 e/3 e/4" "e" "--pending" -darcs record -A test --all --name "patch 3" --skip-long-comment -check_manifest "a b3 e/3 e/4" "e" "--no-pending" -check_manifest "a b3 e/3 e/4" "e" "--pending" - -cd .. -rm -rf temp diff --git a/tests/rebase-nochanges.sh b/tests/rebase-nochanges.sh --- a/tests/rebase-nochanges.sh +++ b/tests/rebase-nochanges.sh @@ -54,6 +54,7 @@ * add wobble Making no changes: this is a dry run. +Rebase in progress: 1 suspended patches EOF darcs unpull --dry-run | tail -n+5 | grep -v tester | diff -u expected - diff --git a/tests/rebase-warns-lost-deps.sh b/tests/rebase-warns-lost-deps.sh new file mode 100644 --- /dev/null +++ b/tests/rebase-warns-lost-deps.sh @@ -0,0 +1,54 @@ +#!/usr/bin/env bash +## +## Check that lost explicit dependencies are reported on during rebase +## +## Copyright (C) 2015 Ganesh Sittampalam +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. + +rm -rf t1 +mkdir t1 +cd t1 +darcs init + +echo 'A' > A +darcs add A +darcs rec -am"patch A" --ignore-times + +echo 'B' > B +darcs add B +darcs rec -am"patch B" --ignore-times + +echo 'C' > C +darcs add C +echo 'yyy' | darcs rec -am"patch C" --ignore-times --ask-deps + +echo 'ydy' | darcs rebase suspend + +darcs unpull -a -p 'patch A' + +echo 'ydy' | darcs rebase unsuspend > unsuspend-output.txt + +grep "following explicit dependency" unsuspend-output.txt +grep "patch A" unsuspend-output.txt +not grep "patch B" unsuspend-output.txt diff --git a/tests/record-interactive.sh b/tests/record-interactive.sh deleted file mode 100644 --- a/tests/record-interactive.sh +++ /dev/null @@ -1,27 +0,0 @@ -#!/usr/bin/env bash - -. lib - - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init - -touch foo -darcs add foo -darcs record -a -m addfoo - -darcs replace one two foo -darcs replace three four foo -darcs replace five six foo - -echo sa | darcs record -m cancelled - -darcs whatsnew - -darcs changes > ch -not grep cancelled ch - -cd .. -rm -rf temp1 diff --git a/tests/record-misc.sh b/tests/record-misc.sh deleted file mode 100644 --- a/tests/record-misc.sh +++ /dev/null @@ -1,61 +0,0 @@ -#!/usr/bin/env bash - -# Some tests for 'darcs record ' - -. lib - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init - -# issue308 - no patches and no deps for record should abort -darcs record -am foo --ask-deps | grep -i "Ok, if you don't want to record anything, that's fine!" - -# RT#476 - --ask-deps works when there are no patches -if echo $OS | grep -i windows; then - echo This test does not work on Windows -else - touch t.f - darcs add t.f - darcs record -am add - echo a | darcs record -am foo --ask-deps | grep -i 'finished recording' -fi - -# RT#231 - special message is given for nonexistent directories -not darcs record -am foo not_there.txt > log -grep -i 'not exist' log - -# RT#231 - a nonexistent file before an existing file is handled correctly -touch b.t -darcs record -lam foo a.t b.t > log -grep -i 'WARNING:.*a.t' log -grep -iv 'WARNING:.*b.t' log - -DIR="`pwd`" -touch date.t -darcs add date.t -darcs record -a -m foo "$DIR/date.t" | grep -i 'finished recording' - -# issue396 - record -l "" -touch 'notnull.t' -darcs record -am foo -l "" notnull.t | grep -i 'finished recording' - -# basic record -date >> date.t -darcs record -a -m basic_record date.t | grep -i 'finished recording' - -# testing --logfile -date >> date.t -echo "second record\n" >> log.txt -darcs record -a -m 'second record' --logfile=log.txt date.t | grep -i 'finished recording' - -# refuse empty patch name -export DARCS_EDITOR="cat -n" -date >> date.t -echo "patchname" | darcs record -a -m "" | grep WARNING -date >> date.t -darcs record -a -m "some name" - -cd .. -rm -rf temp1 diff --git a/tests/record.sh b/tests/record.sh new file mode 100644 --- /dev/null +++ b/tests/record.sh @@ -0,0 +1,211 @@ +#!/usr/bin/env bash + +# Some tests for 'darcs record ' + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init + +# issue308 - no patches and no deps for record should abort +darcs record -am foo --ask-deps | grep -i "Ok, if you don't want to record anything, that's fine!" + +# RT#476 - --ask-deps works when there are no patches +if echo $OS | grep -i windows; then + echo This test does not work on Windows +else + touch t.f + darcs add t.f + darcs record -am add + echo a | darcs record -am foo --ask-deps | grep -i 'finished recording' +fi + +# RT#231 - special message is given for nonexistent directories +not darcs record -am foo not_there.txt > log 2>&1 +grep -i 'non-existing' log + +# RT#231 - a nonexistent file before an existing file is handled correctly +# test disabled, see tests/issue2494-output-of-record-with-file-arguments.sh +# which contains an updated test +# touch b.t +# darcs record -lam foo a.t b.t > log +# grep -i 'WARNING:.*a.t' log +# grep -iv 'WARNING:.*b.t' log + +DIR="`pwd`" +touch date.t +darcs add date.t +darcs record -a -m foo "$DIR/date.t" | grep -i 'finished recording' + +# issue396 - record -l "" +touch 'notnull.t' +darcs record -am foo -l "" notnull.t | grep -i 'finished recording' + +# basic record +date >> date.t +darcs record -a -m basic_record date.t | grep -i 'finished recording' + +# testing --logfile +date >> date.t +echo "second record\n" >> log.txt +darcs record -a -m 'second record' --logfile=log.txt date.t | grep -i 'finished recording' + +# refuse empty patch name +export DARCS_EDITOR="cat -n" +date >> date.t +echo "patchname" | darcs record -a -m "" | grep WARNING +date >> date.t +darcs record -a -m "some name" + +cd .. +rm -rf temp1 + + +# record race + +rm -rf foo1 foo2 +mkdir foo1 foo2 +cd foo1 +darcs init +echo zig > foo +darcs add foo +sleep 1 +darcs record -a -m add_foo -A x +#sleep 1 +echo zag >> foo +darcs record --ignore-time -a -m mod_foo -A x +cd ../foo2 +darcs init +darcs pull -a ../foo1 +cd .. +cmp foo1/foo foo2/foo +rm -rf foo1 foo2 + +# record interactive + + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init + +touch foo +darcs add foo +darcs record -a -m addfoo + +darcs replace one two foo +darcs replace three four foo +darcs replace five six foo + +echo sa | darcs record -m cancelled + +darcs whatsnew + +darcs changes > ch +not grep cancelled ch + +cd .. +rm -rf temp1 + + +# Some tests for 'darcs rec --edit-long-comment' + +rm -rf temp1 + +export DARCS_EDITOR="cat -n" +# editor: space in command +mkdir temp1 +cd temp1 +darcs init +touch file.t +darcs add file.t +echo y | darcs record --edit-long-comment -a -m foo file.t | grep '# Please enter' +cd .. +rm -rf temp1 + +# editor: space in path +mkdir temp2\ dir +cd temp2\ dir +darcs init +touch file.t +darcs add file.t +echo y | darcs record --edit-long-comment -a -m foo file.t | grep '# Please enter' +cd .. +rm -rf temp2\ dir + +# make sure summaries are coalesced +mkdir temp3 +cd temp3 +darcs init +cat > file < file < test-command << FOO +#!/bin/sh +echo EVIL +FOO +chmod u+x test-command +echo y | darcs record --logfile='; test-command' --edit-long-comment -a -m foo file.t > log +not grep EVIL log +cd .. +rm -rf temp1 + +## Test for issue142 - darcs record --logfile foo should not + +darcs init temp1 +cd temp1 +touch f g +touch log +darcs record -alm f --logfile log f +not darcs record -alm g --logfile missing g +cd .. +rm -rf temp1 + +## Test for issue1845 - darcs record f, for f a removed file should work +## Public domain - 2010 Petr Rockai + +darcs init temp1 +cd temp1 + +echo 'Example content.' > f +darcs rec -lam "first" +rm -f f +echo ny | darcs record f 2>&1 | tee log +not grep "None of the files" log +cd .. +rm -rf temp1 diff --git a/tests/record_editor.sh b/tests/record_editor.sh deleted file mode 100644 --- a/tests/record_editor.sh +++ /dev/null @@ -1,79 +0,0 @@ -#!/usr/bin/env bash - -# Some tests for 'darcs rec --edit-long-comment' - -. lib - -rm -rf temp1 - -export DARCS_EDITOR="cat -n" -# editor: space in command -mkdir temp1 -cd temp1 -darcs init -touch file.t -darcs add file.t -echo y | darcs record --edit-long-comment -a -m foo file.t | grep '# Please enter' -cd .. -rm -rf temp1 - -# editor: space in path -mkdir temp2\ dir -cd temp2\ dir -darcs init -touch file.t -darcs add file.t -echo y | darcs record --edit-long-comment -a -m foo file.t | grep '# Please enter' -cd .. -rm -rf temp2\ dir - -# make sure summaries are coalesced -mkdir temp3 -cd temp3 -darcs init -cat > file < file < test-command << FOO -#!/bin/sh -echo EVIL -FOO -chmod u+x test-command -echo y | darcs record --logfile='; test-command' --edit-long-comment -a -m foo file.t > log -not grep EVIL log -cd .. -rm -rf temp1 diff --git a/tests/recordrace.sh b/tests/recordrace.sh deleted file mode 100644 --- a/tests/recordrace.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf foo1 foo2 -mkdir foo1 foo2 -cd foo1 -darcs init -echo zig > foo -darcs add foo -sleep 1 -darcs record -a -m add_foo -A x -#sleep 1 -echo zag >> foo -darcs record --ignore-time -a -m mod_foo -A x -cd ../foo2 -darcs init -darcs pull -a ../foo1 -cd .. -cmp foo1/foo foo2/foo -rm -rf foo1 foo2 - diff --git a/tests/remove.sh b/tests/remove.sh --- a/tests/remove.sh +++ b/tests/remove.sh @@ -48,3 +48,17 @@ not grep -i d/f/1.txt after.lst cd .. +rm -rf temp1 + +# issue1765 recursive remove on root + +darcs init temp1 +cd temp1 + +mkdir d e # Change the working tree. +echo 'Example content.' > d/f +darcs record -lam 'Add d/f and e.' +darcs remove * -r + +cd .. +rm -rf temp1 diff --git a/tests/replace.sh b/tests/replace.sh --- a/tests/replace.sh +++ b/tests/replace.sh @@ -59,3 +59,36 @@ cd .. rm -rf temp + +# replace after pending add + +mkdir temp1 +cd temp1 +darcs init + +echo a b a b a b > A +darcs add A +if darcs replace a c A | grep Skipping; then + exit 1 +fi +cd .. + +rm -fr temp1 + +# replace after pending mv + +mkdir temp1 +cd temp1 +darcs init + +echo a b a b a b > A +darcs add A +darcs record --all --name=p1 +darcs mv A B +if darcs replace a c B | grep Skipping; then + exit 1 +fi +cd .. + +rm -fr temp1 + diff --git a/tests/replace_after_pending_add.sh b/tests/replace_after_pending_add.sh deleted file mode 100644 --- a/tests/replace_after_pending_add.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/env bash - -. ./lib - -rm -fr temp1 - -mkdir temp1 -cd temp1 -darcs --version - -darcs init - -echo a b a b a b > A -darcs add A -if darcs replace a c A | grep Skipping; then - exit 1 -fi -cd .. - -rm -fr temp1 - diff --git a/tests/replace_after_pending_mv.sh b/tests/replace_after_pending_mv.sh deleted file mode 100644 --- a/tests/replace_after_pending_mv.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/env bash - -. ./lib - -rm -fr temp1 - -mkdir temp1 -cd temp1 -darcs init - -echo a b a b a b > A -darcs add A -darcs record --all --name=p1 -darcs mv A B -if darcs replace a c B | grep Skipping; then - exit 1 -fi -cd .. - -rm -fr temp1 - diff --git a/tests/show_files.sh b/tests/show_files.sh new file mode 100644 --- /dev/null +++ b/tests/show_files.sh @@ -0,0 +1,91 @@ +#!/usr/bin/env bash +. ./lib + +check_manifest () { + : > files.tmp + echo . > dirs.tmp + echo . > files-dirs.tmp + for x in $1 ; do + echo "./$x" >> files.tmp + echo "./$x" >> files-dirs.tmp + done + for x in $2 ; do + echo "./$x" >> dirs.tmp + echo "./$x" >> files-dirs.tmp + done + darcs show files $3 --files --no-directories > darcsraw-files.tmp + darcs show files $3 --no-files --directories > darcsraw-dirs.tmp + darcs show files $3 --files --directories > darcsraw-files-dirs.tmp + for x in files dirs files-dirs ; do + sort $x.tmp | sed -e 's,\\,/,' > expected-$x.tmp + sort darcsraw-$x.tmp | sed -e 's,\\,/,' > darcs-$x.tmp + diff -u expected-$x.tmp darcs-$x.tmp + done } + +rm -rf temp +mkdir temp +cd temp +darcs init + +check_manifest "" "" "--no-pending" +check_manifest "" "" "--pending" +touch a b +darcs add a +check_manifest "" "" "--no-pending" +check_manifest "a" "" "--pending" +darcs add b +mkdir c +check_manifest "" "" "--no-pending" +check_manifest "a b" "" "--pending" +darcs add c +touch c/1 c/2 +check_manifest "" "" "--no-pending" +check_manifest "a b" "c" "--pending" +darcs add c/1 c/2 +check_manifest "" "" "--no-pending" +check_manifest "a b c/1 c/2" "c" "--pending" +mkdir d +touch d/3 d/4 +darcs add d/3 d/4 +check_manifest "" "" "--no-pending" +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending" +darcs record -A test --all --name "patch 1" --skip-long-comment +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending" + +darcs mv d e +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" +check_manifest "a b c/1 c/2 e/3 e/4" "c e" "--pending" +rm c/1 +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" +check_manifest "a b c/1 c/2 e/3 e/4" "c e" "--pending" +darcs remove c/1 +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" +check_manifest "a b c/2 e/3 e/4" "c e" "--pending" +darcs mv c/2 c/1 +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" +check_manifest "a b c/1 e/3 e/4" "c e" "--pending" +darcs record -A test --all --name "patch 2" --skip-long-comment +check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending" +check_manifest "a b c/1 e/3 e/4" "c e" "--pending" + +darcs remove c/1 +check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending" +check_manifest "a b e/3 e/4" "c e" "--pending" +darcs remove c +check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending" +check_manifest "a b e/3 e/4" "e" "--pending" +darcs record -A test --all --name "patch 3" --skip-long-comment +check_manifest "a b e/3 e/4" "e" "--no-pending" +check_manifest "a b e/3 e/4" "e" "--pending" + +darcs mv b b2 +darcs mv b2 b3 +check_manifest "a b e/3 e/4" "e" "--no-pending" +check_manifest "a b3 e/3 e/4" "e" "--pending" +darcs record -A test --all --name "patch 3" --skip-long-comment +check_manifest "a b3 e/3 e/4" "e" "--no-pending" +check_manifest "a b3 e/3 e/4" "e" "--pending" + +cd .. +rm -rf temp diff --git a/tests/show_tags-remote.sh b/tests/show_tags-remote.sh deleted file mode 100644 --- a/tests/show_tags-remote.sh +++ /dev/null @@ -1,46 +0,0 @@ -#!/usr/bin/env bash -## Test for show tags --repo -## -## Copyright (C) 2010 Eric Kow -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -darcs init --repo R # Create our test repos. -darcs init --repo S - -cd R -echo 'Example content.' > f -darcs record -lam 'Add f' -darcs tag 't0' -darcs tag 't1' -darcs show tags | grep t0 -cd .. -serve_http # sets baseurl - -cd S -darcs changes --repo ../R -darcs show tags --repo ../R | grep t0 -darcs show tags --repo $baseurl/R | grep t0 -cd .. - -darcs show tags --repo R | grep t0 -darcs show tags --repo $baseurl/R | grep t0 diff --git a/tests/tricky_unrecord.sh b/tests/tricky_unrecord.sh deleted file mode 100644 --- a/tests/tricky_unrecord.sh +++ /dev/null @@ -1,27 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf temp -mkdir temp -cd temp -darcs init -date > temp.c -darcs add temp.c -darcs record --all -A test --name=hi - -mkdir d -darcs add d -darcs mv temp.c d/ -darcs record --all -A test --name=mvetc -darcs show contents d/temp.c | cmp d/temp.c - - -echo y/d/y | tr / \\012 | darcs unrecord -darcs whatsnew -# darcs show contents d/temp.c | cmp d/temp.c - - -darcs record --all -A test --name=again -darcs show contents d/temp.c | cmp d/temp.c - - -cd .. -rm -rf temp - diff --git a/tests/unpull-formerly-pl.sh b/tests/unpull-formerly-pl.sh deleted file mode 100644 --- a/tests/unpull-formerly-pl.sh +++ /dev/null @@ -1,51 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf tempA -mkdir tempA -cd tempA -darcs initialize -echo hello world > foo -darcs add foo -darcs record -a -m hellofoo - -echo goodbye world >> foo -darcs record -a -m goodbyefoo - -darcs replace world bar foo -echo Hi there foo > bar -darcs add bar -darcs record -a -m addbar - -darcs mv bar baz -darcs replace bar baz foo -darcs record -a -m bar2baz - -echo Do not love the baz, or anything in the baz. >> foo -darcs record -a -m nolove - -darcs mv baz world -darcs replace baz world foo -darcs record -a -m baz2world - -not darcs whatsnew - -grep 'love the world' foo - -echo yy | darcs unpull -p baz2world - -not darcs whatsnew - -grep 'love the baz' foo - -echo yy | darcs unpull -p bar2baz - -grep 'love the bar' foo - -echo yy | darcs unpull -p nolove - -grep 'love' foo && exit 1 || true - -cd .. -rm -rf tempA - diff --git a/tests/unpull.sh b/tests/unpull.sh deleted file mode 100644 --- a/tests/unpull.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -cat > f < f < foo -darcs add foo -darcs whatsnew > correct -cat correct - -darcs record -a -m 'addfoo' - -darcs unrecord -a - -darcs whatsnew > unrecorded -cat unrecorded - -diff -u correct unrecorded - -cd .. -rm -rf temp1 diff --git a/tests/unrecord-dont-prompt.sh b/tests/unrecord-dont-prompt.sh deleted file mode 100644 --- a/tests/unrecord-dont-prompt.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/env bash - -. ./lib - -# Check that the right patches get unrecorded using --dont-prompt-for-dependencies - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -echo foo > f -darcs record -Ax -alm foo1 -echo bar > b -darcs rec -Ax -alm bar1 -echo foo2 > f -darcs record -Ax -alm foo2 -echo bar2 > b -darcs record -Ax -alm bar2 -darcs unrec --no-deps -p foo1 -darcs changes -p foo --count | grep 2 -#foo1 is depended upon, we don't unpull it -echo yy | darcs unrec --dont-prompt-for-dependencies -p foo1 -#on the previous line, we don't get asked about foo2. -darcs changes -p foo --count | grep 0 -#yet, it is unrecorded. -darcs changes -p bar --count | grep 2 -cd .. -rm -rf temp1 diff --git a/tests/unrecord-remove.sh b/tests/unrecord-remove.sh deleted file mode 100644 --- a/tests/unrecord-remove.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -echo foo > foo -darcs add foo - -darcs record -a -m 'addfoo' - -darcs remove foo - -darcs whatsnew > correct -cat correct - -darcs record -a -m 'rmfoo' - -darcs unrecord -a --last 1 - -darcs whatsnew > unrecorded -cat unrecorded - -diff -u correct unrecorded - -cd .. -rm -rf temp1 diff --git a/tests/unrecord-setpref.sh b/tests/unrecord-setpref.sh deleted file mode 100644 --- a/tests/unrecord-setpref.sh +++ /dev/null @@ -1,24 +0,0 @@ -#!/usr/bin/env bash -. ./lib - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init - -darcs setpref boringfile foobar - -darcs whatsnew > correct -cat correct - -darcs record -a -m 'boringfoobar' - -darcs unrecord -a - -darcs whatsnew > unrecorded -cat unrecorded - -diff -u correct unrecorded - -cd .. -rm -rf temp1 diff --git a/tests/unrecord.sh b/tests/unrecord.sh new file mode 100644 --- /dev/null +++ b/tests/unrecord.sh @@ -0,0 +1,126 @@ +#!/usr/bin/env bash +. ./lib + +# unrecord remove + +rm -rf temp1 +darcs init temp1 +cd temp1 + +echo foo > foo +darcs record -lam 'addfoo' +darcs remove foo +darcs whatsnew > correct +darcs record -a -m 'rmfoo' +darcs unrecord -a --last 1 +darcs whatsnew > unrecorded +diff -u correct unrecorded + +cd .. +rm -rf temp1 + +# unrecord setpref + +darcs init temp1 +cd temp1 + +darcs setpref boringfile foobar + +darcs whatsnew > correct +cat correct + +darcs record -a -m 'boringfoobar' +darcs unrecord -a + +darcs whatsnew > unrecorded +cat unrecorded + +diff -u correct unrecorded + +cd .. +rm -rf temp1 + +# unrecord add + +darcs init temp1 +cd temp1 + +echo foo > foo +darcs add foo +darcs whatsnew > correct +cat correct + +darcs record -a -m 'addfoo' + +darcs unrecord -a + +darcs whatsnew > unrecorded +cat unrecorded + +diff -u correct unrecorded + +cd .. +rm -rf temp1 + +# tricky unrecord + +darcs init temp1 +cd temp1 + +date > temp.c +darcs record -lam hi + +mkdir d +darcs add d +darcs mv temp.c d/ +darcs record -am mvetc +darcs show contents d/temp.c | cmp d/temp.c - + +echo y/d/y | tr / \\012 | darcs unrecord +darcs whatsnew + +darcs record -a -m again +darcs show contents d/temp.c | cmp d/temp.c - + +cd .. +rm -rf temp1 + +# Check that the right patches get unrecorded using --dont-prompt-for-dependencies + +darcs init temp1 +cd temp1 + +echo foo > f +darcs record -Ax -alm foo1 +echo bar > b +darcs rec -Ax -alm bar1 +echo foo2 > f +darcs record -Ax -alm foo2 +echo bar2 > b +darcs record -Ax -alm bar2 +darcs unrec --no-deps -p foo1 +darcs changes -p foo --count | grep 2 +#foo1 is depended upon, we don't unpull it +echo yy | darcs unrec --dont-prompt-for-dependencies -p foo1 +#on the previous line, we don't get asked about foo2. +darcs changes -p foo --count | grep 0 +#yet, it is unrecorded. +darcs changes -p bar --count | grep 2 +cd .. +rm -rf temp1 + + +# issue1012: rm/record/unrecord/record => inconsistent repository + +darcs init temp1 +cd temp1 + +echo temp1 >File.hs +darcs add File.hs +darcs record File.hs -a -m "add File" +rm File.hs +darcs record -a -m "rm File" +darcs unrecord -p "rm File" -a +darcs record -a -m "re-rm File" +cd .. +rm -rf temp1 diff --git a/tests/unrevert-add.sh b/tests/unrevert-add.sh deleted file mode 100644 --- a/tests/unrevert-add.sh +++ /dev/null @@ -1,26 +0,0 @@ -#!/usr/bin/env bash - -. lib - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -echo foo > foo -darcs add foo -darcs whatsnew > correct -cat correct - -darcs revert -a - -not darcs whatsnew - -darcs unrevert -a - -darcs whatsnew > unrecorded -cat unrecorded - -diff -u correct unrecorded - -cd .. -rm -rf temp1 diff --git a/tests/unrevert-replace-moved.sh b/tests/unrevert-replace-moved.sh deleted file mode 100644 --- a/tests/unrevert-replace-moved.sh +++ /dev/null @@ -1,36 +0,0 @@ -#!/usr/bin/env bash - -. lib - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -echo hello world > foo -darcs add foo - -darcs record -a -m 'addfoo' - -darcs replace hello goodbye foo - -darcs revert -a - -not darcs whatsnew - -darcs mv foo bar - -echo hello my good friends >> bar - -darcs unrevert -a - -darcs whatsnew > unrecorded -cat unrecorded - -grep 'bar .* hello goodbye' unrecorded - -cat bar -grep 'goodbye world' bar -grep 'goodbye my good friends' bar - -cd .. -rm -rf temp1 diff --git a/tests/unrevert.sh b/tests/unrevert.sh --- a/tests/unrevert.sh +++ b/tests/unrevert.sh @@ -2,12 +2,11 @@ . ./lib rm -rf temp1 -mkdir temp1 +darcs init temp1 cd temp1 -darcs init + echo hello world > foo -darcs add foo -darcs record -a -m add -A x +darcs record -lam add echo goodbye world >> foo cp foo bar darcs revert -a @@ -19,3 +18,117 @@ cd .. rm -rf temp1 +# unrevert replace moved + +darcs init temp1 +cd temp1 + +echo hello world > foo +darcs record -lam 'addfoo' +darcs replace hello goodbye foo +darcs revert -a + +not darcs whatsnew + +darcs mv foo bar + +echo hello my good friends >> bar + +darcs unrevert -a + +darcs whatsnew > unrecorded +cat unrecorded + +grep 'bar .* hello goodbye' unrecorded + +cat bar +grep 'goodbye world' bar +grep 'goodbye my good friends' bar + +cd .. +rm -rf temp1 + +# unrevert cancel +# From issue366 bug report + +darcs init temp1 +cd temp1 + +touch a b +darcs record -lam init +echo plim >> a +echo plim >> b +echo yyyy | darcs revert +echo ploum >> a +echo nyyy | darcs unrevert + +cd .. +rm -rf temp1 + +# unrevert add + +darcs init temp1 +cd temp1 + +echo foo > foo +darcs add foo +darcs whatsnew > correct +cat correct + +darcs revert -a + +not darcs whatsnew + +darcs unrevert -a + +darcs whatsnew > unrecorded +cat unrecorded + +diff -u correct unrecorded + +cd .. +rm -rf temp1 + +# double unrevert +# This demonstrates a bug that happens if you revert followed by +# a partial unrevert and a full unrevert. It requires that +# the second unrevert is working with patches who's contents need +# to be modified by the commute in the first unrevert. + +darcs init temp1 +cd temp1 + +echo line1 >> A +echo line2 >> A +echo line3 >> A +echo line4 >> A +echo line5 >> A +echo line6 >> A +darcs add A +darcs record -am A +sed 's/line2/Line2/' A > A1; rm A; mv A1 A +sed '4d' A > A1; rm A; mv A1 A +sed 's/line6/Line6/' A > A1; rm A; mv A1 A +darcs revert -a +echo nyny | darcs unrev +darcs unrev -a + +cd .. +rm -rf temp1 + +# impossible unrevert + +darcs init temp1 +cd temp1 + +echo ALL ignore-times > _darcs/prefs/defaults +echo a > foo +darcs record -lam aa +echo b > foo +echo yy | darcs revert -a +echo ydyy | darcs unrecord +# since the unrevert is impossible, we should fail if it succeeds... +echo yy | darcs unrevert && exit 1 || true + +cd .. +rm -rf temp1 diff --git a/tests/unrevert_cancel.sh b/tests/unrevert_cancel.sh deleted file mode 100644 --- a/tests/unrevert_cancel.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/usr/bin/env bash - -# From issue366 bug report - -. ./lib - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -touch a -touch b -darcs add * -darcs record -A moi -am init -echo plim >> a -echo plim >> b -echo yyyy | darcs revert -echo ploum >> a -echo nyyy | darcs unrevert - -cd .. -rm -rf temp1 diff --git a/tests/what_sl.sh b/tests/what_sl.sh deleted file mode 100644 --- a/tests/what_sl.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/env bash - -. ./lib - -rm -rf temp1 -mkdir temp1 -cd temp1 -darcs init -touch foo -darcs add foo -darcs rec -m t1 -a -A tester -echo 1 >> foo -darcs what -s | grep -v No\ changes -darcs what -l | grep -v No\ changes -darcs what -sl | grep -v No\ changes - -cd .. -rm -rf temp1 - diff --git a/tests/whatsnew-file.sh b/tests/whatsnew-file.sh deleted file mode 100644 --- a/tests/whatsnew-file.sh +++ /dev/null @@ -1,61 +0,0 @@ -#!/usr/bin/env bash - -. lib - -# Some tests for 'darcs whatsnew ' - -rm -rf temp1 - -mkdir temp1 -cd temp1 - -darcs init -date > foo -mkdir bar -echo hello world > bar/baz - -darcs record -la -m "add foo" - -echo goodbye world >> bar/baz - -# goodbye should show up precisely once - -darcs wh > out -cat out -grep goodbye out | wc -l | grep 1 - -darcs wh bar bar/baz > out -cat out -grep goodbye out | wc -l | grep 1 - -darcs mv foo bar -echo not date > bar/foo - -darcs wh bar bar/baz > out -cat out -grep date out | wc -l | grep 1 - -darcs wh foo > out -cat out -grep date out | wc -l | grep 1 - -darcs wh foo foo foo > out -cat out -grep date out | wc -l | grep 1 - -darcs wh foo ./foo ../temp1/foo > out -cat out -grep date out | wc -l | grep 1 - -darcs wh foo bar/../foo > out -cat out -grep date out | wc -l | grep 1 - -# This one fails actually, but it's not my fault. Filed as issue1196. -#darcs wh foo foo/../foo/. > out -#cat out -#grep date out | wc -l | grep 1 - -cd .. - -rm -rf temp1 diff --git a/tests/whatsnew-interactive.sh b/tests/whatsnew-interactive.sh deleted file mode 100644 --- a/tests/whatsnew-interactive.sh +++ /dev/null @@ -1,46 +0,0 @@ -#!/usr/bin/env bash -## -## This tests the basic fascilities of `whatsnew --interactive` -## -## Copyright (C) 2014 Daniil Frumin -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib - -rm -rf wn-i - -darcs init --repo wn-i -cd wn-i - -echo lolz > foo -darcs add foo - -echo n | darcs whatsnew -i > what -grep "Will not ask whether to view 1" what -rm what - -echo yxgq | darcs whatsnew -i > what2 -grep "M ./foo +1" what2 -addfileCount=`grep -c "addfile" what2` -if [ "$addfileCount" -ne 3 ]; then - exit 1 -fi; diff --git a/tests/whatsnew-pending.sh b/tests/whatsnew-pending.sh deleted file mode 100644 --- a/tests/whatsnew-pending.sh +++ /dev/null @@ -1,38 +0,0 @@ -#!/usr/bin/env bash -## Ensure that darcs whatsnew only lists relevant bits. -## Public Domain, 2010, Petr Rockai -## -## This file is included as part of the Darcs test distribution, -## which is licensed to you under the following terms: -## -## Permission is hereby granted, free of charge, to any person -## obtaining a copy of this software and associated documentation -## files (the "Software"), to deal in the Software without -## restriction, including without limitation the rights to use, copy, -## modify, merge, publish, distribute, sublicense, and/or sell copies -## of the Software, and to permit persons to whom the Software is -## furnished to do so, subject to the following conditions: -## -## The above copyright notice and this permission notice shall be -## included in all copies or substantial portions of the Software. -## -## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -## SOFTWARE. - -. lib # Load some portability helpers. -rm -rf R # Another script may have left a mess. -darcs init --repo R # Create our test repos. - -cd R -mkdir d e # Change the working tree. -echo 'Example content.' > d/f -darcs record -lam 'Add d/f and e.' -darcs remove d/f -not darcs wh e # | not grep f -cd .. diff --git a/tests/whatsnew.sh b/tests/whatsnew.sh --- a/tests/whatsnew.sh +++ b/tests/whatsnew.sh @@ -4,7 +4,7 @@ # Some tests for 'darcs whatsnew ' -rm -rf temp1 temp2 +rm -rf temp1 mkdir temp1 cd temp1 @@ -51,3 +51,116 @@ cd .. rm -rf temp1 + + +## Part 2 +## This tests the basic fascilities of `whatsnew --interactive` +## Copyright (C) 2014 Daniil Frumin + +rm -rf wn-i + +darcs init --repo wn-i +cd wn-i + +echo lolz > foo +darcs add foo + +echo n | darcs whatsnew -i > what +grep "Will not ask whether to view 1" what +rm what + +echo yxgq | darcs whatsnew -i > what2 +grep "M ./foo +1" what2 +addfileCount=`grep -c "addfile" what2` +if [ "$addfileCount" -ne 3 ]; then + exit 1 +fi; +cd .. + +## Part 3 +## Ensure that darcs whatsnew only lists relevant bits. +## Public Domain, 2010, Petr Rockai + +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repos. + +cd R +mkdir d e # Change the working tree. +echo 'Example content.' > d/f +darcs record -lam 'Add d/f and e.' +darcs remove d/f +not darcs wh e # | not grep f +cd .. + +## Part 4 +# Some tests for 'darcs whatsnew ' + +rm -rf temp1 + +darcs init temp1 +cd temp1 + +date > foo +mkdir bar +echo hello world > bar/baz + +darcs record -la -m "add foo" + +echo goodbye world >> bar/baz + +# goodbye should show up precisely once + +darcs wh > out +cat out +grep goodbye out | wc -l | grep 1 + +darcs wh bar bar/baz > out +cat out +grep goodbye out | wc -l | grep 1 + +darcs mv foo bar +echo not date > bar/foo + +darcs wh bar bar/baz > out +cat out +grep date out | wc -l | grep 1 + +darcs wh foo > out +cat out +grep date out | wc -l | grep 1 + +darcs wh foo foo foo > out +cat out +grep date out | wc -l | grep 1 + +darcs wh foo ./foo ../temp1/foo > out +cat out +grep date out | wc -l | grep 1 + +darcs wh foo bar/../foo > out +cat out +grep date out | wc -l | grep 1 + +# This one fails actually, but it's not my fault. Filed as issue1196. +#darcs wh foo foo/../foo/. > out +#cat out +#grep date out | wc -l | grep 1 + +cd .. +rm -rf temp1 + +## Part 5 + +darcs init temp1 +cd temp1 +touch foo +darcs add foo +darcs rec -m t1 -a -A tester +echo 1 >> foo +darcs what -s | grep -v No\ changes +darcs what -l | grep -v No\ changes +darcs what -sl | grep -v No\ changes + +cd .. +rm -rf temp1 +