screened 2024-10-14 07:44:03+00:00

darcs.cabal

@@ -376,6 +376,7 @@ Library
                       Darcs.Util.Show
                       Darcs.Util.SignalHandler
                       Darcs.Util.Ssh
+                      Darcs.Util.StrictIdentity
                       Darcs.Util.Tree
                       Darcs.Util.Tree.Hashed
                       Darcs.Util.Tree.Monad
@@ -408,9 +409,12 @@ Library
                       System.Posix.IO
       cpp-options:    -DWIN32
       c-sources:      src/win32/send_email.c
-      build-depends:  Win32 >= 2.4.0 && < 2.14
+      build-depends:  Win32             >= 2.4.0 && < 2.14,
+                      -- exclude 1.3.8 .. 1.3.8.4 due to bug on windows
+                      directory         >= 1.2.7 && < 1.3.8 || >= 1.3.8.5 && < 1.4
     else
-      build-depends:  unix >= 2.7.1.0 && < 2.9
+      build-depends:  unix              >= 2.7.1.0 && < 2.9,
+                      directory         >= 1.2.7 && < 1.4
 
     build-depends:    base              >= 4.10 && < 4.21,
                       safe              >= 0.3.20 && < 0.4,
@@ -443,13 +447,10 @@ Library
                       old-time          >= 1.1.0.3 && < 1.2,
                       time              >= 1.9 && < 1.15,
                       text              >= 1.2.1.3 && < 2.2,
-                      directory         >= 1.2.7 && < 1.3.8 || >= 1.3.8.5 && < 1.4,
                       temporary         >= 1.2.1 && < 1.4,
                       process           >= 1.2.3.0 && < 1.7,
                       array             >= 0.5.1.0 && < 0.6,
                       hashable          >= 1.2.3.3 && < 1.5,
-                      semialign         >= 1.3 && < 1.4,
-                      these             >= 1.2 && < 1.3,
                       mmap              >= 0.5.9 && < 0.6,
                       zlib              >= 0.6.1.2 && < 0.8,
                       network-uri       >= 2.6 && < 2.8,
@@ -458,10 +459,9 @@ Library
                       http-conduit      >= 2.3 && < 2.4,
                       http-types        >= 0.12.1 && < 0.12.5,
                       exceptions        >= 0.6 && < 0.11,
-                      terminal-size     >= 0.3.4 && < 0.4,
-                      strict-identity   >= 0.1 && < 0.2
+                      terminal-size     >= 0.3.4 && < 0.4
 
-    if impl(ghc >= 9.6)
+    if impl(ghc >= 9.8)
       cpp-options:    -DHAVE_CRYPTON_CONNECTION
       build-depends:  crypton-connection >= 0.4 && < 0.5,
                       data-default-class >= 0.1.2.0 && < 0.1.3,

harness/Darcs/Test/Patch/V1Model.hs

@@ -31,6 +31,7 @@ import Darcs.Patch.Witnesses.Show
 
 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.Arrow ( second )
@@ -119,6 +120,9 @@ emptyDir = RepoItem $ T.SubTree T.emptyTree
 ----------------------------------------------------------------------
 -- * Queries
 
+nullRepo :: V1Model wX -> Bool
+nullRepo = M.null . T.items . repoTree
+
 isFile :: RepoItem -> Bool
 isFile (RepoItem (T.File _)) = True
 isFile _other                = False
@@ -171,12 +175,15 @@ filterDirs = filter (isDir . snd)
 ----------------------------------------------------------------------
 -- * Comparing repositories
 
-diffRepos :: V1Model wX -> V1Model wY -> Bool
+diffRepos :: V1Model wX -> V1Model wY -> (V1Model wU, V1Model wV)
 diffRepos repo1 repo2 =
-    null $ unFail $
-      T.diffTrees' diffItem (repoTree repo1) (repoTree repo2)
+  let (diff1,diff2) = unFail $ T.diffTrees hashedTree1 hashedTree2
+    in (V1Model diff1, V1Model diff2)
   where
-    diffItem p _ = return p
+      hashedTree1, hashedTree2 :: Tree Fail
+      hashedTree1 = unFail $ darcsUpdateHashes $ repoTree repo1
+      hashedTree2 = unFail $ darcsUpdateHashes $ repoTree repo2
+
 
 ----------------------------------------------------------------------
 -- * Patch application
