packages feed

darcs 2.10.3 → 2.12.0

raw patch · 471 files changed

+16324/−21971 lines, 471 filesdep +asyncdep +fgldep +graphvizdep −deepseqdep −lcsdep ~HTTPdep ~HUnitdep ~QuickChecksetup-changedbinary-added

Dependencies added: async, fgl, graphviz

Dependencies removed: deepseq, lcs

Dependency ranges changed: HTTP, HUnit, QuickCheck, Win32, array, base, binary, bytestring, containers, cryptohash, directory, filepath, hashable, html, mmap, mtl, network, old-locale, process, random, sandi, split, test-framework, test-framework-hunit, test-framework-quickcheck2, time, unix, unix-compat, vector, zip-archive, zlib

Files

CHANGELOG view
@@ -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"
README.md view
@@ -46,3 +46,12 @@  Please send bug reports to <bugs@darcs.net>. +Hacking+=======++Please consult <http://darcs.net/Development/GettingStarted> 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
Setup.lhs view
@@ -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 )
− containers-0.5.2.1/Darcs/Data/Map/Base.hs 
@@ -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,---     <http://www.swiss.ai.mit.edu/~adams/BB/>.------    * 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 <http://en.wikipedia.org/wiki/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) l && bounded (>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 #-}
− containers-0.5.2.1/Darcs/Data/Map/Strict.hs 
@@ -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,---     <http://www.swiss.ai.mit.edu/~adams/BB/>.------    * 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 (<http://en.wikipedia.org/wiki/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)
− containers-0.5.2.1/Darcs/Data/Set/Base.hs 
@@ -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,---      <http://www.swiss.ai.mit.edu/~adams/BB/>.------    * 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) l && bounded (>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
− containers-0.5.2.1/Darcs/Data/StrictPair.hs 
@@ -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 #-}
contrib/darcs-errors.hlint view
@@ -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
+ contrib/runHLint.sh view
@@ -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
darcs.cabal view
@@ -1,5 +1,5 @@ Name:           darcs-version:        2.10.3+version:        2.12.0 License:        GPL License-file:   COPYING Author:         David Roundy <droundy@darcs.net>, <darcs-devel@darcs.net>@@ -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
harness/Darcs/Test/Patch.hs view
@@ -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             ]
harness/Darcs/Test/Patch/Arbitrary/Generic.hs view
@@ -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
− harness/Darcs/Test/Patch/Arbitrary/PatchV1.hs 
@@ -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-
+ harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs view
@@ -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
harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs view
@@ -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 )
− harness/Darcs/Test/Patch/Arbitrary/PrimV3.hs 
@@ -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
− harness/Darcs/Test/Patch/Arbitrary/Real.hs 
@@ -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'))
+ harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs view
@@ -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+
+ harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs view
@@ -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'))
harness/Darcs/Test/Patch/Examples/Set1.hs view
@@ -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 :: [((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)  -- ----------------------------------------------------------------------
harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs view
@@ -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)
+ harness/Darcs/Test/Patch/FileUUIDModel.hs view
@@ -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
harness/Darcs/Test/Patch/Properties/Check.hs view
@@ -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
harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs view
@@ -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
− harness/Darcs/Test/Patch/Properties/Real.hs 
@@ -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)-
+ harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs view
@@ -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)+
harness/Darcs/Test/Patch/Properties/V1Set1.hs view
@@ -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:<p2,p2':<p1') =-   case commute (p2:>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:<p2) =-    case commute (p2:>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"
harness/Darcs/Test/Patch/Properties/V1Set2.hs view
@@ -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':<p2') ->-                  case runWrappedCommuteFunction c (invert p2:< p1') of-                  Succeeded (p1'':<ip2x') -> 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':<p2') ->-                  case runWrappedCommuteFunction c (invert p2:< p1') of-                  Succeeded (p1'':<ip2x') -> 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:<p1)) && checkAPatch (p1 :>: 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:<p1)) && checkAPatch (p1 :>: 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:<p1)) && checkAPatch (p1 :>: 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
harness/Darcs/Test/Patch/Rebase.hs view
@@ -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) $
+ harness/Darcs/Test/Patch/Selection.hs view
@@ -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 ()+
harness/Darcs/Test/Patch/V1Model.hs view
@@ -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
− harness/Darcs/Test/Patch/V3Model.hs 
@@ -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
harness/Darcs/Test/Patch/WSub.hs view
@@ -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)
harness/Darcs/Test/Util/QuickCheck.hs view
@@ -11,7 +11,9 @@   where  -import Control.Applicative+import Prelude ()+import Darcs.Prelude+ import Test.QuickCheck.Gen
+ harness/Storage/Hashed/Test.hs view
@@ -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+
+ harness/hstestdata.zip view

binary file changed (absent → 16669 bytes)

harness/test.hs view
@@ -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
− hashed-storage/Bundled/Posix.hsc 
@@ -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 <sys/stat.h>---- 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 #-}
− hashed-storage/LICENSE 
@@ -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.
− hashed-storage/Storage/Hashed.hs 
@@ -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' ]-
− hashed-storage/Storage/Hashed/AnchoredPath.hs 
@@ -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
− hashed-storage/Storage/Hashed/Darcs.hs 
@@ -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')
− hashed-storage/Storage/Hashed/Diff.hs 
@@ -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 ]
− hashed-storage/Storage/Hashed/Hash.hs 
@@ -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
− hashed-storage/Storage/Hashed/Index.hs 
@@ -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
− hashed-storage/Storage/Hashed/Monad.hs 
@@ -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
− hashed-storage/Storage/Hashed/Packed.hs 
@@ -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)
− hashed-storage/Storage/Hashed/Plain.hs 
@@ -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-
− hashed-storage/Storage/Hashed/Test.hs 
@@ -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!"
− hashed-storage/Storage/Hashed/Tree.hs 
@@ -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-
− hashed-storage/Storage/Hashed/Utils.hs 
@@ -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)
− hashed-storage/test.hs 
@@ -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
− hashed-storage/testdata.zip

binary file changed (16669 → absent bytes)

