Hi, Ganesh Sittampalam <[email protected]> writes: > ok, I think this looks fine. Eric has OK'd removal of > --store-in-memory on the basis that it's unused and not worth going > through a huge process for.
> What's in hashed-storage HEAD that's not in a hashed-storage release? I > only see this patch which seems inconsequential: the usual problem with out of order tags... I keep the HEAD and release branches conflated in a single repository and use tags to mark what goes into releases... I was sure that darcs changes --from-tag . works as expected, but that doesn't seem to be the case (blah). So it seems you need to darcs optimize --reorder to see what's on top. Anyway, I am attaching a complete diff. > Sun May 2 14:29:44 EDT 2010 Petr Rockai <[email protected]> > * Fix build on GHC 6.12 on Windows. > > Let me know if there are any other hashed-storage changes I should > review. Otherwise please commit the bundle yourself when ready along > with any version bumps needed. Yours, Petr.
Sun May 2 20:29:44 CEST 2010 Petr Rockai <[email protected]> * Fix build on GHC 6.12 on Windows. Sun Mar 21 12:41:09 CET 2010 Petr Rockai <[email protected]> * Explain req_size in mmapIndex's haddock. Fri Mar 19 15:35:51 CET 2010 Petr Rockai <[email protected]> * Add readDarcsHashedNosize that fails on encountering a size-prefixed hash. Sun Mar 7 12:31:07 CET 2010 Petr Rockai <[email protected]> * Use mmap >= 0.5. Sat Feb 13 20:18:13 CET 2010 Petr Rockai <[email protected]> * Fix withDirectory handling in Monad. Sat Feb 13 20:12:57 CET 2010 Petr Rockai <[email protected]> * Add a testcase for Monad's rename action. Sat Feb 13 20:12:29 CET 2010 Petr Rockai <[email protected]> * Add a testcase and a QC property for expandPath. Sat Feb 13 20:11:14 CET 2010 Petr Rockai <[email protected]> * Avoid a redundant replaceItem call on directories in hashedTreeIO/sync. Sat Feb 13 20:08:39 CET 2010 Petr Rockai <[email protected]> * Make expandPath more robust and useful. Sat Feb 13 20:08:09 CET 2010 Petr Rockai <[email protected]> * Lift unstub/isSub to toplevel in Tree, as they are useful elsewhere. Sat Feb 13 20:05:46 CET 2010 Petr Rockai <[email protected]> * Add a couple assertions to darcs hashed format code. Sat Feb 13 20:00:41 CET 2010 Petr Rockai <[email protected]> * Encountering Stub in darcsFormatDir is not fatal as long as a Hash is there. Sat Feb 13 20:00:02 CET 2010 Petr Rockai <[email protected]> * Also correctly canonize "." in floatPath. Fri Feb 12 16:21:52 CET 2010 Petr Rockai <[email protected]> * Make modifyTree more conservative about sticking NoHash around. Sat Apr 24 16:02:56 CEST 2010 Petr Rockai <[email protected]> tagged 0.4.12 diff -rN -u -p old-hashed-storage/Bundled/Posix.hsc new-hashed-storage/Bundled/Posix.hsc --- old-hashed-storage/Bundled/Posix.hsc 2010-05-06 09:04:28.000000000 +0200 +++ new-hashed-storage/Bundled/Posix.hsc 2010-05-06 09:04:28.000000000 +0200 @@ -10,7 +10,6 @@ import qualified Data.ByteString.Char8 a import Data.ByteString.Unsafe( unsafeUseAsCString ) import Foreign.Marshal.Alloc ( allocaBytes ) import Foreign.C.Error ( throwErrno, getErrno, eNOENT ) -import Foreign.C.String ( withCString ) import Foreign.C.Types ( CTime, CInt ) import Foreign.Ptr ( Ptr ) @@ -20,6 +19,12 @@ import System.Posix.Internals import System.Posix.Types ( Fd(..), CMode, EpochTime ) +#if mingw32_HOST_OS && __GLASGOW_HASKELL__ >= 612 +import Foreign.C.String( withCWString ) +#else +import Foreign.C.String ( withCString ) +#endif + #if mingw32_HOST_OS import Data.Int ( Int64 ) @@ -30,6 +35,14 @@ import System.Posix.Types ( FileOffset ) import System.Posix.Internals( lstat ) #endif +#if mingw32_HOST_OS && __GLASGOW_HASKELL__ >= 612 +bsToPath s f = withCWString (BS.unpack s) f +strToPath = withCWString +#else +bsToPath = unsafeUseAsCString +strToPath = withCString +#endif + data FileStatus = FileStatus { fst_exists :: !Bool, fst_mode :: !CMode, @@ -78,15 +91,15 @@ getSymbolicLinkStatus :: FilePath -> IO getSymbolicLinkStatus = getFileStatus ##else getSymbolicLinkStatus fp = - do_stat (\p -> (fp `withCString` (`lstat` p))) + do_stat (\p -> (fp `strToPath` (`lstat` p))) ##endif getFileStatus :: FilePath -> IO FileStatus getFileStatus fp = - do_stat (\p -> (fp `withCString` (`lstat` p))) + 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 `unsafeUseAsCString` (`lstat` p))) + do_stat (\p -> (fp `bsToPath` (`lstat` p))) {-# INLINE getFileStatusBS #-} diff -rN -u -p old-hashed-storage/hashed-storage.cabal new-hashed-storage/hashed-storage.cabal --- old-hashed-storage/hashed-storage.cabal 2010-05-06 09:04:28.000000000 +0200 +++ new-hashed-storage/hashed-storage.cabal 2010-05-06 09:04:28.000000000 +0200 @@ -73,7 +73,7 @@ library dataenc, binary, zlib, - mmap >= 0.4 && < 0.5 + mmap >= 0.5 && < 0.6 c-sources: Bundled/sha2.c diff -rN -u -p old-hashed-storage/Storage/Hashed/AnchoredPath.hs new-hashed-storage/Storage/Hashed/AnchoredPath.hs --- old-hashed-storage/Storage/Hashed/AnchoredPath.hs 2010-05-06 09:04:28.000000000 +0200 +++ new-hashed-storage/Storage/Hashed/AnchoredPath.hs 2010-05-06 09:04:28.000000000 +0200 @@ -82,8 +82,9 @@ makeName n | '/' `elem` n = error "/ may -- FilePaths before you declare them "good" by converting into AnchoredPath -- (using this function). floatPath :: FilePath -> AnchoredPath -floatPath = AnchoredPath . map (Name . BS.pack) . splitDirectories - . normalise . dropTrailingPathSeparator +floatPath = make . splitDirectories . normalise . dropTrailingPathSeparator + where make ["."] = AnchoredPath [] + make x = AnchoredPath $ map (Name . BS.pack) x anchoredRoot :: AnchoredPath diff -rN -u -p old-hashed-storage/Storage/Hashed/Darcs.hs new-hashed-storage/Storage/Hashed/Darcs.hs --- old-hashed-storage/Storage/Hashed/Darcs.hs 2010-05-06 09:04:28.000000000 +0200 +++ new-hashed-storage/Storage/Hashed/Darcs.hs 2010-05-06 09:04:28.000000000 +0200 @@ -18,7 +18,7 @@ import qualified Data.ByteString as BS import Data.List( sortBy ) import Data.Char( chr, ord, isSpace ) -import Data.Maybe( fromJust ) +import Data.Maybe( fromJust, isJust ) import qualified Data.Set as S import Control.Monad.State.Strict @@ -78,10 +78,13 @@ decodeDarcsSize bs = case BS8.split '-' _ -> Nothing darcsLocation :: FilePath -> (Maybe Int, Hash) -> FileSegment -darcsLocation dir (s,h) = (dir </> (prefix s ++ BS8.unpack (encodeBase16 h)), Nothing) +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. @@ -94,8 +97,7 @@ darcsFormatDir t = BL8.fromChunks <$> co string (Name name, item) = do header <- case item of File _ -> Just $ BS8.pack "file:\n" - SubTree _ -> Just $ BS8.pack "directory:\n" - Stub _ _ -> Nothing + _ -> Just $ BS8.pack "directory:\n" hash <- case itemHash item of NoHash -> Nothing x -> Just $ encodeBase16 x @@ -147,6 +149,7 @@ darcsAddMissingHashes = updateTree updat update (File blob@(Blob con NoHash)) = do hash <- sha256 <$> readBlob blob return $ File (Blob con hash) + update (Stub _ NoHash) = fail "NoHash Stub encountered in darcsAddMissingHashes" update x = return x ------------------------------------------- @@ -168,21 +171,25 @@ readDarcsHashedDir dir h = do -- | 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 :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO) -readDarcsHashed _ (_, NoHash) = fail "Cannot readDarcsHashed NoHash" -readDarcsHashed dir root@(_, hash) = do +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 [ - 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) + do when (sizefail && isJust s) $ fail "Boo." + 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 = readDarcsHashed' False +readDarcsHashedNosize dir hash = readDarcsHashed' True dir (Nothing, hash) + ---------------------------------------------------- -- Writing darcs-style hashed trees. -- @@ -237,12 +244,10 @@ hashedTreeIO action t dir = fsCreateHashedFile fn newcontent replaceItem path (Just nblob) updateSub path s = do - let !hash = darcsTreeHash s + let !hash = treeHash s Just dirdata = darcsFormatDir s fn = dir </> BS8.unpack (encodeBase16 hash) - ns = SubTree (s { treeHash = hash }) fsCreateHashedFile fn (compress dirdata) - replaceItem path (Just ns) -------------------------------------------------------------- -- Reading and writing packed pristine. EXPERIMENTAL. diff -rN -u -p old-hashed-storage/Storage/Hashed/Index.hs new-hashed-storage/Storage/Hashed/Index.hs --- old-hashed-storage/Storage/Hashed/Index.hs 2010-05-06 09:04:28.000000000 +0200 +++ new-hashed-storage/Storage/Hashed/Index.hs 2010-05-06 09:04:28.000000000 +0200 @@ -202,7 +202,8 @@ iHash' :: Item -> Hash iHash' i = SHA256 (iHash i) -- | Gives a ForeignPtr to mmapped index, which can be used for reading and --- updates. +-- 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 @@ -214,8 +215,8 @@ mmapIndex indexpath req_size = do | otherwise -> 0 case size of 0 -> return (castForeignPtr nullForeignPtr, size) - _ -> do (x, _) <- mmapFileForeignPtr indexpath - ReadWrite (Just (0, size + size_magic)) + _ -> do (x, _, _) <- mmapFileForeignPtr indexpath + ReadWriteEx (Just (0, size + size_magic)) return (x, size) data IndexM m = Index { mmap :: (ForeignPtr ()) diff -rN -u -p old-hashed-storage/Storage/Hashed/Monad.hs new-hashed-storage/Storage/Hashed/Monad.hs --- old-hashed-storage/Storage/Hashed/Monad.hs 2010-05-06 09:04:28.000000000 +0200 +++ new-hashed-storage/Storage/Hashed/Monad.hs 2010-05-06 09:04:28.000000000 +0200 @@ -54,7 +54,7 @@ type TreeIO = TreeMonad IO class (Functor m, Monad m) => TreeRO m where currentDirectory :: m AnchoredPath withDirectory :: (MonadError e m) => AnchoredPath -> m a -> m a - expandTo :: (MonadError e m) => AnchoredPath -> m () + expandTo :: (MonadError e m) => AnchoredPath -> m AnchoredPath -- | Grab content of a file in the current Tree at the given path. readFile :: (MonadError e m) => AnchoredPath -> m BL.ByteString -- | Check for existence of a node (file or directory, doesn't matter). @@ -147,33 +147,39 @@ maybeFlush = do x <- gets changesize instance (Monad m, MonadError e m) => TreeRO (TreeMonad m) where expandTo p = do t <- gets tree - case find t p of - Nothing -> do t' <- lift $ expandPath t p `catchError` \_ -> return t - modify $ \st -> st { tree = t' } + p' <- (`catPaths` p) `fmap` ask + let amend = do t' <- lift $ expandPath t p' + modify $ \st -> st { tree = t' } + case find t p' of + Nothing -> amend + Just (Stub _ _) -> amend _ -> return () + return p' fileExists p = - do expandTo p - (isJust . (flip findFile p)) `fmap` gets tree + do p' <- expandTo p + (isJust . (flip findFile p')) `fmap` gets tree directoryExists p = - do expandTo p - (isJust . (flip findTree p)) `fmap` gets tree + do p' <- expandTo p + (isJust . (flip findTree p')) `fmap` gets tree exists p = - do expandTo p - (isJust . (flip find p)) `fmap` gets tree + do p' <- expandTo p + (isJust . (flip find p')) `fmap` gets tree readFile p = - do expandTo p + do p' <- expandTo p t <- gets tree - let f = findFile t p + let f = findFile t p' case f of - Nothing -> fail $ "No such file " ++ show p + Nothing -> fail $ "No such file " ++ show p' Just x -> lift (readBlob x) currentDirectory = ask - withDirectory dir = local (\old -> old `catPaths` dir) + withDirectory dir act = do + dir' <- expandTo dir + local (\old -> dir') act instance (Functor m, Monad m, MonadError e m) => TreeRW (TreeMonad m) where writeFile p con = @@ -196,12 +202,13 @@ instance (Functor m, Monad m, MonadError modifyItem p Nothing rename from to = - do expandTo from + do from' <- expandTo from + to' <- expandTo to tr <- gets tree - let item = find tr from - found_to = find tr to + 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 to item modifyItem from Nothing + modifyItem to item diff -rN -u -p old-hashed-storage/Storage/Hashed/Test.hs new-hashed-storage/Storage/Hashed/Test.hs --- old-hashed-storage/Storage/Hashed/Test.hs 2010-05-06 09:04:28.000000000 +0200 +++ new-hashed-storage/Storage/Hashed/Test.hs 2010-05-06 09:04:28.000000000 +0200 @@ -171,8 +171,10 @@ tree = [ testCase "modifyTree" check_mod , 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 @@ -253,6 +255,16 @@ tree = [ testCase "modifyTree" check_mod 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" @@ -307,7 +319,11 @@ tree = [ testCase "modifyTree" check_mod prop_overlay_super (t1 :: Tree Identity, t2) = (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==> 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 = [ testCase "loose pristine tree" check_loose , testCase "load" check_load @@ -416,12 +432,18 @@ hash = [ testProperty "decodeBase16 . en where prop_base16 x = (decodeBase16 . encodeBase16) x == x prop_base64u x = (decodeBase64u . encodeBase64u) x == x -monad = [ testCase "path expansion" check_virtual ] +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 = [ testCase "getFileStatus" $ check_stat Posix.getFileStatus , testCase "getSymbolicLinkStatus" $ check_stat Posix.getSymbolicLinkStatus ] @@ -498,6 +520,14 @@ instance (Monad m) => Arbitrary (Tree m) 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 -- diff -rN -u -p old-hashed-storage/Storage/Hashed/Tree.hs new-hashed-storage/Storage/Hashed/Tree.hs --- old-hashed-storage/Storage/Hashed/Tree.hs 2010-05-06 09:04:28.000000000 +0200 +++ new-hashed-storage/Storage/Hashed/Tree.hs 2010-05-06 09:04:28.000000000 +0200 @@ -35,7 +35,7 @@ import qualified Data.ByteString.Lazy.Ch import qualified Data.ByteString.Char8 as BS import qualified Data.Map as M -import Data.Maybe( catMaybes ) +import Data.Maybe( catMaybes, isNothing ) import Data.List( union, sort ) import Control.Applicative( (<$>) ) @@ -158,10 +158,6 @@ expandUpdate update t_ = go (AnchoredPat expanded_map = M.fromList expanded tree = t { items = M.union orig_map expanded_map } update path tree - unstub (Stub s _) = s - unstub (SubTree t) = return t - isSub (File _) = False - isSub _ = True -- | 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 @@ -171,21 +167,18 @@ expand :: (Monad m) => Tree m -> m (Tree expand = expandUpdate $ \_ -> return -- | Unfold a path in a (stubbed) Tree, such that the leaf node of the path is --- reachable without crossing any stubs. +-- 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_ = do expand' t_ path_ - where expand' t (AnchoredPath [_]) = return t - expand' t (AnchoredPath (n:rest)) = do +expandPath t_ path_ = expand' t_ path_ + where expand' t (AnchoredPath []) = return t + expand' t (AnchoredPath (n:rest)) = case lookup t n of - (Just (Stub stub _)) -> - do unstubbed <- stub - amend t n rest unstubbed - (Just (SubTree t')) -> amend t n rest t' - _ -> fail $ "Descent error in expandPath: " ++ show path_ + (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 orig_l = [ i | i@(n',_) <- listImmediate t, name /= n' ] - tree = t { items = M.insert name (SubTree sub') (items t) } + let tree = t { items = M.insert name (SubTree sub') (items t) } return tree class (Monad m) => FilterTree a m where @@ -322,37 +315,40 @@ diffTrees left right = -- | Modify a Tree (by replacing, or removing or adding items). modifyTree :: (Monad m) => Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m - -modifyTree _ (AnchoredPath []) (Just (SubTree sub)) = sub - -modifyTree t (AnchoredPath [n]) (Just item) = - t { items = countmap items' `seq` items' - , treeHash = NoHash } - where !items' = M.insert n item (items t) - -modifyTree t (AnchoredPath [n]) Nothing = - t { items = countmap items' `seq` items' - , treeHash = NoHash } - where !items' = M.delete n (items t) - -modifyTree t path@(AnchoredPath (n:r)) item = - t { items = countmap items' `seq` items' - , treeHash = NoHash } - where subtree s = modifyTree s (AnchoredPath r) item - !items' = M.insert n sub (items t) - !sub = case lookup t n of - Just (SubTree s) -> SubTree $! subtree s - Just (Stub s _) -> Stub (do x <- s - return $! subtree x) NoHash - Nothing -> SubTree $! subtree emptyTree - _ -> error $ "Modify tree at " ++ show path - -modifyTree _ (AnchoredPath []) (Just (Stub _ _)) = - error "Bug in descent in modifyTree." -modifyTree _ (AnchoredPath []) (Just (File _)) = - error "Bug in descent in modifyTree." -modifyTree _ (AnchoredPath []) Nothing = - error "Bug in descent in modifyTree." +modifyTree t_ p_ i_ = snd $ go t_ p_ i_ + where fix t unmod items' = (unmod, t { items = countmap items' `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 in descent in modifyTree." + go _ (AnchoredPath []) (Just (File _)) = + error "Bug in descent in modifyTree." + go _ (AnchoredPath []) Nothing = + error "Bug in descent in modifyTree." countmap = M.fold (\_ i -> i + 1) 0 @@ -394,3 +390,15 @@ overlay base over = Tree { items = M.fro return $ overlay b' o') NoHash (Just x, _) -> x (_, _) -> error $ "Unexpected case in overlay at get " ++ show n ++ "." + + +------ Private utilities shared among multiple functions. -------- + +unstub :: (Monad m) => TreeItem m -> m (Tree m) +unstub (Stub s _) = s +unstub (SubTree s) = return s + +isSub :: TreeItem m -> Bool +isSub (File _) = False +isSub _ = True +
_______________________________________________ darcs-users mailing list [email protected] http://lists.osuosl.org/mailman/listinfo/darcs-users