@@ -261,7 +268,8 @@ instance RepoModel V1Model where
                   dirsNo <- frequency [(3, return 1), (1, return 0)]
                   aRepo filesNo dirsNo
   repoApply (V1Model tree) patch = V1Model <$> applyToTree patch tree
-  eqModel repo1 repo2 = diffRepos repo1 repo2
+  eqModel repo1 repo2 = let (diff1,diff2) = diffRepos repo1 repo2
+                         in nullRepo diff1 && nullRepo diff2
 
 
 instance Arbitrary (Sealed V1Model) where

harness/Darcs/Test/Shell.hs

@@ -113,7 +113,6 @@ runtest' ShellTest{..} srcdir =
           , ("TESTDATA", EnvFilePath (srcdir </> "tests" </> "data"))
           , ("TESTBIN", EnvFilePath (srcdir </> "tests" </> "bin"))
           , ("DARCS_TESTING_PREFS_DIR"   , EnvFilePath $ wd </> ".darcs")
-          , ("DARCS_TESTING_CACHE_DIR"   , EnvFilePath $ wd </> ".cache" </> "darcs")
           , ("EMAIL"                     , EnvString "tester")
           , ("GIT_AUTHOR_NAME"           , EnvString "tester")
           , ("GIT_AUTHOR_EMAIL"          , EnvString "tester")

release/distributed-version

@@ -1 +1 @@
-Just 51
+Just 72

src/Darcs/Patch/ApplyMonad.hs

@@ -37,12 +37,12 @@ import qualified Data.ByteString      as B
 import qualified Data.ByteString.Lazy as BL
 import qualified Darcs.Util.Tree.Monad as TM
 import Darcs.Patch.Object ( ObjectIdOf )
+import Darcs.Util.StrictIdentity (StrictIdentity(..) )
 import Darcs.Util.Tree ( Tree )
 import Data.Maybe ( fromMaybe )
 import Darcs.Util.Path ( AnchoredPath, movedirfilename, isPrefix )
 import Control.Monad.Catch ( MonadThrow(..) )
 import Control.Monad.State.Strict
-import Control.Monad.StrictIdentity (StrictIdentity(..) )
 
 import GHC.Exts ( Constraint )
 

src/Darcs/Patch/Set.hs

@@ -31,7 +31,6 @@ module Darcs.Patch.Set
     , patchSetSnoc
     , patchSetSplit
     , patchSetDrop
-    , tagsCovering
     ) where
 
 import Darcs.Prelude
@@ -40,8 +39,7 @@ import qualified Data.Set as S
 
 import Darcs.Patch.Ident ( Ident(..), PatchId )
 import Darcs.Patch.Info ( PatchInfo, piTag )
-import Darcs.Patch.Named ( getdeps )
-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info )
+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )
 import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
 import Darcs.Patch.Witnesses.Ordered
     ( FL, RL(..), (+<+), (+<<+), (:>)(..), reverseRL,
@@ -141,38 +139,6 @@ patchSetInventoryHashes (PatchSet ts _) = mapRL (\(Tagged _ _ mh) -> mh) ts
 patchSetTags :: PatchSet p wX wY -> [String]
 patchSetTags = catMaybes . mapRL (piTag . info) . patchSet2RL
 
--- Find all tags that cover the latest patch matching the given matcher.
---
--- The algorithm: Go back until a matching patch is found. On the way, collect
--- information about tags. For each tag remember name and explicit
--- dependencies. Then go forward, and add every tag to the result that covers
--- the patch or covers one of the tags found so far. As a special optimization,
--- known clean tags always depend everything before them, so we don't have to
--- check their explicit dependencies.
-tagsCovering
-  :: forall p wO wX
-   . (forall wA wB. PatchInfoAnd p wA wB -> Bool)
-  -> PatchSet p wO wX
-  -> Maybe [String]
-tagsCovering matcher = fmap (catMaybes . fmap piTag) . go []
-  where
-    go :: [(PatchInfo, Maybe[PatchInfo])] -> PatchSet p wO wY -> Maybe [PatchInfo]
-    go _ (PatchSet NilRL NilRL) = Nothing
-    go tags (PatchSet (ts :<: Tagged ps t _) NilRL)
-      | matcher t = Just $ checkCovered (info t) tags
-      | otherwise = go ((info t, Nothing) : tags) (PatchSet ts ps)
-    go tags (PatchSet ts (ps :<: p))
-      | matcher p = Just $ checkCovered (info p) tags
-      | Just _ <- piTag (info p) =
-        go ((info p, Just (getdeps (hopefully p))) : tags) (PatchSet ts ps)
-      | otherwise = go tags (PatchSet ts ps)
-
-    checkCovered i ((t,Nothing):ts) = t : checkCovered i ts
-    checkCovered i ((t,Just is):ts)
-      | i `elem` is = t : checkCovered i ts
-      | otherwise = checkCovered i ts
-    checkCovered _ [] = []
-
 inOrderTags :: PatchSet p wS wX -> [PatchInfo]
 inOrderTags (PatchSet ts _) = go ts
   where go :: RL(Tagged t1) wT wY -> [PatchInfo]

src/Darcs/Patch/Summary.hs

@@ -30,6 +30,8 @@ import Darcs.Util.Printer
     , ($$)
     , (<+>)
     , empty
+    , minus
+    , plus
     , text
     , vcat
     )