release/distributed-context view
@@ -1,1 +1,1 @@-Just "\nContext:\n\n[TAG 2.10.3\nGuillaume Hoffmann <guillaumh@gmail.com>**20160129115730\n Ignore-this: 7eac9bf53015a285c43e6ea2b1e11a1d\n] \n"+Just "\nContext:\n\n[TAG 2.12.0\nGuillaume Hoffmann <guillaumh@gmail.com>**20160429142058\n Ignore-this: 5c8cbe0424942686a2168f9e6fd8e35d\n] \n"
+ src/Bundled/Posix.hsc view
@@ -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 <sys/stat.h>++-- 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 #-}
src/Darcs/Patch.hs view
@@ -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)
src/Darcs/Patch/Annotate.hs view
@@ -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
src/Darcs/Patch/Apply.hs view
@@ -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
src/Darcs/Patch/ApplyMonad.hs view
@@ -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
src/Darcs/Patch/ApplyPatches.hs view
@@ -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)
src/Darcs/Patch/Bracketed.hs view
@@ -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 )
src/Darcs/Patch/Bracketed/Instances.hs view
@@ -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
src/Darcs/Patch/Bundle.hs view
@@ -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'
src/Darcs/Patch/Choices.hs view
@@ -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
src/Darcs/Patch/Commute.hs view
@@ -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
src/Darcs/Patch/CommuteFn.hs view
@@ -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
src/Darcs/Patch/Conflict.hs view
@@ -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 ""
− src/Darcs/Patch/ConflictMarking.hs 
@@ -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 ""-
src/Darcs/Patch/Depends.hs view
@@ -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)
src/Darcs/Patch/Dummy.hs view
@@ -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
src/Darcs/Patch/Effect.hs view
@@ -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
src/Darcs/Patch/FileHunk.hs view
@@ -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 )
src/Darcs/Patch/Index/Monad.hs view
@@ -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 ()
src/Darcs/Patch/Index/Types.hs view
@@ -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 )
src/Darcs/Patch/Info.hs view
@@ -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 )
src/Darcs/Patch/Inspect.hs view
@@ -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
src/Darcs/Patch/Invert.hs view
@@ -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
src/Darcs/Patch/Match.hs view
@@ -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
src/Darcs/Patch/Matchable.hs view
@@ -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
− src/Darcs/Patch/MaybeInternal.hs 
@@ -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
src/Darcs/Patch/Merge.hs view
@@ -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''
src/Darcs/Patch/MonadProgress.hs view
@@ -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
src/Darcs/Patch/Named.hs view
@@ -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
+ src/Darcs/Patch/Named/Wrapped.hs view
@@ -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 <invalid@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)
src/Darcs/Patch/OldDate.hs view
@@ -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 )
src/Darcs/Patch/PatchInfoAnd.hs view
@@ -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: -- \<description of the 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)
src/Darcs/Patch/Permutations.hs view
@@ -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
src/Darcs/Patch/Prim/Class.hs view
@@ -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 ()
+ src/Darcs/Patch/Prim/FileUUID.hs view
@@ -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
+ src/Darcs/Patch/Prim/FileUUID/Apply.hs view
@@ -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+
+ src/Darcs/Patch/Prim/FileUUID/Coalesce.hs view
@@ -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
+ src/Darcs/Patch/Prim/FileUUID/Commute.hs view
@@ -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
+ src/Darcs/Patch/Prim/FileUUID/Core.hs view
@@ -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
+ src/Darcs/Patch/Prim/FileUUID/Details.hs view
@@ -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 _ = []
+ src/Darcs/Patch/Prim/FileUUID/ObjectMap.hs view
@@ -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]+                                         }
+ src/Darcs/Patch/Prim/FileUUID/Read.hs view
@@ -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+
+ src/Darcs/Patch/Prim/FileUUID/Show.hs view
@@ -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+
src/Darcs/Patch/Prim/V1.hs view
@@ -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 ()
src/Darcs/Patch/Prim/V1/Apply.hs view
@@ -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
src/Darcs/Patch/Prim/V1/Coalesce.hs view
@@ -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
src/Darcs/Patch/Prim/V1/Commute.hs view
@@ -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+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 :<p1) = Succeeded (unsafeCoerceP p1 :< ChangePref p f t)-    eec (p2 :<ChangePref p f t) = Succeeded (ChangePref p f t :< unsafeCoerceP p2)-    eec xx = cleverCommute commuteFiledir                xx+    eec (p1 :> 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
src/Darcs/Patch/Prim/V1/Core.hs view
@@ -26,6 +26,9 @@        )        where +import Prelude ()+import Darcs.Prelude+ import Prelude hiding ( pi )  import qualified Data.ByteString as B (ByteString)
src/Darcs/Patch/Prim/V1/Details.hs view
@@ -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(..) )
src/Darcs/Patch/Prim/V1/Read.hs view
@@ -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(..),
src/Darcs/Patch/Prim/V1/Show.hs view
@@ -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
− src/Darcs/Patch/Prim/V3.hs 
@@ -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
− src/Darcs/Patch/Prim/V3/Apply.hs 
@@ -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-
− src/Darcs/Patch/Prim/V3/Coalesce.hs 
@@ -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
− src/Darcs/Patch/Prim/V3/Commute.hs 
@@ -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
− src/Darcs/Patch/Prim/V3/Core.hs 
@@ -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
− src/Darcs/Patch/Prim/V3/Details.hs 
@@ -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 _ = []
− src/Darcs/Patch/Prim/V3/ObjectMap.hs 
@@ -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]-                                         }
− src/Darcs/Patch/Prim/V3/Read.hs 
@@ -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-
− src/Darcs/Patch/Prim/V3/Show.hs 
@@ -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-
src/Darcs/Patch/Progress.hs view
@@ -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
src/Darcs/Patch/Read.hs view
@@ -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 )
src/Darcs/Patch/ReadMonads.hs view
@@ -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(..) )
src/Darcs/Patch/Rebase.hs view
@@ -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 <invalid@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)
+ src/Darcs/Patch/Rebase/Container.hs view
@@ -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)
src/Darcs/Patch/Rebase/Fixup.hs view
@@ -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) =
+ src/Darcs/Patch/Rebase/Item.hs view
@@ -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
src/Darcs/Patch/Rebase/Name.hs view
@@ -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
− src/Darcs/Patch/Rebase/NameHack.hs 
@@ -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-
− src/Darcs/Patch/Rebase/Recontext.hs 
@@ -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
src/Darcs/Patch/Rebase/Viewing.hs view
@@ -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
src/Darcs/Patch/RegChars.hs view
@@ -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
src/Darcs/Patch/Repair.hs view
@@ -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)
src/Darcs/Patch/RepoPatch.hs view
@@ -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
+ src/Darcs/Patch/RepoType.hs view
@@ -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
src/Darcs/Patch/Set.hs view
@@ -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
src/Darcs/Patch/Show.hs view
@@ -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
src/Darcs/Patch/Split.hs view
@@ -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 }
src/Darcs/Patch/Summary.hs view
@@ -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
src/Darcs/Patch/SummaryData.hs view
@@ -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
src/Darcs/Patch/TokenReplace.hs view
@@ -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"
src/Darcs/Patch/TouchesFiles.hs view
@@ -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]
src/Darcs/Patch/Type.hs view
@@ -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
src/Darcs/Patch/V1.hs view
@@ -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)
src/Darcs/Patch/V1/Apply.hs view
@@ -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
src/Darcs/Patch/V1/Commute.hs view
@@ -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+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:<p) of-              Just (p'@(Merger _ _ p1 p2):<_) ->+          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 &&
src/Darcs/Patch/V1/Core.hs view
@@ -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)
src/Darcs/Patch/V1/Read.hs view
@@ -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 '('
src/Darcs/Patch/V1/Show.hs view
@@ -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
src/Darcs/Patch/V1/Viewing.hs view
@@ -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
src/Darcs/Patch/V2.hs view
@@ -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)
src/Darcs/Patch/V2/Non.hs view
@@ -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
− src/Darcs/Patch/V2/Real.hs 
@@ -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
+ src/Darcs/Patch/V2/RepoPatch.hs view
@@ -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
src/Darcs/Patch/Viewing.hs view
@@ -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
src/Darcs/Patch/Witnesses/Eq.hs view
@@ -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
src/Darcs/Patch/Witnesses/Ordered.hs view
@@ -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':<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
src/Darcs/Patch/Witnesses/Sealed.hs view
@@ -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 ( (=\/=) )
src/Darcs/Patch/Witnesses/Show.hs view
@@ -15,6 +15,9 @@     , appPrec     ) where +import Prelude ()+import Darcs.Prelude+ import Darcs.Util.Show ( appPrec )  data ShowDict a where
src/Darcs/Patch/Witnesses/WZipper.hs view
@@ -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
+ src/Darcs/Prelude.hs view
@@ -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 )
src/Darcs/Repository.hs view
@@ -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
src/Darcs/Repository/ApplyPatches.hs view
@@ -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
src/Darcs/Repository/Cache.hs view
@@ -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)
+ src/Darcs/Repository/Clone.hs view
@@ -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
− src/Darcs/Repository/Compat.hs 
@@ -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
src/Darcs/Repository/Diff.hs view
@@ -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
− src/Darcs/Repository/External.hs 
@@ -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."-    ])--
src/Darcs/Repository/Flags.hs view
@@ -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 )
src/Darcs/Repository/Format.hs view
@@ -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
src/Darcs/Repository/HashedIO.hs view
@@ -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
src/Darcs/Repository/HashedRepo.hs view
@@ -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)
src/Darcs/Repository/Internal.hs view
@@ -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
src/Darcs/Repository/InternalTypes.hs view
@@ -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)
src/Darcs/Repository/Job.hs view
@@ -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
− src/Darcs/Repository/Lock.hs 
@@ -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
− src/Darcs/Repository/LowLevel.hs 
@@ -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"
src/Darcs/Repository/Match.hs view
@@ -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
src/Darcs/Repository/Merge.hs view
@@ -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
src/Darcs/Repository/Motd.hs view
@@ -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 )
src/Darcs/Repository/Old.hs view
@@ -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)
+ src/Darcs/Repository/Packs.hs view
@@ -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
src/Darcs/Repository/PatchIndex.hs view
@@ -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
+ src/Darcs/Repository/Pending.hs view
@@ -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"
src/Darcs/Repository/Prefs.hs view
@@ -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,
− src/Darcs/Repository/Read.hs 
@@ -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
src/Darcs/Repository/Rebase.hs view
@@ -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'
src/Darcs/Repository/Repair.hs view
@@ -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
src/Darcs/Repository/Resolution.hs view
@@ -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
− src/Darcs/Repository/Ssh.hs 
@@ -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."])
src/Darcs/Repository/State.hs view
@@ -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
src/Darcs/Repository/Test.hs view
@@ -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
− src/Darcs/Repository/Util.hs 
@@ -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)
src/Darcs/UI/ApplyPatches.hs view
@@ -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)
src/Darcs/UI/Commands.hs view
@@ -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)
src/Darcs/UI/Commands/Add.hs view
@@ -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
src/Darcs/UI/Commands/Amend.hs view
@@ -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
src/Darcs/UI/Commands/Annotate.hs view
@@ -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"
src/Darcs/UI/Commands/Apply.hs view
@@ -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
src/Darcs/UI/Commands/Clone.hs view
@@ -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
src/Darcs/UI/Commands/Convert.hs view
@@ -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@home> -> john <john@home> -- john <john@home  -> john <john@home> -- <john>           -> john <unknown>-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...
src/Darcs/UI/Commands/Diff.hs view
@@ -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
src/Darcs/UI/Commands/Dist.hs view
@@ -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
src/Darcs/UI/Commands/GZCRCs.hs view
@@ -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
src/Darcs/UI/Commands/Help.hs view
@@ -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])
src/Darcs/UI/Commands/Init.hs view
@@ -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."
src/Darcs/UI/Commands/Log.hs view
@@ -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 "<changelog>"       $$ 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
src/Darcs/UI/Commands/MarkConflicts.hs view
@@ -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"++
src/Darcs/UI/Commands/Move.hs view
@@ -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
src/Darcs/UI/Commands/Optimize.hs view
@@ -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)
src/Darcs/UI/Commands/Pull.hs view
@@ -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
src/Darcs/UI/Commands/Push.hs view
@@ -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 []
src/Darcs/UI/Commands/Rebase.hs view
@@ -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)
src/Darcs/UI/Commands/Record.hs view
@@ -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
src/Darcs/UI/Commands/Remove.hs view
@@ -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
src/Darcs/UI/Commands/Repair.hs view
@@ -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 <-
src/Darcs/UI/Commands/Replace.hs view
@@ -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\\-\\."
src/Darcs/UI/Commands/Revert.hs view
@@ -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."
src/Darcs/UI/Commands/Rollback.hs view
@@ -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"
src/Darcs/UI/Commands/Send.hs view
@@ -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
src/Darcs/UI/Commands/SetPref.hs view
@@ -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)
src/Darcs/UI/Commands/Show.hs view
@@ -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-}
src/Darcs/UI/Commands/ShowAuthors.hs view
@@ -19,6 +19,9 @@     ( showAuthors, Spelling, compiledAuthorSpellings, canonizeAuthor, rankAuthors     ) where +import Prelude ()+import Darcs.Prelude+ import Prelude hiding ( (^), catch )  import Control.Arrow ( (&&&), (***) )
src/Darcs/UI/Commands/ShowBug.hs view
@@ -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 )
src/Darcs/UI/Commands/ShowContents.hs view
@@ -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
+ src/Darcs/UI/Commands/ShowDependencies.hs view
@@ -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
src/Darcs/UI/Commands/ShowFiles.hs view
@@ -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 "."-
src/Darcs/UI/Commands/ShowIndex.hs view
@@ -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 )
src/Darcs/UI/Commands/ShowPatchIndex.hs view
@@ -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
src/Darcs/UI/Commands/ShowRepo.hs view
@@ -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 "<repository>\n")          when (Verbose `elem` opts) (out "Show" $ show r)@@ -145,8 +151,8 @@          showRepoMOTD out r          when (XMLOutput `elem` opts) (putStr "</repository>\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
src/Darcs/UI/Commands/ShowTags.hs view
@@ -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
src/Darcs/UI/Commands/Tag.hs view
@@ -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
src/Darcs/UI/Commands/Test.hs view
@@ -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
src/Darcs/UI/Commands/TransferMode.hs view
@@ -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)-
src/Darcs/UI/Commands/Unrecord.hs view
@@ -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
src/Darcs/UI/Commands/Unrevert.hs view
@@ -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!"
src/Darcs/UI/Commands/Util.hs view
@@ -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
src/Darcs/UI/Commands/Util/Tree.hs view
@@ -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
src/Darcs/UI/Commands/WhatsNew.hs view
@@ -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@
src/Darcs/UI/CommandsAux.hs view
@@ -24,6 +24,9 @@     , hasMaliciousPath     ) where +import Prelude ()+import Darcs.Prelude+ import Control.Monad ( when )  import Darcs.UI.Flags ( DarcsFlag )
src/Darcs/UI/Defaults.hs view
@@ -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 )
src/Darcs/UI/Email.hs view
@@ -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
src/Darcs/UI/External.hs view
@@ -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)
src/Darcs/UI/Flags.hs view
@@ -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)
src/Darcs/UI/Message/Send.hs view
@@ -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!"
src/Darcs/UI/Options.hs view
@@ -7,6 +7,9 @@     , optDescr     ) where +import Prelude ()+import Darcs.Prelude+ import Data.Functor.Compose import System.Console.GetOpt
src/Darcs/UI/Options/All.hs view
@@ -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" ]
src/Darcs/UI/Options/Core.hs view
@@ -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
src/Darcs/UI/Options/Flags.hs view
@@ -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
src/Darcs/UI/Options/Iso.hs view
@@ -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
src/Darcs/UI/Options/Markdown.hs view
@@ -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 )
src/Darcs/UI/Options/Matching.hs view
@@ -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
src/Darcs/UI/Options/Util.hs view
@@ -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 )
+ src/Darcs/UI/PatchHeader.hs view
@@ -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
src/Darcs/UI/PrintPatch.hs view
@@ -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 )
− src/Darcs/UI/RemoteApply.hs 
@@ -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 []
src/Darcs/UI/RunCommand.hs view
@@ -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
src/Darcs/UI/SelectChanges.hs view
@@ -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 {-
src/Darcs/UI/TheCommands.hs view
@@ -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     ]
src/Darcs/UI/Usage.hs view
@@ -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 )
src/Darcs/Util/AtExit.hs view
@@ -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 []))
src/Darcs/Util/Bug.hs view
@@ -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, ($$) )
src/Darcs/Util/ByteString.hs view
@@ -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
src/Darcs/Util/CommandLine.hs view
@@ -56,6 +56,9 @@     , addUrlencoded     ) where +import Prelude ()+import Darcs.Prelude+ import Control.Arrow ( (***) ) import Data.Char ( ord, intToDigit, toUpper ) import Data.List ( find )
+ src/Darcs/Util/Compat.hs view
@@ -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
src/Darcs/Util/Crypt/SHA1.hs view
@@ -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(..) )
src/Darcs/Util/Crypt/SHA256.hs view
@@ -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 )
src/Darcs/Util/DateMatcher.hs view
@@ -33,6 +33,9 @@     , getMatchers     ) where +import Prelude ()+import Darcs.Prelude+ import Control.Exception ( catchJust ) import Data.Maybe ( isJust )
src/Darcs/Util/DateTime.hs view
@@ -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)
src/Darcs/Util/Diff.hs view
@@ -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 )
src/Darcs/Util/Diff/Myers.hs view
@@ -60,6 +60,9 @@     , getSlice     ) where +import Prelude ()+import Darcs.Prelude+ import Control.Monad import Data.Int import Control.Monad.ST
src/Darcs/Util/Diff/Patience.hs view
@@ -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
src/Darcs/Util/Download.hs view
@@ -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,
src/Darcs/Util/Download/Curl.hs view
@@ -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 )
src/Darcs/Util/Download/HTTP.hs view
@@ -4,7 +4,8 @@     ( fetchUrl, postUrl, requestUrl, waitNextUrl     ) where -import Prelude hiding ( catch )+import Prelude ()+import Darcs.Prelude  import Darcs.Util.Global ( debugFail )
src/Darcs/Util/Download/Request.hs view
@@ -15,6 +15,9 @@     , ConnectionError(..)     ) where +import Prelude ()+import Darcs.Prelude+ import Data.List ( delete ) import Data.Map ( Map ) import Foreign.C.Types ( CInt )
src/Darcs/Util/Encoding.hs view
@@ -26,6 +26,9 @@     ( encode,decode     ) where +import Prelude ()+import Darcs.Prelude+ import Data.ByteString ( ByteString )  #ifdef WIN32
src/Darcs/Util/Encoding/Win32.hs view
@@ -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 )
src/Darcs/Util/English.hs view
@@ -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
src/Darcs/Util/Environment.hs view
@@ -3,8 +3,8 @@       maybeGetEnv     ) where --import Prelude hiding ( catch )+import Prelude ()+import Darcs.Prelude  import System.Environment ( getEnv )
src/Darcs/Util/Exception.hs view
@@ -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
src/Darcs/Util/Exec.hs view
@@ -37,6 +37,9 @@     , ExecException(..)     ) where +import Prelude ()+import Darcs.Prelude+ #ifndef WIN32 import Control.Exception ( bracket ) import System.Posix.Env ( setEnv, getEnv, unsetEnv )
+ src/Darcs/Util/External.hs view
@@ -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++
src/Darcs/Util/File.hs view
@@ -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 )
src/Darcs/Util/Global.hs view
@@ -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"
+ src/Darcs/Util/Hash.hs view
@@ -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
+ src/Darcs/Util/Index.hs view
@@ -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+
src/Darcs/Util/IsoDate.hs view
@@ -36,6 +36,9 @@     , unsetTime, TimeInterval     ) where +import Prelude ( (^) )+import Darcs.Prelude+ import Text.ParserCombinators.Parsec import System.Time import System.IO.Unsafe ( unsafePerformIO )
+ src/Darcs/Util/Lock.hs view
@@ -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
src/Darcs/Util/Path.hs view
@@ -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
src/Darcs/Util/Printer.hs view
@@ -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
src/Darcs/Util/Printer/Color.hs view
@@ -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 )
src/Darcs/Util/Progress.hs view
@@ -29,6 +29,9 @@     ) where  +import Prelude ()+import Darcs.Prelude hiding ( lookup )+ import Prelude hiding (lookup)  import Control.Arrow ( second )
src/Darcs/Util/Prompt.hs view
@@ -10,7 +10,8 @@     ) where  -import Prelude hiding ( catch )+import Prelude ()+import Darcs.Prelude  import Control.Monad ( void )
src/Darcs/Util/Show.hs view
@@ -2,6 +2,9 @@     ( appPrec, BSWrapper(..)     ) where +import Prelude ()+import Darcs.Prelude+ import qualified Data.ByteString as B  appPrec :: Int
src/Darcs/Util/SignalHandler.hs view
@@ -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 ) )
src/Darcs/Util/Ssh.hs view
@@ -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."])
src/Darcs/Util/Text.hs view
@@ -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)
+ src/Darcs/Util/Tree.hs view
@@ -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+
+ src/Darcs/Util/Tree/Hashed.hs view
@@ -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+
+ src/Darcs/Util/Tree/Monad.hs view
@@ -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
+ src/Darcs/Util/Tree/Plain.hs view
@@ -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)+
src/Darcs/Util/URL.hs view
@@ -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)
src/Darcs/Util/Workaround.hs view
@@ -25,7 +25,8 @@     , sigPIPE     ) where -import Prelude hiding ( catch )+import Prelude ()+import Darcs.Prelude  #ifdef WIN32
src/win32/System/Posix.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE ForeignFunctionInterface #-}  module System.Posix ( sleep ) where
src/win32/System/Posix/Files.hsc view
@@ -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
− tests/add-formerly-pl.sh 
@@ -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
tests/add.sh view
@@ -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
− tests/add_in_subdir.sh 
@@ -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
− tests/addexitval.sh 
@@ -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
− tests/addmv.sh 
@@ -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-
− tests/addrace.sh 
@@ -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-
− tests/addrm.sh 
@@ -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-
− tests/amend-cancelling.sh 
@@ -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
− tests/amend-record-back-up.sh 
@@ -1,39 +0,0 @@-#!/usr/bin/env bash-## Copyright (C) 2011 Ganesh Sittampalam <ganesh@earth.li>-##-## 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
− tests/amend-unrecord.sh 
@@ -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 -
tests/amend.sh view
@@ -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 <ganesh@earth.li>++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
+ tests/apply_skip_conflicts.sh view
@@ -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 ..
tests/ask_deps.sh view
@@ -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
− tests/bad_pending_after_pull.sh 
@@ -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
− tests/changes-duplicate.sh 
@@ -1,49 +0,0 @@-#!/usr/bin/env bash-## Test for patch index automation - <SYNOPSIS: Patch index should-## always be in sync with repo after execution of any command.>-##-## 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'
− tests/changes.sh 
@@ -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@b.com>' -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 '&lt;a@b.com&gt;' 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
− tests/changes_send_context.sh 
@@ -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
− tests/changes_with_move.sh 
@@ -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
+ tests/conflict-reporting.sh view
@@ -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 <<EOF+line1+EOF+darcs add file1+cat > file2 <<EOF+line1+line2+line3+EOF+darcs add file2+darcs rec -am "initial patch"++cd ..+darcs get R1 R2+cd R2++cat > file1 <<EOF+line1A+EOF+cat > file2 <<EOF+line1A+line2+line3+EOF++darcs rec -am "patch 1"++cd ../R1++cat > file1 <<EOF+line1B+EOF+cat > file2 <<EOF+line1+line2+line3B+EOF++darcs rec -am "patch 2"+darcs pull -a ../R2 > pull-output+grep "We have conflicts in the following files" pull-output+grep "file1" pull-output+not grep "file2" pull-output++cat > file1-expected <<EOF+v v v v v v v+line1+=============+line1A+*************+line1B+^ ^ ^ ^ ^ ^ ^+EOF++diff -u file1-expected file1++darcs changes --summary -p "patch 1" > changes-output+grep "M! ./file1 -1 +1" changes-output+grep "M ./file2 -1 +1" changes-output+
− tests/dist-v.sh 
@@ -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-
− tests/double-unrevert.sh 
@@ -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
− tests/failing-haskell_policy.sh 
@@ -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
tests/failing-index-argument.sh view
@@ -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
− tests/failing-issue1013_either_dependency.sh 
@@ -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
− tests/failing-issue1196_whatsnew_falsely_lists_all_changes.sh 
@@ -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-
tests/failing-issue1316-2.sh view
@@ -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
− tests/failing-issue1332_add_r_boring.sh 
@@ -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
tests/failing-issue1401_bug_in_get_extra.sh view
@@ -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/
− tests/failing-issue1609_ot_convergence.sh 
@@ -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 <kowey@darcs.net>-## Copyright (C) 2009 Pascal Molli <momo54@gmail.com>-##-## 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
− tests/failing-issue1632_changes_nonexisting.sh 
@@ -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 ..
@@ -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
tests/failing-issue1829-inconsistent-conflictor.sh view
@@ -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
− tests/failing-issue1928-file-dir-replace.sh 
@@ -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 ..
− tests/failing-issue2017-missing-tag.sh 
@@ -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
tests/failing-issue2047_duplicate_conflictor_recommute_fail.sh view
@@ -43,6 +43,8 @@ # # See issue2047 on the BTS for more information. +. ./lib+ rm -rf R1* R2 R3*  darcs init --repo R1
− tests/failing-issue2086-index-permissions.sh 
@@ -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 ..
− tests/failing-issue2138-whatsnew-s.sh 
@@ -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
tests/failing-issue2186-apply--reply-conflict.sh view
@@ -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
tests/failing-issue2186-apply--reply-ok.sh view
@@ -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
tests/failing-issue2219-no-working.sh view
@@ -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
− tests/failing-issue2238-unadded-files-showing-added.sh 
@@ -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'
− tests/failing-issue2242-rollback-mv.sh 
@@ -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
tests/failing-issue2293-laziness-amend.sh view
@@ -32,4 +32,4 @@  echo 'baz' > bar -echo yyyy | darcs amend-rec+echo yyyy | darcs amend
− tests/failing-issue2308-changes-missing-amend-edit.sh 
@@ -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 <<EOF-  * Add file-Shall I amend this patch? [yNjk...], or ? for more options: Add file-***END OF DESCRIPTION***--Place the long patch description above the ***END OF DESCRIPTION*** marker.-The first line of this file will be the patch name.---This patch contains the following changes:--EOF--export DARCS_EDITOR=cat-# Ignore the patch date/author line (telling tail to start at line 2) and the-# "finished amending patch:" lines-echo y | darcs amend --edit | tail -n+2 | head -n-3 > actual--not diff expected actual
− tests/failing-issue2380-rename-to-deleted-file.sh 
@@ -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 && $(<foo) == "otherstuff" ]]--echo -e 'hunk ./foo 1\n-foostuff\nrmfile ./foo\nmove ./other ./foo' > expected-darcs wh > actual--diff expected actual--darcs rev -a--[[ -e foo && -e other && $(<foo) == "foostuff" && $(<other) == "otherstuff" ]]
+ tests/failing-issue2480-display-unicode-in-patch-content.sh view
@@ -0,0 +1,9 @@+#!/usr/bin/env bash++. lib+darcs init R+cd R+touch äöüßÄÖÜ+darcs record -lam'added äöüßÄÖÜ'+#darcs log -s | grep './äöüßÄÖÜ'+DARCS_DONT_ESCAPE_8BIT=1 darcs log -s | grep './äöüßÄÖÜ'
− tests/failing-issue612_repo_not_writable.sh 
@@ -1,35 +0,0 @@-#!/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-
− tests/failing-issue68_broken_pipe.sh 
@@ -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 ..
− tests/failing-look_for_moves.sh 
@@ -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 <<EOF- ./dir -> ./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
tests/failing-merging_newlines.sh view
@@ -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
− tests/get-http-packed-detect.sh 
@@ -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"
− tests/get-http-packed.sh 
@@ -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
− tests/get-http.sh 
@@ -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
tests/git_import_delete_empty_directories.sh view
@@ -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
+ tests/git_rename_and_copy_files.sh view
@@ -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 <me@example.org> 1307452813 +0100+committer CommiterName <me@example.org> 1307452813 +0100+data 6+add a+M 100644 :1 a++commit refs/heads/master+mark :3+author CommiterName <me@example.org> 1307452821 +0100+committer CommiterName <me@example.org> 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 ]]
+ tests/git_rename_dir.sh view
@@ -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 <me@example.org> 1307452813 +0100+committer CommiterName <me@example.org> 1307452813 +0100+data 10+add dir/a+M 100644 :1 dir/a++commit refs/heads/master+mark :3+author CommiterName <me@example.org> 1307452821 +0100+committer CommiterName <me@example.org> 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 ]]
+ tests/hijack.sh view
@@ -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 ..
− tests/illegal_mv.sh 
@@ -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-
− tests/impossible_unrevert.sh 
@@ -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
− tests/issue1012_unrecord_remove.sh 
@@ -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
− tests/issue1111-pull-intersection.sh 
@@ -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
tests/issue1139-diff-last.sh view
@@ -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'
+ tests/issue1196_whatsnew_falsely_lists_all_changes.sh view
@@ -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+
+ tests/issue1332_add_r_boring.sh view
@@ -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
− tests/issue1337_darcs_changes_false_positives.sh 
@@ -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')"
− tests/issue142_record-log.sh 
@@ -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
− tests/issue1599-automatically-expire-unused-caches.sh 
@@ -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 ]
@@ -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
− tests/issue1765_recursive-remove-on-root.sh 
@@ -1,36 +0,0 @@-#!/usr/bin/env bash-## Test for issueNNNN - <SYNOPSIS: WHAT IS THE BUG?  THIS SYNOPSIS-## SHOULD BE ONE OR TWO SENTENCES.>-##-## 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
tests/issue1825-remove-pending.sh view
@@ -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
− tests/issue1845-record-removed.sh 
@@ -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 ..
− tests/issue184_add.sh 
@@ -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
− tests/issue1888-changes-context.sh 
@@ -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
− tests/issue1923-cache-warning.sh 
@@ -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 <<SOURCES > 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
+ tests/issue1928-file-dir-replace.sh view
@@ -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 ..
tests/issue1932-colon-breaks-add.sh view
@@ -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
+ tests/issue2017-missing-tag.sh view
@@ -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
+ tests/issue2086-index-permissions.sh view
@@ -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 ..
− tests/issue2136-changes_created_as_for_multiple_files.sh 
@@ -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 "<created_as current_name='\./$2' original_name='\./$3'>" -C2 | tail -1 | grep "<name>$4</name>"-}--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 "<created_as[^>]*'\./f6'"
+ tests/issue2136-log_created_as_for_multiple_files.sh view
@@ -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 "<created_as current_name='\./$2' original_name='\./$3'>" -C2 | tail -1 | grep "<name>$4</name>"+}++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 "<created_as[^>]*'\./f6'"
+ tests/issue2138-whatsnew-s.sh view
@@ -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
− tests/issue2139-mv-to-dir.sh 
@@ -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 ..
tests/issue2209-look_for_replaces.sh view
@@ -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
+ tests/issue2242-rollback-mv.sh view
@@ -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
− tests/issue2270-changes-interactive-only-to-files.sh 
@@ -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
+ tests/issue2270-log-interactive-only-to-files.sh view
@@ -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
+ tests/issue2378-moving-directory-to-file.sh view
@@ -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
+ tests/issue2380-rename-to-deleted-file.sh view
@@ -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 && $(<foo) == "otherstuff" ]]++echo -e 'hunk ./foo 1\n-foostuff\nrmfile ./foo\nmove ./other ./foo' > expected+darcs wh > actual++diff expected actual++darcs rev -a++[[ -e foo && -e other && $(<foo) == "foostuff" && $(<other) == "otherstuff" ]]
− tests/issue2388-optimize-fails-no-changes.sh 
@@ -1,30 +0,0 @@-#!/usr/bin/env bash-## Test for issue2388 - optimize fails if no patches have been recorded-##-## 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-## SOFTWARE.--. lib-darcs init --repo R-cd R--darcs optimize clean
− tests/issue244_changes.sh 
@@ -1,18 +0,0 @@-#!/usr/bin/env bash-. ./lib--# Issue244-# darcs changes should be able to pull up the history for a file-#   using its moved and not-yet recorded new name--rm -rf temp1-mkdir temp1-cd temp1-darcs init-touch b-darcs add b-darcs record -am 11-darcs mv b c-darcs changes c | grep 11-cd ..-rm -rf temp1
+ tests/issue2479-mv-list-files.sh view
@@ -0,0 +1,14 @@+#!/usr/bin/env bash+## Test for issueNNNN - Bad error message in 'darcs move' if the repo root dir (".")+##                      is given among multiple sources for the move.++. lib                           # Load some portability helpers.++mkdir R+cd R+darcs init+echo "test" > b+darcs add b+darcs record -a -m 'added b'+mkdir a+not darcs move . ./b a 2>&1 | not grep -i bug
+ tests/issue2494-output-of-record-with-file-arguments.sh view
@@ -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
+ tests/issue612_repo_not_writable.sh view
@@ -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+
+ tests/issue68_broken_pipe.sh view
@@ -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 ]]
tests/lib view
@@ -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 }
+ tests/log-duplicate.sh view
@@ -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'
+ tests/log.sh view
@@ -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 <a@b.com>' -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 '&lt;a@b.com&gt;' 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++
+ tests/log_send_context.sh view
@@ -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
tests/look_for_moves.sh view
@@ -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 <<EOF@@ -18,7 +18,7 @@ EOF diff -u log log.expected rm log log.expected-darcs record -a -m move_file -A x --look-for-moves+darcs record -am move_file --look-for-moves darcs wh --look-for-moves --look-for-adds  >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 <<EOF@@ -35,7 +35,7 @@ EOF diff -u log log.expected rm log log.expected-darcs record -a -m move_file -A x --look-for-moves+darcs record -am move_dir --look-for-moves darcs wh --look-for-adds >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 <<EOF@@ -116,7 +116,7 @@ EOF diff -u log log.expected rm log log.expected-darcs record -a -m move_dir -A x --look-for-moves+darcs record -am move_dir --look-for-moves darcs wh --look-for-moves --look-for-adds >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 <<EOF+ ./dir/foo -> ./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 <<EOF
tests/merge_three_patches.sh view
@@ -42,8 +42,8 @@  cd tempA darcs pull ../tempB-darcs annotate -p B-darcs annotate -p resolution+darcs log -v --max-count 1 -p B | cat+darcs log -v --max-count 1 -p resolution | cat cd ..  cmp tempA/foo tempB/foo
tests/merging_newlines.sh view
@@ -31,7 +31,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
− tests/mv-formerly-pl.sh 
@@ -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--
− tests/mv-test-suite.sh 
@@ -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-
tests/mv.sh view
@@ -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
− tests/mv_then_add.sh 
@@ -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-
+ tests/network/clone-http-packed-detect.sh view
@@ -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"
+ tests/network/clone-http-packed.sh view
@@ -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
+ tests/network/clone-http.sh view
@@ -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
tests/network/clone.sh view
@@ -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
tests/network/issue1503_prefer_local_caches_to_remote_one.sh view
@@ -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
+ tests/network/issue1599-automatically-expire-unused-caches.sh view
@@ -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 ]
+ tests/network/issue1923-cache-warning.sh view
@@ -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 <<SOURCES > 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
+ tests/network/issue1932-remote.sh view
@@ -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
tests/network/issue2090-transfer-mode.sh view
@@ -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} "\
tests/network/lazy-clone.sh view
@@ -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
tests/network/log.sh view
@@ -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
+ tests/network/show_tags-remote.sh view
@@ -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
tests/network/ssh.sh view
@@ -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
− tests/obliterate-add.sh 
@@ -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
− tests/obliterate-formerly-pl.sh 
@@ -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
tests/obliterate.sh view
@@ -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 <<EOF+one+two+three+EOF+darcs rec -Ax -alm init+cp f g+cat > f <<EOF+three+one+EOF+darcs rec -Ax -am foo+echo yy | darcs unpull -p foo+cmp f g+cd ..+rm -rf temp1
tests/optimize.sh view
@@ -14,3 +14,11 @@ cd ..  rm -rf temp1++## issue2388 - optimize fails if no patches have been recorded++darcs init temp1+cd temp1+darcs optimize clean+cd ..+rm -rf temp1
tests/patch-index-creation.sh view
@@ -36,27 +36,27 @@  darcs init --repo R cd R-darcs show patch-index-status | grep 'Patch Index is not yet created.' # init+darcs show patch-index | grep 'Patch Index is not yet created.' # init  cd .. rm -rf R  darcs init --repo R --with-patch-index cd R-darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # init --patch-index+darcs show patch-index | grep 'Patch Index is in sync with repo.' # init --patch-index  cd ..  darcs clone R S cd S-darcs show patch-index-status | grep 'Patch Index is not yet created.' # clone+darcs show patch-index | grep 'Patch Index is not yet created.' # clone  cd .. rm -rf S  darcs clone R S --with-patch-index cd S-darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # clone --patch-index+darcs show patch-index | grep 'Patch Index is in sync with repo.' # clone --patch-index  cd .. @@ -64,7 +64,7 @@ gunzip -c $TESTDATA/simple-v1.tgz | tar xf - echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2  cd repo2-darcs show patch-index-status | grep 'Patch Index is not yet created.' # convert+darcs show patch-index | grep 'Patch Index is not yet created.' # convert  cd .. rm -rf repo repo2@@ -72,7 +72,7 @@ gunzip -c $TESTDATA/simple-v1.tgz | tar xf - echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2 --with-patch-index cd repo2-darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # convert --patch-index+darcs show patch-index | grep 'Patch Index is in sync with repo.' # convert --patch-index  cd ../R @@ -81,19 +81,19 @@ darcs record -lam "Change d/f" rm -rf _darcs/patch_index darcs annotate d/f-darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # annotate+darcs show patch-index | grep 'Patch Index is in sync with repo.' # annotate  rm -rf _darcs/patch_index darcs annotate d/f --no-patch-index-darcs show patch-index-status | grep 'Patch Index is not yet created.' # annotate --no-patch-index+darcs show patch-index | grep 'Patch Index is not yet created.' # annotate --no-patch-index  rm -rf _darcs/patch_index darcs log -a d/f-darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # log -a file+darcs show patch-index | grep 'Patch Index is in sync with repo.' # log -a file  rm -rf _darcs/patch_index darcs log -a d/f --no-patch-index-darcs show patch-index-status | grep 'Patch Index is not yet created.' # log -a file --no-patch-index+darcs show patch-index | grep 'Patch Index is not yet created.' # log -a file --no-patch-index  cd .. rm -rf R S repo repo2
tests/patch-index-enabled-and-disabled.sh view
@@ -48,14 +48,14 @@ darcs changes f | grep 'older darcs'  # Now, check: Did the patch-index self heal?-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.'  # Another check, just to be sure. echo 'Example content updated again.' > 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 ..
tests/patch-index-rename.sh view
@@ -34,5 +34,5 @@ darcs mv file1 file2 darcs rec -am "move" -darcs show patch-index-test+darcs show patch-index --verbose
tests/patch-index-spans.sh view
@@ -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
tests/patch-index-sync.sh view
@@ -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
− tests/pull-union.sh 
@@ -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
tests/pull.sh view
@@ -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+
− tests/pull_binary.sh 
@@ -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
− tests/pull_compl.sh 
@@ -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 <<EOF-line1-line2-line3-line4-line5-line6-line7-EOF-darcs initialize-darcs add foo-darcs record -a -m addfoo--cd ..-darcs get temp1 temp4--chgrec () {-    set -ev-    sed -e "$1" 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 <<EOF-  * inssub2-  * Line4-  * line0-  * LINE4-  * LastLine-  * line4.1-EOF-diff p1.req p1.out--darcs pull ../temp1 --dry-run --complement | grep ' \*' > p2.out-diff p1.out p2.out--darcs pull --dry-run --complement ../temp1 ../temp2 | grep ' \*' > p3.out-cat > p3.req <<EOF-  * line0-  * LastLine-EOF-diff p3.req p3.out--darcs pull --dry-run --complement ../temp1 ../temp3 | grep ' \*' > p4.out-cat > p4.req <<EOF-  * line0-EOF-diff p3.req p3.out--darcs pull --dry-run --complement ../temp1 ../temp2 ../temp3 | grep ' \*' > 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 <<EOF-  * LastLine-EOF--darcs pull --dry-run --complement ../temp2 ../temp3 > 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
+ tests/pull_complement.sh view
@@ -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 <<EOF+line1+line2+line3+line4+line5+line6+line7+EOF+darcs initialize+darcs add foo+darcs record -a -m addfoo++cd ..+darcs get temp1 temp4++chgrec () {+    set -ev+    sed -e "$1" 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 <<EOF+  * inssub2+  * Line4+  * line0+  * LINE4+  * LastLine+  * line4.1+EOF+diff p1.req p1.out++darcs pull ../temp1 --dry-run --complement | grep ' \*' > p2.out+diff p1.out p2.out++darcs pull --dry-run --complement ../temp1 ../temp2 | grep ' \*' > p3.out+cat > p3.req <<EOF+  * line0+  * LastLine+EOF+diff p3.req p3.out++darcs pull --dry-run --complement ../temp1 ../temp3 | grep ' \*' > p4.out+cat > p4.req <<EOF+  * line0+EOF+diff p3.req p3.out++darcs pull --dry-run --complement ../temp1 ../temp2 ../temp3 | grep ' \*' > 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 <<EOF+  * LastLine+EOF++darcs pull --dry-run --complement ../temp2 ../temp3 > 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
− tests/pull_conflicts.sh 
@@ -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 ..
− tests/pull_two.sh 
@@ -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
− tests/push-dont-prompt-deps.sh 
@@ -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
tests/push-dry-run.sh view
@@ -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
− tests/push-formerly-pl.sh 
@@ -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
tests/push.sh view
@@ -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
− tests/push_conflicts.sh 
@@ -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 ..
− tests/push_lock.sh 
@@ -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
− tests/query_manifest.sh 
@@ -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
tests/rebase-nochanges.sh view
@@ -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 -
+ tests/rebase-warns-lost-deps.sh view
@@ -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
− tests/record-interactive.sh 
@@ -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
− tests/record-misc.sh 
@@ -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
+ tests/record.sh view
@@ -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 <<EOF+1+2+3+4+EOF+darcs add file+darcs rec -a -m "init" file+cat > file <<EOF+A+2+3+B+EOF+echo y | darcs record --edit-long-comment -a -m edit | grep -c "./file" | grep 1+cd ..+rm -rf temp2\ dir++export DARCS_EDITOR='grep "# Please enter"'+# editor: quoting 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++export DARCS_EDITOR='echo'+# editor: evil filename+darcs init temp1+cd temp1+touch file.t+darcs add file.t+touch '; test-command'+echo > 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
− tests/record_editor.sh 
@@ -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 <<EOF-1-2-3-4-EOF-darcs add file-darcs rec -a -m "init" file-cat > file <<EOF-A-2-3-B-EOF-echo y | darcs record --edit-long-comment -a -m edit | grep -c "./file" | grep 1-cd ..-rm -rf temp2\ dir--export DARCS_EDITOR='grep "# Please enter"'-# editor: quoting 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--export DARCS_EDITOR='echo'-# editor: evil filename-mkdir temp1-cd temp1-darcs init-touch file.t-darcs add file.t-touch '; test-command'-echo > 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
− tests/recordrace.sh 
@@ -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-
tests/remove.sh view
@@ -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
tests/replace.sh view
@@ -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+
− tests/replace_after_pending_add.sh 
@@ -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-
− tests/replace_after_pending_mv.sh 
@@ -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-
+ tests/show_files.sh view
@@ -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
− tests/show_tags-remote.sh 
@@ -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
− tests/tricky_unrecord.sh 
@@ -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-
− tests/unpull-formerly-pl.sh 
@@ -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-
− tests/unpull.sh 
@@ -1,23 +0,0 @@-#!/usr/bin/env bash-. ./lib--rm -rf temp1-mkdir temp1-cd temp1-darcs init-cat > f <<EOF-one-two-three-EOF-darcs rec -Ax -alm init-cp f g-cat > f <<EOF-three-one-EOF-darcs rec -Ax -am foo-echo yy | darcs unpull -p foo-cmp f g-cd ..-rm -rf temp1
− tests/unrecord-add.sh 
@@ -1,23 +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 record -a -m 'addfoo'--darcs unrecord -a--darcs whatsnew > unrecorded-cat unrecorded--diff -u correct unrecorded--cd ..-rm -rf temp1
− tests/unrecord-dont-prompt.sh 
@@ -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
− tests/unrecord-remove.sh 
@@ -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
− tests/unrecord-setpref.sh 
@@ -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
+ tests/unrecord.sh view
@@ -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
− tests/unrevert-add.sh 
@@ -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
− tests/unrevert-replace-moved.sh 
@@ -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
tests/unrevert.sh view
@@ -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
− tests/unrevert_cancel.sh 
@@ -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
− tests/what_sl.sh 
@@ -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-
− tests/whatsnew-file.sh 
@@ -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
− tests/whatsnew-interactive.sh 
@@ -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;
− tests/whatsnew-pending.sh 
@@ -1,38 +0,0 @@-#!/usr/bin/env bash-## Ensure that darcs whatsnew <paths> 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 ..
tests/whatsnew.sh view
@@ -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 <paths> 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+