@@ -176,8 +178,8 @@ summChunkToLine machineReadable (SummChunk detail c) =
      | otherwise       = text t <+> x <+> text "duplicate"
    --
    ad 0 = empty
-   ad a = text "+" <> text (show a)
+   ad a = plus <> text (show a)
    rm 0 = empty
-   rm a = text "-" <> text (show a)
+   rm a = minus <> text (show a)
    rp 0 = empty
    rp a = text "r" <> text (show a)

src/Darcs/Patch/Witnesses/Sealed.hs

@@ -50,8 +50,6 @@ import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP1, unsafeCoerceP )
 -- |A 'Sealed' type is a way of hide an existentially quantified type parameter,
 -- in this case wX, inside the type. Note that the only thing we can currently
 -- recover about the existentially quantified type wX is that it exists.
--- With https://github.com/ghc-proposals/ghc-proposals/pull/473
--- we could eliminate this and simply use @exists wY. a wY@.
 data Sealed a where
     Sealed :: a wX -> Sealed a
 
@@ -63,16 +61,12 @@ instance Eq2 a => Eq (Sealed (a wX)) where
                          | otherwise = False
 
 -- |The same as 'Sealed' but for two parameters (wX and wY).
--- With https://github.com/ghc-proposals/ghc-proposals/pull/473
--- we could eliminate this and simply use @exists wX wY. a wX wY@.
 data Sealed2 a where
     Sealed2 :: !(a wX wY) -> Sealed2 a
 
 seal2 :: a wX wY -> Sealed2 a
 seal2 = Sealed2
 
--- With https://github.com/ghc-proposals/ghc-proposals/pull/473
--- we could eliminate this and simply use @exists wX. a wX wY@.
 data FlippedSeal a wY where
     FlippedSeal :: !(a wX wY) -> FlippedSeal a wY
 
@@ -110,9 +104,6 @@ unseal f x = f (unsafeUnseal x)
 -- All this applies to Sealed2 too, and FlippedSeal if we ever need a lazy one (but
 -- the implementation of unsealFlipped has been strict for a long time without causing
 -- trouble).
---
--- All these difficulties would go away if we had
--- https://github.com/ghc-proposals/ghc-proposals/pull/473.
 
 mapSeal :: (forall wX . a wX -> b wX) -> Sealed a -> Sealed b
 mapSeal f = unseal (seal . f)

src/Darcs/Repository/Diff.hs

@@ -28,57 +28,85 @@
 -- Stability   : experimental
 -- Portability : portable
 
-{-# LANGUAGE PatternSynonyms #-}
 module Darcs.Repository.Diff
     (
       treeDiff
     ) where
 
 import Darcs.Prelude
 
+import qualified Data.ByteString.Lazy.Char8 as BLC
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
-import qualified Data.ByteString.Lazy.Char8 as BLC
-import Data.These ( These(..) )
-
-import Darcs.Patch
-    ( PrimPatch
-    , adddir
-    , addfile
-    , binary
-    , canonizeFL
-    , hunk
-    , invert
-    , rmdir
-    , rmfile
-    )
-import Darcs.Patch.Witnesses.Ordered ( FL(..), concatGapsFL, consGapFL, (+>+) )
+
+import Data.List ( sortBy )
+
+import Darcs.Util.Tree      ( diffTrees
+                            , zipTrees
+                            , TreeItem(..)
+                            , Tree
+                            , readBlob
+                            , emptyBlob
+                            )
+import Darcs.Util.Path( AnchoredPath, anchorPath )
+
+
+import Darcs.Util.ByteString ( isFunky )
+import Darcs.Patch  ( PrimPatch
+                    , hunk
+                    , canonizeFL
+                    , binary
+                    , addfile
+                    , rmfile
+                    , adddir
+                    , rmdir
+                    , invert
+                    )
+import Darcs.Repository.Prefs ( FileType(..) )
+import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), concatGapsFL, consGapFL )
 import Darcs.Patch.Witnesses.Sealed ( Gap(..) )
 import Darcs.Repository.Flags ( DiffAlgorithm(..) )
-import Darcs.Repository.Prefs ( FileType(..) )
-import Darcs.Util.ByteString ( isFunky )
-import Darcs.Util.Path ( AnchoredPath, anchorPath )
-import Darcs.Util.Tree ( Tree, TreeItem(..), diffTrees', emptyBlob, readBlob )
 
-type Diff m = These (TreeItem m) (TreeItem m)
+data Diff m = Added (TreeItem m)
+            | Removed (TreeItem m)
+            | Changed (TreeItem m) (TreeItem m)
 
-pattern Removed :: TreeItem m -> Diff m
-pattern Removed i = This i
 
-pattern Added :: TreeItem m -> Diff m
-pattern Added j = That j
+getDiff :: AnchoredPath
+        -> Maybe (TreeItem m)
+        -> Maybe (TreeItem m)
+        -> (AnchoredPath, Diff m)
+getDiff p Nothing (Just t) = (p, Added t)
+getDiff p (Just from) (Just to) = (p, Changed from to)
+getDiff p (Just t) Nothing = (p, Removed t)
+getDiff _ Nothing Nothing = error "impossible case" -- zipTrees should never return this
 
-pattern Changed :: TreeItem m -> TreeItem m -> Diff m
-pattern Changed i j = These i j
 
 treeDiff :: forall m w prim . (Monad m, Gap w, PrimPatch prim)
          => DiffAlgorithm
          -> (FilePath -> FileType)
          -> Tree m
          -> Tree m
          -> m (w (FL prim))
-treeDiff da ft t1 t2 = concatGapsFL <$> diffTrees' diff t1 t2
+treeDiff da ft t1 t2 = do
+    (from, to) <- diffTrees t1 t2
+    diffs <- mapM (uncurry diff) $ sortBy organise $ zipTrees getDiff from to
+    return $ concatGapsFL diffs
   where
+    -- sort into removes, changes, adds, with removes in reverse-path order
+    -- and everything else in forward order
+    organise :: (AnchoredPath, Diff m) -> (AnchoredPath, Diff m) -> Ordering
+
+    organise (p1, Changed _ _ ) (p2, Changed _ _) = compare p1 p2
+    organise (p1, Added _)      (p2, Added _)   = compare p1 p2
+    organise (p1, Removed _)    (p2, Removed _) = compare p2 p1
+
+    organise (_, Removed _) _ = LT
+    organise _ (_, Removed _) = GT
+
+    organise (_, Changed _ _) _ = LT
+    organise _ (_, Changed _ _) = GT
+
     diff :: AnchoredPath -> Diff m -> m (w (FL prim))
     diff _ (Changed (SubTree _) (SubTree _)) = return (emptyGap NilFL)
     diff p (Removed (SubTree _)) =

src/Darcs/Repository/Prefs.hs

@@ -301,14 +301,9 @@ xdgCacheDir = do
     `catchall` return Nothing
 
 globalCacheDir :: IO (Maybe FilePath)
-globalCacheDir = do
-    env <- getEnvironment
-    case lookup "DARCS_TESTING_CACHE_DIR" env of
-        Just d -> return (Just d)
-        Nothing
-            | windows   -> ((</> "cache2") `fmap`) `fmap` globalPrefsDir
-            | osx       -> ((</> "darcs") `fmap`) `fmap` osxCacheDir
-            | otherwise -> ((</> "darcs") `fmap`) `fmap` xdgCacheDir
+globalCacheDir | windows   = ((</> "cache2") `fmap`) `fmap` globalPrefsDir
+               | osx       = ((</> "darcs") `fmap`) `fmap` osxCacheDir
+               | otherwise = ((</> "darcs") `fmap`) `fmap` xdgCacheDir
 
 -- |tryMakeBoringRegexp attempts to create a Regex from a given String. The
 -- evaluation is forced, to ensure any malformed exceptions are thrown here,