--  Copyright (C) 2009-2011 Petr Rockai
--
--  BSD3
{-# LANGUAGE MultiParamTypeClasses #-}

-- | 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
    , explodePath, explodePaths

    -- * Files (Blobs).
    , readBlob

    -- * Filtering trees.
    , FilterTree(..), restrict

    -- * Manipulating trees.
    , modifyTree, updateTree, partiallyUpdateTree, updateSubtrees, overlay
    , addMissingHashes

    -- * Properties
    , prop_explodePath
    ) where

import Darcs.Prelude hiding ( filter )
import qualified Prelude ( filter )

import Control.Exception( catch, IOException )
import Darcs.Util.Path
import Darcs.Util.Hash

import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as B
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 )

--------------------------------
-- 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 (Int -> ItemType -> ShowS
[ItemType] -> ShowS
ItemType -> String
(Int -> ItemType -> ShowS)
-> (ItemType -> String) -> ([ItemType] -> ShowS) -> Show ItemType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ItemType] -> ShowS
$cshowList :: [ItemType] -> ShowS
show :: ItemType -> String
$cshow :: ItemType -> String
showsPrec :: Int -> ItemType -> ShowS
$cshowsPrec :: Int -> ItemType -> ShowS
Show, ItemType -> ItemType -> Bool
(ItemType -> ItemType -> Bool)
-> (ItemType -> ItemType -> Bool) -> Eq ItemType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ItemType -> ItemType -> Bool
$c/= :: ItemType -> ItemType -> Bool
== :: ItemType -> ItemType -> Bool
$c== :: ItemType -> ItemType -> Bool
Eq, Eq ItemType
Eq ItemType
-> (ItemType -> ItemType -> Ordering)
-> (ItemType -> ItemType -> Bool)
-> (ItemType -> ItemType -> Bool)
-> (ItemType -> ItemType -> Bool)
-> (ItemType -> ItemType -> Bool)
-> (ItemType -> ItemType -> ItemType)
-> (ItemType -> ItemType -> ItemType)
-> Ord ItemType
ItemType -> ItemType -> Bool
ItemType -> ItemType -> Ordering
ItemType -> ItemType -> ItemType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ItemType -> ItemType -> ItemType
$cmin :: ItemType -> ItemType -> ItemType
max :: ItemType -> ItemType -> ItemType
$cmax :: ItemType -> ItemType -> ItemType
>= :: ItemType -> ItemType -> Bool
$c>= :: ItemType -> ItemType -> Bool
> :: ItemType -> ItemType -> Bool
$c> :: ItemType -> ItemType -> Bool
<= :: ItemType -> ItemType -> Bool
$c<= :: ItemType -> ItemType -> Bool
< :: ItemType -> ItemType -> Bool
$c< :: ItemType -> ItemType -> Bool
compare :: ItemType -> ItemType -> Ordering
$ccompare :: ItemType -> ItemType -> Ordering
$cp1Ord :: Eq ItemType
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 { Tree m -> Map Name (TreeItem m)
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.
                   , Tree m -> Hash
treeHash :: !Hash }

listImmediate :: Tree m -> [(Name, TreeItem m)]
listImmediate :: Tree m -> [(Name, TreeItem m)]
listImmediate = Map Name (TreeItem m) -> [(Name, TreeItem m)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Name (TreeItem m) -> [(Name, TreeItem m)])
-> (Tree m -> Map Name (TreeItem m))
-> Tree m
-> [(Name, TreeItem m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree m -> Map Name (TreeItem m)
forall (m :: * -> *). Tree m -> Map Name (TreeItem m)
items

-- | Get a hash of a TreeItem. May be Nothing.
itemHash :: TreeItem m -> Hash
itemHash :: TreeItem m -> Hash
itemHash (File (Blob m ByteString
_ Hash
h)) = Hash
h
itemHash (SubTree Tree m
t) = Tree m -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree m
t
itemHash (Stub m (Tree m)
_ Hash
h) = Hash
h

itemType :: TreeItem m -> ItemType
itemType :: TreeItem m -> ItemType
itemType (File Blob m
_) = ItemType
BlobType
itemType (SubTree Tree m
_) = ItemType
TreeType
itemType (Stub m (Tree m)
_ Hash
_) = ItemType
TreeType

emptyTree :: Tree m
emptyTree :: Tree m
emptyTree = Tree :: forall (m :: * -> *). Map Name (TreeItem m) -> Hash -> Tree m
Tree { items :: Map Name (TreeItem m)
items = Map Name (TreeItem m)
forall k a. Map k a
M.empty
                 , treeHash :: Hash
treeHash = Hash
NoHash }

emptyBlob :: (Monad m) => Blob m
emptyBlob :: Blob m
emptyBlob = m ByteString -> Hash -> Blob m
forall (m :: * -> *). m ByteString -> Hash -> Blob m
Blob (ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
BL.empty) Hash
NoHash

makeBlob :: (Monad m) => BL.ByteString -> Blob m
makeBlob :: ByteString -> Blob m
makeBlob ByteString
str = m ByteString -> Hash -> Blob m
forall (m :: * -> *). m ByteString -> Hash -> Blob m
Blob (ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
str) (ByteString -> Hash
sha256 ByteString
str)

makeBlobBS :: (Monad m) => B.ByteString -> Blob m
makeBlobBS :: ByteString -> Blob m
makeBlobBS ByteString
s' = let s :: ByteString
s = [ByteString] -> ByteString
BL.fromChunks [ByteString
s'] in m ByteString -> Hash -> Blob m
forall (m :: * -> *). m ByteString -> Hash -> Blob m
Blob (ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
s) (ByteString -> Hash
sha256 ByteString
s)

makeTree :: [(Name,TreeItem m)] -> Tree m
makeTree :: [(Name, TreeItem m)] -> Tree m
makeTree [(Name, TreeItem m)]
l = Tree :: forall (m :: * -> *). Map Name (TreeItem m) -> Hash -> Tree m
Tree { items :: Map Name (TreeItem m)
items = [(Name, TreeItem m)] -> Map Name (TreeItem m)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, TreeItem m)]
l
                  , treeHash :: Hash
treeHash = Hash
NoHash }

makeTreeWithHash :: [(Name,TreeItem m)] -> Hash -> Tree m
makeTreeWithHash :: [(Name, TreeItem m)] -> Hash -> Tree m
makeTreeWithHash [(Name, TreeItem m)]
l Hash
h = Tree :: forall (m :: * -> *). Map Name (TreeItem m) -> Hash -> Tree m
Tree { items :: Map Name (TreeItem m)
items = [(Name, TreeItem m)] -> Map Name (TreeItem m)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, TreeItem m)]
l
                            , treeHash :: Hash
treeHash = Hash
h }

-----------------------------------
-- Tree access and lookup
--

-- | Look up a 'Tree' item (an immediate subtree or blob).
lookup :: Tree m -> Name -> Maybe (TreeItem m)
lookup :: Tree m -> Name -> Maybe (TreeItem m)
lookup Tree m
t Name
n = Name -> Map Name (TreeItem m) -> Maybe (TreeItem m)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n (Tree m -> Map Name (TreeItem m)
forall (m :: * -> *). Tree m -> Map Name (TreeItem m)
items Tree m
t)

find' :: TreeItem m -> AnchoredPath -> Maybe (TreeItem m)
find' :: TreeItem m -> AnchoredPath -> Maybe (TreeItem m)
find' TreeItem m
t (AnchoredPath []) = TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just TreeItem m
t
find' (SubTree Tree m
t) (AnchoredPath (Name
d : [Name]
rest)) =
    case Tree m -> Name -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> Name -> Maybe (TreeItem m)
lookup Tree m
t Name
d of
      Just TreeItem m
sub -> TreeItem m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *).
TreeItem m -> AnchoredPath -> Maybe (TreeItem m)
find' TreeItem m
sub ([Name] -> AnchoredPath
AnchoredPath [Name]
rest)
      Maybe (TreeItem m)
Nothing -> Maybe (TreeItem m)
forall a. Maybe a
Nothing
find' TreeItem m
_ AnchoredPath
_ = Maybe (TreeItem m)
forall a. Maybe a
Nothing

-- | Find a 'TreeItem' by its path. Gives 'Nothing' if the path is invalid.
find :: Tree m -> AnchoredPath -> Maybe (TreeItem m)
find :: Tree m -> AnchoredPath -> Maybe (TreeItem m)
find = TreeItem m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *).
TreeItem m -> AnchoredPath -> Maybe (TreeItem m)
find' (TreeItem m -> AnchoredPath -> Maybe (TreeItem m))
-> (Tree m -> TreeItem m)
-> Tree m
-> AnchoredPath
-> Maybe (TreeItem m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
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 :: Tree m -> AnchoredPath -> Maybe (Blob m)
findFile Tree m
t AnchoredPath
p = case Tree m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree m
t AnchoredPath
p of
                 Just (File Blob m
x) -> Blob m -> Maybe (Blob m)
forall a. a -> Maybe a
Just Blob m
x
                 Maybe (TreeItem m)
_ -> Maybe (Blob m)
forall a. Maybe a
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 :: Tree m -> AnchoredPath -> Maybe (Tree m)
findTree Tree m
t AnchoredPath
p = case Tree m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree m
t AnchoredPath
p of
                 Just (SubTree Tree m
x) -> Tree m -> Maybe (Tree m)
forall a. a -> Maybe a
Just Tree m
x
                 Maybe (TreeItem m)
_ -> Maybe (Tree m)
forall a. Maybe a
Nothing

-- | List all contents of a 'Tree'.
list :: Tree m -> [(AnchoredPath, TreeItem m)]
list :: Tree m -> [(AnchoredPath, TreeItem m)]
list Tree m
t_ = Tree m -> AnchoredPath -> [(AnchoredPath, TreeItem m)]
forall (m :: * -> *).
Tree m -> AnchoredPath -> [(AnchoredPath, TreeItem m)]
paths Tree m
t_ ([Name] -> AnchoredPath
AnchoredPath [])
    where paths :: Tree m -> AnchoredPath -> [(AnchoredPath, TreeItem m)]
paths Tree m
t AnchoredPath
p = [ (AnchoredPath -> Name -> AnchoredPath
appendPath AnchoredPath
p Name
n, TreeItem m
i)
                          | (Name
n,TreeItem m
i) <- Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree m
t ] [(AnchoredPath, TreeItem m)]
-> [(AnchoredPath, TreeItem m)] -> [(AnchoredPath, TreeItem m)]
forall a. [a] -> [a] -> [a]
++
                    [[(AnchoredPath, TreeItem m)]] -> [(AnchoredPath, TreeItem m)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Tree m -> AnchoredPath -> [(AnchoredPath, TreeItem m)]
paths Tree m
subt (AnchoredPath -> Name -> AnchoredPath
appendPath AnchoredPath
p Name
subn)
                             | (Name
subn, SubTree Tree m
subt) <- Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree m
t ]

-- | Like 'explodePath' but for multiple paths.
explodePaths :: Tree IO -> [AnchoredPath] -> [AnchoredPath]
explodePaths :: Tree IO -> [AnchoredPath] -> [AnchoredPath]
explodePaths Tree IO
tree [AnchoredPath]
paths = (AnchoredPath -> [AnchoredPath])
-> [AnchoredPath] -> [AnchoredPath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Tree IO -> AnchoredPath -> [AnchoredPath]
forall (m :: * -> *). Tree m -> AnchoredPath -> [AnchoredPath]
explodePath Tree IO
tree) [AnchoredPath]
paths

-- | All paths in the tree that that have the given path as prefix.
--
-- prop> explodePath t p == Prelude.filter (p `isPrefix`) (map fst (list t))
explodePath :: Tree m -> AnchoredPath -> [AnchoredPath]
explodePath :: Tree m -> AnchoredPath -> [AnchoredPath]
explodePath Tree m
tree AnchoredPath
path =
  AnchoredPath
path AnchoredPath -> [AnchoredPath] -> [AnchoredPath]
forall a. a -> [a] -> [a]
: [AnchoredPath]
-> (Tree m -> [AnchoredPath]) -> Maybe (Tree m) -> [AnchoredPath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (((AnchoredPath, TreeItem m) -> AnchoredPath)
-> [(AnchoredPath, TreeItem m)] -> [AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath -> AnchoredPath -> AnchoredPath
catPaths AnchoredPath
path (AnchoredPath -> AnchoredPath)
-> ((AnchoredPath, TreeItem m) -> AnchoredPath)
-> (AnchoredPath, TreeItem m)
-> AnchoredPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredPath, TreeItem m) -> AnchoredPath
forall a b. (a, b) -> a
fst) ([(AnchoredPath, TreeItem m)] -> [AnchoredPath])
-> (Tree m -> [(AnchoredPath, TreeItem m)])
-> Tree m
-> [AnchoredPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree m -> [(AnchoredPath, TreeItem m)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list) (Tree m -> AnchoredPath -> Maybe (Tree m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
findTree Tree m
tree AnchoredPath
path)

expandUpdate :: (Monad m) => (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m)
expandUpdate :: (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m)
expandUpdate AnchoredPath -> Tree m -> m (Tree m)
update Tree m
t_ = AnchoredPath -> Tree m -> m (Tree m)
go ([Name] -> AnchoredPath
AnchoredPath []) Tree m
t_
    where go :: AnchoredPath -> Tree m -> m (Tree m)
go AnchoredPath
path Tree m
t = do
            let subtree :: (Name, TreeItem m) -> m (Name, TreeItem m)
subtree (Name
name, TreeItem m
sub) = do Tree m
tree <- AnchoredPath -> Tree m -> m (Tree m)
go (AnchoredPath
path AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
name) (Tree m -> m (Tree m)) -> m (Tree m) -> m (Tree m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TreeItem m -> m (Tree m)
forall (m :: * -> *). Monad m => TreeItem m -> m (Tree m)
unstub TreeItem m
sub
                                         (Name, TreeItem m) -> m (Name, TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree m
tree)
            [(Name, TreeItem m)]
expanded <- ((Name, TreeItem m) -> m (Name, TreeItem m))
-> [(Name, TreeItem m)] -> m [(Name, TreeItem m)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name, TreeItem m) -> m (Name, TreeItem m)
subtree [ (Name, TreeItem m)
x | x :: (Name, TreeItem m)
x@(Name
_, TreeItem m
item) <- Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree m
t, TreeItem m -> Bool
forall (m :: * -> *). TreeItem m -> Bool
isSub TreeItem m
item ]
            let orig_map :: Map Name (TreeItem m)
orig_map = (TreeItem m -> Bool)
-> Map Name (TreeItem m) -> Map Name (TreeItem m)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool) -> (TreeItem m -> Bool) -> TreeItem m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeItem m -> Bool
forall (m :: * -> *). TreeItem m -> Bool
isSub) (Tree m -> Map Name (TreeItem m)
forall (m :: * -> *). Tree m -> Map Name (TreeItem m)
items Tree m
t)
                expanded_map :: Map Name (TreeItem m)
expanded_map = [(Name, TreeItem m)] -> Map Name (TreeItem m)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, TreeItem m)]
expanded
                tree :: Tree m
tree = Tree m
t { items :: Map Name (TreeItem m)
items = Map Name (TreeItem m)
-> Map Name (TreeItem m) -> Map Name (TreeItem m)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map Name (TreeItem m)
orig_map Map Name (TreeItem m)
expanded_map }
            AnchoredPath -> Tree m -> m (Tree m)
update AnchoredPath
path Tree m
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 :: Tree m -> m (Tree m)
expand = (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m)
forall (m :: * -> *).
Monad m =>
(AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m)
expandUpdate ((AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m))
-> (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m)
forall a b. (a -> b) -> a -> b
$ (Tree m -> m (Tree m)) -> AnchoredPath -> Tree m -> m (Tree m)
forall a b. a -> b -> a
const Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
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 :: Tree m -> AnchoredPath -> m (Tree m)
expandPath Tree m
t (AnchoredPath []) = Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree m
t
expandPath Tree m
t (AnchoredPath (Name
n:[Name]
rest)) =
  case Tree m -> Name -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> Name -> Maybe (TreeItem m)
lookup Tree m
t Name
n of
    (Just TreeItem m
item) | TreeItem m -> Bool
forall (m :: * -> *). TreeItem m -> Bool
isSub TreeItem m
item -> Tree m -> Name -> [Name] -> Tree m -> m (Tree m)
forall (m :: * -> *).
Monad m =>
Tree m -> Name -> [Name] -> Tree m -> m (Tree m)
amend Tree m
t Name
n [Name]
rest (Tree m -> m (Tree m)) -> m (Tree m) -> m (Tree m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TreeItem m -> m (Tree m)
forall (m :: * -> *). Monad m => TreeItem m -> m (Tree m)
unstub TreeItem m
item
    Maybe (TreeItem m)
_ -> Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree m
t -- fail $ "Descent error in expandPath: " ++ show path_
    where
          amend :: Tree m -> Name -> [Name] -> Tree m -> m (Tree m)
amend Tree m
t' Name
name [Name]
rest' Tree m
sub = do
            Tree m
sub' <- Tree m -> AnchoredPath -> m (Tree m)
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> m (Tree m)
expandPath Tree m
sub ([Name] -> AnchoredPath
AnchoredPath [Name]
rest')
            let tree :: Tree m
tree = Tree m
t' { items :: Map Name (TreeItem m)
items = Name
-> TreeItem m -> Map Name (TreeItem m) -> Map Name (TreeItem m)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name (Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree m
sub') (Tree m -> Map Name (TreeItem m)
forall (m :: * -> *). Tree m -> Map Name (TreeItem m)
items Tree m
t') }
            Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree m
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 :: (TreeItem IO -> IO Hash)
-> Tree IO
-> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))
checkExpand TreeItem IO -> IO Hash
hashFunc Tree IO
t = AnchoredPath
-> Tree IO
-> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))
go ([Name] -> AnchoredPath
AnchoredPath []) Tree IO
t
    where
      go :: AnchoredPath
-> Tree IO
-> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))
go AnchoredPath
path Tree IO
t_ = do
        let
            subtree :: (Name, TreeItem IO)
-> IO
     (Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO))
subtree (Name
name, TreeItem IO
sub) =
                do let here :: AnchoredPath
here = AnchoredPath
path AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
name
                   Maybe (Tree IO)
sub' <- (Tree IO -> Maybe (Tree IO)
forall a. a -> Maybe a
Just (Tree IO -> Maybe (Tree IO))
-> IO (Tree IO) -> IO (Maybe (Tree IO))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeItem IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => TreeItem m -> m (Tree m)
unstub TreeItem IO
sub) IO (Maybe (Tree IO))
-> (IOException -> IO (Maybe (Tree IO))) -> IO (Maybe (Tree IO))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> Maybe (Tree IO) -> IO (Maybe (Tree IO))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Tree IO)
forall a. Maybe a
Nothing
                   case Maybe (Tree IO)
sub' of
                     Maybe (Tree IO)
Nothing -> Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)
-> IO
     (Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)
 -> IO
      (Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)))
-> Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)
-> IO
     (Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO))
forall a b. (a -> b) -> a -> b
$ [(AnchoredPath, Hash, Maybe Hash)]
-> Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)
forall a b. a -> Either a b
Left [(AnchoredPath
here, Tree IO -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree IO
t_, Maybe Hash
forall a. Maybe a
Nothing)]
                     Just Tree IO
sub'' -> do
                       Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
treeOrTrouble <- AnchoredPath
-> Tree IO
-> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))
go (AnchoredPath
path AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
name) Tree IO
sub''
                       Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)
-> IO
     (Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)
 -> IO
      (Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)))
-> Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)
-> IO
     (Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO))
forall a b. (a -> b) -> a -> b
$ case Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
treeOrTrouble of
                              Left [(AnchoredPath, Hash, Maybe Hash)]
problems -> [(AnchoredPath, Hash, Maybe Hash)]
-> Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)
forall a b. a -> Either a b
Left [(AnchoredPath, Hash, Maybe Hash)]
problems
                              Right Tree IO
tree -> (Name, TreeItem IO)
-> Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)
forall a b. b -> Either a b
Right (Name
name, Tree IO -> TreeItem IO
forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree IO
tree)
            badBlob :: (a, TreeItem IO) -> IO Bool
badBlob (a
_, f :: TreeItem IO
f@(File (Blob IO ByteString
_ Hash
h))) =
              (Hash -> Bool) -> IO Hash -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
/= Hash
h) (TreeItem IO -> IO Hash
hashFunc TreeItem IO
f IO Hash -> (IOException -> IO Hash) -> IO Hash
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOException
_ :: IOException) -> Hash -> IO Hash
forall (m :: * -> *) a. Monad m => a -> m a
return Hash
NoHash))
            badBlob (a, TreeItem IO)
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            render :: (Name, TreeItem IO) -> IO (AnchoredPath, Hash, Maybe Hash)
render (Name
name, f :: TreeItem IO
f@(File (Blob IO ByteString
_ Hash
h))) = do
              Maybe Hash
h' <- (Hash -> Maybe Hash
forall a. a -> Maybe a
Just (Hash -> Maybe Hash) -> IO Hash -> IO (Maybe Hash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeItem IO -> IO Hash
hashFunc TreeItem IO
f) IO (Maybe Hash)
-> (IOException -> IO (Maybe Hash)) -> IO (Maybe Hash)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> Maybe Hash -> IO (Maybe Hash)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Hash
forall a. Maybe a
Nothing
              (AnchoredPath, Hash, Maybe Hash)
-> IO (AnchoredPath, Hash, Maybe Hash)
forall (m :: * -> *) a. Monad m => a -> m a
return (AnchoredPath
path AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
name, Hash
h, Maybe Hash
h')
            render (Name
name, TreeItem IO
_) = (AnchoredPath, Hash, Maybe Hash)
-> IO (AnchoredPath, Hash, Maybe Hash)
forall (m :: * -> *) a. Monad m => a -> m a
return (AnchoredPath
path AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
name, Hash
NoHash, Maybe Hash
forall a. Maybe a
Nothing)
        [Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)]
subs <- ((Name, TreeItem IO)
 -> IO
      (Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)))
-> [(Name, TreeItem IO)]
-> IO
     [Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name, TreeItem IO)
-> IO
     (Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO))
subtree [ (Name, TreeItem IO)
x | x :: (Name, TreeItem IO)
x@(Name
_, TreeItem IO
item) <- Tree IO -> [(Name, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree IO
t_, TreeItem IO -> Bool
forall (m :: * -> *). TreeItem m -> Bool
isSub TreeItem IO
item ]
        [(AnchoredPath, Hash, Maybe Hash)]
badBlobs <- ((Name, TreeItem IO) -> IO Bool)
-> [(Name, TreeItem IO)] -> IO [(Name, TreeItem IO)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Name, TreeItem IO) -> IO Bool
forall a. (a, TreeItem IO) -> IO Bool
badBlob (Tree IO -> [(Name, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree IO
t) IO [(Name, TreeItem IO)]
-> ([(Name, TreeItem IO)] -> IO [(AnchoredPath, Hash, Maybe Hash)])
-> IO [(AnchoredPath, Hash, Maybe Hash)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Name, TreeItem IO) -> IO (AnchoredPath, Hash, Maybe Hash))
-> [(Name, TreeItem IO)] -> IO [(AnchoredPath, Hash, Maybe Hash)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name, TreeItem IO) -> IO (AnchoredPath, Hash, Maybe Hash)
render
        let problems :: [(AnchoredPath, Hash, Maybe Hash)]
problems = [(AnchoredPath, Hash, Maybe Hash)]
badBlobs [(AnchoredPath, Hash, Maybe Hash)]
-> [(AnchoredPath, Hash, Maybe Hash)]
-> [(AnchoredPath, Hash, Maybe Hash)]
forall a. [a] -> [a] -> [a]
++ [[(AnchoredPath, Hash, Maybe Hash)]]
-> [(AnchoredPath, Hash, Maybe Hash)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)]
-> [[(AnchoredPath, Hash, Maybe Hash)]]
forall a b. [Either a b] -> [a]
lefts [Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)]
subs)
        if [(AnchoredPath, Hash, Maybe Hash)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(AnchoredPath, Hash, Maybe Hash)]
problems
         then do
           let orig_map :: Map Name (TreeItem IO)
orig_map = (TreeItem IO -> Bool)
-> Map Name (TreeItem IO) -> Map Name (TreeItem IO)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool) -> (TreeItem IO -> Bool) -> TreeItem IO -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeItem IO -> Bool
forall (m :: * -> *). TreeItem m -> Bool
isSub) (Tree IO -> Map Name (TreeItem IO)
forall (m :: * -> *). Tree m -> Map Name (TreeItem m)
items Tree IO
t)
               expanded_map :: Map Name (TreeItem IO)
expanded_map = [(Name, TreeItem IO)] -> Map Name (TreeItem IO)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, TreeItem IO)] -> Map Name (TreeItem IO))
-> [(Name, TreeItem IO)] -> Map Name (TreeItem IO)
forall a b. (a -> b) -> a -> b
$ [Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)]
-> [(Name, TreeItem IO)]
forall a b. [Either a b] -> [b]
rights [Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO)]
subs
               tree :: Tree IO
tree = Tree IO
t_ {items :: Map Name (TreeItem IO)
items = Map Name (TreeItem IO)
orig_map Map Name (TreeItem IO)
-> Map Name (TreeItem IO) -> Map Name (TreeItem IO)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Name (TreeItem IO)
expanded_map}
           Hash
h' <- TreeItem IO -> IO Hash
hashFunc (Tree IO -> TreeItem IO
forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree IO
t_)
           if Hash
h' Hash -> Hash -> Bool
`match` Tree IO -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree IO
t_
            then Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
-> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
 -> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)))
-> Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
-> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))
forall a b. (a -> b) -> a -> b
$ Tree IO -> Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
forall a b. b -> Either a b
Right Tree IO
tree
            else Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
-> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
 -> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)))
-> Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
-> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))
forall a b. (a -> b) -> a -> b
$ [(AnchoredPath, Hash, Maybe Hash)]
-> Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
forall a b. a -> Either a b
Left [(AnchoredPath
path, Tree IO -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree IO
t_, Hash -> Maybe Hash
forall a. a -> Maybe a
Just Hash
h')]
         else Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
-> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
 -> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)))
-> Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
-> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))
forall a b. (a -> b) -> a -> b
$ [(AnchoredPath, Hash, Maybe Hash)]
-> Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO)
forall a b. a -> Either a b
Left [(AnchoredPath, Hash, Maybe Hash)]
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 :: (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> Tree m
filter AnchoredPath -> TreeItem m -> Bool
predicate Tree m
t_ = Tree m -> AnchoredPath -> Tree m
filter' Tree m
t_ ([Name] -> AnchoredPath
AnchoredPath [])
        where filter' :: Tree m -> AnchoredPath -> Tree m
filter' Tree m
t AnchoredPath
path = Tree m
t { items :: Map Name (TreeItem m)
items = (Name -> TreeItem m -> Maybe (TreeItem m))
-> Map Name (TreeItem m) -> Map Name (TreeItem m)
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
M.mapMaybeWithKey (AnchoredPath -> Name -> TreeItem m -> Maybe (TreeItem m)
wibble AnchoredPath
path) (Map Name (TreeItem m) -> Map Name (TreeItem m))
-> Map Name (TreeItem m) -> Map Name (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Tree m -> Map Name (TreeItem m)
forall (m :: * -> *). Tree m -> Map Name (TreeItem m)
items Tree m
t }
              wibble :: AnchoredPath -> Name -> TreeItem m -> Maybe (TreeItem m)
wibble AnchoredPath
path Name
name TreeItem m
item =
                  let npath :: AnchoredPath
npath = AnchoredPath
path AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
name in
                      if AnchoredPath -> TreeItem m -> Bool
predicate AnchoredPath
npath TreeItem m
item
                         then TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just (TreeItem m -> Maybe (TreeItem m))
-> TreeItem m -> Maybe (TreeItem m)
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> TreeItem m -> TreeItem m
filterSub AnchoredPath
npath TreeItem m
item
                         else Maybe (TreeItem m)
forall a. Maybe a
Nothing
              filterSub :: AnchoredPath -> TreeItem m -> TreeItem m
filterSub AnchoredPath
npath (SubTree Tree m
t) = Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree m -> TreeItem m) -> Tree m -> TreeItem m
forall a b. (a -> b) -> a -> b
$ Tree m -> AnchoredPath -> Tree m
filter' Tree m
t AnchoredPath
npath
              filterSub AnchoredPath
npath (Stub m (Tree m)
stub Hash
h) =
                  m (Tree m) -> Hash -> TreeItem m
forall (m :: * -> *). m (Tree m) -> Hash -> TreeItem m
Stub (do Tree m
x <- m (Tree m)
stub
                           Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree m -> m (Tree m)) -> Tree m -> m (Tree m)
forall a b. (a -> b) -> a -> b
$ Tree m -> AnchoredPath -> Tree m
filter' Tree m
x AnchoredPath
npath) Hash
h
              filterSub AnchoredPath
_ TreeItem m
x = TreeItem m
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) => Tree n -> t m -> t m
restrict :: Tree n -> t m -> t m
restrict Tree n
guide t m
tree = (AnchoredPath -> TreeItem m -> Bool) -> t m -> t m
forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
filter AnchoredPath -> TreeItem m -> Bool
forall (m :: * -> *). AnchoredPath -> TreeItem m -> Bool
accept t m
tree
    where accept :: AnchoredPath -> TreeItem m -> Bool
accept AnchoredPath
path TreeItem m
item =
              case (Tree n -> AnchoredPath -> Maybe (TreeItem n)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree n
guide AnchoredPath
path, TreeItem m
item) of
                (Just (SubTree Tree n
_), SubTree Tree m
_) -> Bool
True
                (Just (SubTree Tree n
_), Stub m (Tree m)
_ Hash
_) -> Bool
True
                (Just (File Blob n
_), File Blob m
_) -> Bool
True
                (Just (Stub n (Tree n)
_ Hash
_), TreeItem m
_) ->
                    String -> Bool
forall a. HasCallStack => String -> a
error String
"*sulk* Go away, you, you precondition violator!"
                (Maybe (TreeItem n)
_, TreeItem m
_) -> Bool
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 m -> m ByteString
readBlob (Blob m ByteString
r Hash
_) = m ByteString
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 :: (AnchoredPath -> Blob m -> Blob m -> a) -> Tree m -> Tree m -> [a]
zipCommonFiles AnchoredPath -> Blob m -> Blob m -> a
f Tree m
a Tree m
b = [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes [ (Blob m -> Blob m -> a) -> Blob m -> Blob m -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (AnchoredPath -> Blob m -> Blob m -> a
f AnchoredPath
p) Blob m
x (Blob m -> a) -> Maybe (Blob m) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Tree m -> AnchoredPath -> Maybe (Blob m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Blob m)
findFile Tree m
a AnchoredPath
p
                                   | (AnchoredPath
p, File Blob m
x) <- Tree m -> [(AnchoredPath, TreeItem m)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree m
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 :: (AnchoredPath -> Maybe (Blob m) -> Maybe (Blob m) -> a)
-> Tree m -> Tree m -> [a]
zipFiles AnchoredPath -> Maybe (Blob m) -> Maybe (Blob m) -> a
f Tree m
a Tree m
b = [ AnchoredPath -> Maybe (Blob m) -> Maybe (Blob m) -> a
f AnchoredPath
p (Tree m -> AnchoredPath -> Maybe (Blob m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Blob m)
findFile Tree m
a AnchoredPath
p) (Tree m -> AnchoredPath -> Maybe (Blob m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Blob m)
findFile Tree m
b AnchoredPath
p)
                   | AnchoredPath
p <- Tree m -> [AnchoredPath]
forall (m :: * -> *). Tree m -> [AnchoredPath]
paths Tree m
a [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
`sortedUnion` Tree m -> [AnchoredPath]
forall (m :: * -> *). Tree m -> [AnchoredPath]
paths Tree m
b ]
    where paths :: Tree m -> [AnchoredPath]
paths Tree m
t = [AnchoredPath] -> [AnchoredPath]
forall a. Ord a => [a] -> [a]
sort [ AnchoredPath
p | (AnchoredPath
p, File Blob m
_) <- Tree m -> [(AnchoredPath, TreeItem m)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree m
t ]

zipTrees :: (AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a)
         -> Tree m -> Tree m -> [a]
zipTrees :: (AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a)
-> Tree m -> Tree m -> [a]
zipTrees AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a
f Tree m
a Tree m
b = [ AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a
f AnchoredPath
p (Tree m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree m
a AnchoredPath
p) (Tree m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree m
b AnchoredPath
p)
                   | AnchoredPath
p <- [AnchoredPath] -> [AnchoredPath]
forall a. [a] -> [a]
reverse (Tree m -> [AnchoredPath]
forall (m :: * -> *). Tree m -> [AnchoredPath]
paths Tree m
a [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
`sortedUnion` Tree m -> [AnchoredPath]
forall (m :: * -> *). Tree m -> [AnchoredPath]
paths Tree m
b) ]
    where paths :: Tree m -> [AnchoredPath]
paths Tree m
t = [AnchoredPath] -> [AnchoredPath]
forall a. Ord a => [a] -> [a]
sort [ AnchoredPath
p | (AnchoredPath
p, TreeItem m
_) <- Tree m -> [(AnchoredPath, TreeItem m)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree m
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 :: [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
sortedUnion [] [AnchoredPath]
ys = [AnchoredPath]
ys
sortedUnion [AnchoredPath]
xs [] = [AnchoredPath]
xs
sortedUnion a :: [AnchoredPath]
a@(AnchoredPath
x:[AnchoredPath]
xs) b :: [AnchoredPath]
b@(AnchoredPath
y:[AnchoredPath]
ys) = case AnchoredPath -> AnchoredPath -> Ordering
forall a. Ord a => a -> a -> Ordering
compare AnchoredPath
x AnchoredPath
y of
                                Ordering
LT -> AnchoredPath
x AnchoredPath -> [AnchoredPath] -> [AnchoredPath]
forall a. a -> [a] -> [a]
: [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
sortedUnion [AnchoredPath]
xs [AnchoredPath]
b
                                Ordering
EQ -> AnchoredPath
x AnchoredPath -> [AnchoredPath] -> [AnchoredPath]
forall a. a -> [a] -> [a]
: [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
sortedUnion [AnchoredPath]
xs [AnchoredPath]
ys
                                Ordering
GT -> AnchoredPath
y AnchoredPath -> [AnchoredPath] -> [AnchoredPath]
forall a. a -> [a] -> [a]
: [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
sortedUnion [AnchoredPath]
a [AnchoredPath]
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. (Monad m) => Tree m -> Tree m -> m (Tree m, Tree m)
diffTrees :: Tree m -> Tree m -> m (Tree m, Tree m)
diffTrees Tree m
left Tree m
right =
            if Tree m -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree m
left Hash -> Hash -> Bool
`match` Tree m -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree m
right
               then (Tree m, Tree m) -> m (Tree m, Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree m
forall (m :: * -> *). Tree m
emptyTree, Tree m
forall (m :: * -> *). Tree m
emptyTree)
               else Tree m -> Tree m -> m (Tree m, Tree m)
diff Tree m
left Tree m
right
  where isFile :: TreeItem m -> Bool
isFile (File Blob m
_) = Bool
True
        isFile TreeItem m
_ = Bool
False
        notFile :: TreeItem m -> Bool
notFile = Bool -> Bool
not (Bool -> Bool) -> (TreeItem m -> Bool) -> TreeItem m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeItem m -> Bool
forall (m :: * -> *). TreeItem m -> Bool
isFile
        isEmpty :: Tree m -> Bool
isEmpty = [(Name, TreeItem m)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(Name, TreeItem m)] -> Bool)
-> (Tree m -> [(Name, TreeItem m)]) -> Tree m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate
        subtree :: TreeItem m -> m (Tree m)
        subtree :: TreeItem m -> m (Tree m)
subtree (Stub m (Tree m)
x Hash
_) = m (Tree m)
x
        subtree (SubTree Tree m
x) = Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree m
x
        subtree (File Blob m
_) = String -> m (Tree m)
forall a. HasCallStack => String -> a
error String
"diffTrees tried to descend a File as a subtree"
        maybeUnfold :: TreeItem m -> m (TreeItem m)
maybeUnfold (Stub m (Tree m)
x Hash
_) = Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree m -> TreeItem m) -> m (Tree m) -> m (TreeItem m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (m (Tree m)
x m (Tree m) -> (Tree m -> m (Tree m)) -> m (Tree m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tree m -> m (Tree m)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand)
        maybeUnfold (SubTree Tree m
x) = Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree m -> TreeItem m) -> m (Tree m) -> m (TreeItem m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Tree m -> m (Tree m)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand Tree m
x
        maybeUnfold TreeItem m
i = TreeItem m -> m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return TreeItem m
i
        immediateN :: Tree m -> [Name]
immediateN Tree m
t = [ Name
n | (Name
n, TreeItem m
_) <- Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree m
t ]
        diff :: Tree m -> Tree m -> m (Tree m, Tree m)
diff Tree m
left' Tree m
right' = do
          [(Name, Maybe (TreeItem m), Maybe (TreeItem m))]
is <- [m (Name, Maybe (TreeItem m), Maybe (TreeItem m))]
-> m [(Name, Maybe (TreeItem m), Maybe (TreeItem m))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
                   case (Tree m -> Name -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> Name -> Maybe (TreeItem m)
lookup Tree m
left' Name
n, Tree m -> Name -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> Name -> Maybe (TreeItem m)
lookup Tree m
right' Name
n) of
                     (Just TreeItem m
l, Maybe (TreeItem m)
Nothing) -> do
                       TreeItem m
l' <- TreeItem m -> m (TreeItem m)
forall (m :: * -> *). Monad m => TreeItem m -> m (TreeItem m)
maybeUnfold TreeItem m
l
                       (Name, Maybe (TreeItem m), Maybe (TreeItem m))
-> m (Name, Maybe (TreeItem m), Maybe (TreeItem m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just TreeItem m
l', Maybe (TreeItem m)
forall a. Maybe a
Nothing)
                     (Maybe (TreeItem m)
Nothing, Just TreeItem m
r) -> do
                       TreeItem m
r' <- TreeItem m -> m (TreeItem m)
forall (m :: * -> *). Monad m => TreeItem m -> m (TreeItem m)
maybeUnfold TreeItem m
r
                       (Name, Maybe (TreeItem m), Maybe (TreeItem m))
-> m (Name, Maybe (TreeItem m), Maybe (TreeItem m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Maybe (TreeItem m)
forall a. Maybe a
Nothing, TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just TreeItem m
r')
                     (Just TreeItem m
l, Just TreeItem m
r)
                         | TreeItem m -> Hash
forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
l Hash -> Hash -> Bool
`match` TreeItem m -> Hash
forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
r ->
                             (Name, Maybe (TreeItem m), Maybe (TreeItem m))
-> m (Name, Maybe (TreeItem m), Maybe (TreeItem m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Maybe (TreeItem m)
forall a. Maybe a
Nothing, Maybe (TreeItem m)
forall a. Maybe a
Nothing)
                         | TreeItem m -> Bool
forall (m :: * -> *). TreeItem m -> Bool
notFile TreeItem m
l Bool -> Bool -> Bool
&& TreeItem m -> Bool
forall (m :: * -> *). TreeItem m -> Bool
notFile TreeItem m
r ->
                             do Tree m
x <- TreeItem m -> m (Tree m)
subtree TreeItem m
l
                                Tree m
y <- TreeItem m -> m (Tree m)
subtree TreeItem m
r
                                (Tree m
x', Tree m
y') <- Tree m -> Tree m -> m (Tree m, Tree m)
forall (m :: * -> *).
Monad m =>
Tree m -> Tree m -> m (Tree m, Tree m)
diffTrees Tree m
x Tree m
y
                                if Tree m -> Bool
forall (m :: * -> *). Tree m -> Bool
isEmpty Tree m
x' Bool -> Bool -> Bool
&& Tree m -> Bool
forall (m :: * -> *). Tree m -> Bool
isEmpty Tree m
y'
                                   then (Name, Maybe (TreeItem m), Maybe (TreeItem m))
-> m (Name, Maybe (TreeItem m), Maybe (TreeItem m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Maybe (TreeItem m)
forall a. Maybe a
Nothing, Maybe (TreeItem m)
forall a. Maybe a
Nothing)
                                   else (Name, Maybe (TreeItem m), Maybe (TreeItem m))
-> m (Name, Maybe (TreeItem m), Maybe (TreeItem m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just (TreeItem m -> Maybe (TreeItem m))
-> TreeItem m -> Maybe (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree m
x', TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just (TreeItem m -> Maybe (TreeItem m))
-> TreeItem m -> Maybe (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree m
y')
                         | TreeItem m -> Bool
forall (m :: * -> *). TreeItem m -> Bool
isFile TreeItem m
l Bool -> Bool -> Bool
&& TreeItem m -> Bool
forall (m :: * -> *). TreeItem m -> Bool
isFile TreeItem m
r ->
                             (Name, Maybe (TreeItem m), Maybe (TreeItem m))
-> m (Name, Maybe (TreeItem m), Maybe (TreeItem m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just TreeItem m
l, TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just TreeItem m
r)
                         | Bool
otherwise ->
                             do TreeItem m
l' <- TreeItem m -> m (TreeItem m)
forall (m :: * -> *). Monad m => TreeItem m -> m (TreeItem m)
maybeUnfold TreeItem m
l
                                TreeItem m
r' <- TreeItem m -> m (TreeItem m)
forall (m :: * -> *). Monad m => TreeItem m -> m (TreeItem m)
maybeUnfold TreeItem m
r
                                (Name, Maybe (TreeItem m), Maybe (TreeItem m))
-> m (Name, Maybe (TreeItem m), Maybe (TreeItem m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just TreeItem m
l', TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just TreeItem m
r')
                     (Maybe (TreeItem m), Maybe (TreeItem m))
_ -> String -> m (Name, Maybe (TreeItem m), Maybe (TreeItem m))
forall a. HasCallStack => String -> a
error String
"n lookups failed"
                   | Name
n <- Tree m -> [Name]
forall (m :: * -> *). Tree m -> [Name]
immediateN Tree m
left' [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` Tree m -> [Name]
forall (m :: * -> *). Tree m -> [Name]
immediateN Tree m
right' ]
          let is_l :: [(Name, TreeItem m)]
is_l = [ (Name
n, TreeItem m
l) | (Name
n, Just TreeItem m
l, Maybe (TreeItem m)
_) <- [(Name, Maybe (TreeItem m), Maybe (TreeItem m))]
is ]
              is_r :: [(Name, TreeItem m)]
is_r = [ (Name
n, TreeItem m
r) | (Name
n, Maybe (TreeItem m)
_, Just TreeItem m
r) <- [(Name, Maybe (TreeItem m), Maybe (TreeItem m))]
is ]
          (Tree m, Tree m) -> m (Tree m, Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, TreeItem m)] -> Tree m
forall (m :: * -> *). [(Name, TreeItem m)] -> Tree m
makeTree [(Name, TreeItem m)]
is_l, [(Name, TreeItem m)] -> Tree m
forall (m :: * -> *). [(Name, TreeItem m)] -> Tree m
makeTree [(Name, TreeItem m)]
is_r)

-- | Modify a Tree (by replacing, or removing or adding items).
modifyTree :: (Monad m) => Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
modifyTree :: Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
modifyTree Tree m
t_ AnchoredPath
p_ Maybe (TreeItem m)
i_ = (Bool, Tree m) -> Tree m
forall a b. (a, b) -> b
snd ((Bool, Tree m) -> Tree m) -> (Bool, Tree m) -> Tree m
forall a b. (a -> b) -> a -> b
$ Tree m -> AnchoredPath -> Maybe (TreeItem m) -> (Bool, Tree m)
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> (Bool, Tree m)
go Tree m
t_ AnchoredPath
p_ Maybe (TreeItem m)
i_
  where fix :: Tree m -> Bool -> Map Name (TreeItem m) -> (Bool, Tree m)
fix Tree m
t Bool
unmod Map Name (TreeItem m)
items' = (Bool
unmod, Tree m
t { items :: Map Name (TreeItem m)
items = (Map Name (TreeItem m) -> Int
forall a k. Map k a -> Int
countmap Map Name (TreeItem m)
items':: Int) Int -> Map Name (TreeItem m) -> Map Name (TreeItem m)
`seq` Map Name (TreeItem m)
items'
                                       , treeHash :: Hash
treeHash = if Bool
unmod then Tree m -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree m
t else Hash
NoHash })

        go :: Tree m -> AnchoredPath -> Maybe (TreeItem m) -> (Bool, Tree m)
go Tree m
t (AnchoredPath []) (Just (SubTree Tree m
sub)) = (Tree m -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree m
t Hash -> Hash -> Bool
`match` Tree m -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree m
sub, Tree m
sub)

        go Tree m
t (AnchoredPath [Name
n]) (Just TreeItem m
item) = Tree m -> Bool -> Map Name (TreeItem m) -> (Bool, Tree m)
forall (m :: * -> *) (m :: * -> *).
Tree m -> Bool -> Map Name (TreeItem m) -> (Bool, Tree m)
fix Tree m
t Bool
unmod Map Name (TreeItem m)
items'
            where !items' :: Map Name (TreeItem m)
items' = Name
-> TreeItem m -> Map Name (TreeItem m) -> Map Name (TreeItem m)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
n TreeItem m
item (Tree m -> Map Name (TreeItem m)
forall (m :: * -> *). Tree m -> Map Name (TreeItem m)
items Tree m
t)
                  !unmod :: Bool
unmod = TreeItem m -> Hash
forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
item Hash -> Hash -> Bool
`match` case Tree m -> Name -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> Name -> Maybe (TreeItem m)
lookup Tree m
t Name
n of
                                             Maybe (TreeItem m)
Nothing -> Hash
NoHash
                                             Just TreeItem m
i -> TreeItem m -> Hash
forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i

        go Tree m
t (AnchoredPath [Name
n]) Maybe (TreeItem m)
Nothing = Tree m -> Bool -> Map Name (TreeItem m) -> (Bool, Tree m)
forall (m :: * -> *) (m :: * -> *).
Tree m -> Bool -> Map Name (TreeItem m) -> (Bool, Tree m)
fix Tree m
t Bool
unmod Map Name (TreeItem m)
items'
            where !items' :: Map Name (TreeItem m)
items' = Name -> Map Name (TreeItem m) -> Map Name (TreeItem m)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Name
n (Tree m -> Map Name (TreeItem m)
forall (m :: * -> *). Tree m -> Map Name (TreeItem m)
items Tree m
t)
                  !unmod :: Bool
unmod = Maybe (TreeItem m) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (TreeItem m) -> Bool) -> Maybe (TreeItem m) -> Bool
forall a b. (a -> b) -> a -> b
$ Tree m -> Name -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> Name -> Maybe (TreeItem m)
lookup Tree m
t Name
n

        go Tree m
t path :: AnchoredPath
path@(AnchoredPath (Name
n:[Name]
r)) Maybe (TreeItem m)
item = Tree m -> Bool -> Map Name (TreeItem m) -> (Bool, Tree m)
forall (m :: * -> *) (m :: * -> *).
Tree m -> Bool -> Map Name (TreeItem m) -> (Bool, Tree m)
fix Tree m
t Bool
unmod Map Name (TreeItem m)
items'
            where subtree :: Tree m -> (Bool, Tree m)
subtree Tree m
s = Tree m -> AnchoredPath -> Maybe (TreeItem m) -> (Bool, Tree m)
go Tree m
s ([Name] -> AnchoredPath
AnchoredPath [Name]
r) Maybe (TreeItem m)
item
                  !items' :: Map Name (TreeItem m)
items' = Name
-> TreeItem m -> Map Name (TreeItem m) -> Map Name (TreeItem m)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
n TreeItem m
sub (Tree m -> Map Name (TreeItem m)
forall (m :: * -> *). Tree m -> Map Name (TreeItem m)
items Tree m
t)
                  !sub :: TreeItem m
sub = (Bool, TreeItem m) -> TreeItem m
forall a b. (a, b) -> b
snd (Bool, TreeItem m)
sub'
                  !unmod :: Bool
unmod = (Bool, TreeItem m) -> Bool
forall a b. (a, b) -> a
fst (Bool, TreeItem m)
sub'
                  !sub' :: (Bool, TreeItem m)
sub' = case Tree m -> Name -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> Name -> Maybe (TreeItem m)
lookup Tree m
t Name
n of
                    Just (SubTree Tree m
s) -> let (Bool
mod', Tree m
sub'') = Tree m -> (Bool, Tree m)
subtree Tree m
s in (Bool
mod', Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree m
sub'')
                    Just (Stub m (Tree m)
s Hash
_) -> (Bool
False, m (Tree m) -> Hash -> TreeItem m
forall (m :: * -> *). m (Tree m) -> Hash -> TreeItem m
Stub (do Tree m
x <- m (Tree m)
s
                                                        Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree m -> m (Tree m)) -> Tree m -> m (Tree m)
forall a b. (a -> b) -> a -> b
$! (Bool, Tree m) -> Tree m
forall a b. (a, b) -> b
snd ((Bool, Tree m) -> Tree m) -> (Bool, Tree m) -> Tree m
forall a b. (a -> b) -> a -> b
$! Tree m -> (Bool, Tree m)
subtree Tree m
x) Hash
NoHash)
                    Maybe (TreeItem m)
Nothing -> (Bool
False, Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree m -> TreeItem m) -> Tree m -> TreeItem m
forall a b. (a -> b) -> a -> b
$! (Bool, Tree m) -> Tree m
forall a b. (a, b) -> b
snd ((Bool, Tree m) -> Tree m) -> (Bool, Tree m) -> Tree m
forall a b. (a -> b) -> a -> b
$! Tree m -> (Bool, Tree m)
subtree Tree m
forall (m :: * -> *). Tree m
emptyTree)
                    Maybe (TreeItem m)
_ -> String -> (Bool, TreeItem m)
forall a. HasCallStack => String -> a
error (String -> (Bool, TreeItem m)) -> String -> (Bool, TreeItem m)
forall a b. (a -> b) -> a -> b
$ String
"Modify tree at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
forall a. Show a => a -> String
show AnchoredPath
path

        go Tree m
_ (AnchoredPath []) (Just (Stub m (Tree m)
_ Hash
_)) =
            String -> (Bool, Tree m)
forall a. HasCallStack => String -> a
error (String -> (Bool, Tree m)) -> String -> (Bool, Tree m)
forall a b. (a -> b) -> a -> b
$ String
"descending in modifyTree, case = (Just (Stub _ _)), path = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
forall a. Show a => a -> String
show AnchoredPath
p_
        go Tree m
_ (AnchoredPath []) (Just (File Blob m
_)) =
            String -> (Bool, Tree m)
forall a. HasCallStack => String -> a
error (String -> (Bool, Tree m)) -> String -> (Bool, Tree m)
forall a b. (a -> b) -> a -> b
$ String
"descending in modifyTree, case = (Just (File _)), path = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
forall a. Show a => a -> String
show AnchoredPath
p_
        go Tree m
_ (AnchoredPath []) Maybe (TreeItem m)
Nothing =
            String -> (Bool, Tree m)
forall a. HasCallStack => String -> a
error (String -> (Bool, Tree m)) -> String -> (Bool, Tree m)
forall a b. (a -> b) -> a -> b
$ String
"descending in modifyTree, case = Nothing, path = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
forall a. Show a => a -> String
show AnchoredPath
p_

countmap :: forall a k. M.Map k a -> Int
countmap :: Map k a -> Int
countmap = (a -> Int -> Int) -> Int -> Map k a -> Int
forall a b k. (a -> b -> b) -> b -> Map k a -> b
M.foldr (\a
_ Int
i -> Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
0

updateSubtrees :: (Tree m -> Tree m) -> Tree m -> Tree m
updateSubtrees :: (Tree m -> Tree m) -> Tree m -> Tree m
updateSubtrees Tree m -> Tree m
fun Tree m
t =
    Tree m -> Tree m
fun (Tree m -> Tree m) -> Tree m -> Tree m
forall a b. (a -> b) -> a -> b
$ Tree m
t { items :: Map Name (TreeItem m)
items = (Name -> TreeItem m -> TreeItem m)
-> Map Name (TreeItem m) -> Map Name (TreeItem m)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey (((Name, TreeItem m) -> TreeItem m)
-> Name -> TreeItem m -> TreeItem m
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((Name, TreeItem m) -> TreeItem m)
 -> Name -> TreeItem m -> TreeItem m)
-> ((Name, TreeItem m) -> TreeItem m)
-> Name
-> TreeItem m
-> TreeItem m
forall a b. (a -> b) -> a -> b
$ (Name, TreeItem m) -> TreeItem m
forall a b. (a, b) -> b
snd ((Name, TreeItem m) -> TreeItem m)
-> ((Name, TreeItem m) -> (Name, TreeItem m))
-> (Name, TreeItem m)
-> TreeItem m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, TreeItem m) -> (Name, TreeItem m)
forall a. (a, TreeItem m) -> (a, TreeItem m)
update) (Map Name (TreeItem m) -> Map Name (TreeItem m))
-> Map Name (TreeItem m) -> Map Name (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Tree m -> Map Name (TreeItem m)
forall (m :: * -> *). Tree m -> Map Name (TreeItem m)
items Tree m
t
            , treeHash :: Hash
treeHash = Hash
NoHash }
  where update :: (a, TreeItem m) -> (a, TreeItem m)
update (a
k, SubTree Tree m
s) = (a
k, Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree m -> TreeItem m) -> Tree m -> TreeItem m
forall a b. (a -> b) -> a -> b
$ (Tree m -> Tree m) -> Tree m -> Tree m
forall (m :: * -> *). (Tree m -> Tree m) -> Tree m -> Tree m
updateSubtrees Tree m -> Tree m
fun Tree m
s)
        update (a
k, File Blob m
f) = (a
k, Blob m -> TreeItem m
forall (m :: * -> *). Blob m -> TreeItem m
File Blob m
f)
        update (a
_, Stub m (Tree m)
_ Hash
_) = String -> (a, TreeItem m)
forall a. HasCallStack => String -> a
error String
"Stubs not supported in updateTreePostorder"

-- | Does /not/ expand the tree.
updateTree :: (Monad m) => (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m)
updateTree :: (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m)
updateTree TreeItem m -> m (TreeItem m)
fun Tree m
t = (TreeItem m -> m (TreeItem m))
-> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m)
forall (m :: * -> *).
Monad m =>
(TreeItem m -> m (TreeItem m))
-> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m)
partiallyUpdateTree TreeItem m -> m (TreeItem m)
fun (\AnchoredPath
_ TreeItem m
_ -> Bool
True) Tree m
t

-- | Does /not/ expand the tree.
partiallyUpdateTree :: (Monad m) => (TreeItem m -> m (TreeItem m))
                       -> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m)
partiallyUpdateTree :: (TreeItem m -> m (TreeItem m))
-> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m)
partiallyUpdateTree TreeItem m -> m (TreeItem m)
fun AnchoredPath -> TreeItem m -> Bool
predi Tree m
t' = AnchoredPath -> Tree m -> m (Tree m)
go ([Name] -> AnchoredPath
AnchoredPath []) Tree m
t'
  where go :: AnchoredPath -> Tree m -> m (Tree m)
go AnchoredPath
path Tree m
t = do
          Map Name (TreeItem m)
items' <- [(Name, TreeItem m)] -> Map Name (TreeItem m)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, TreeItem m)] -> Map Name (TreeItem m))
-> m [(Name, TreeItem m)] -> m (Map Name (TreeItem m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, TreeItem m) -> m (Name, TreeItem m))
-> [(Name, TreeItem m)] -> m [(Name, TreeItem m)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AnchoredPath -> (Name, TreeItem m) -> m (Name, TreeItem m)
maybeupdate AnchoredPath
path) (Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree m
t)
          TreeItem m
subtree <- TreeItem m -> m (TreeItem m)
fun (TreeItem m -> m (TreeItem m))
-> (Tree m -> TreeItem m) -> Tree m -> m (TreeItem m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree m -> m (TreeItem m)) -> Tree m -> m (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Tree m
t { items :: Map Name (TreeItem m)
items = Map Name (TreeItem m)
items'
                                       , treeHash :: Hash
treeHash = Hash
NoHash }
          case TreeItem m
subtree of
            SubTree Tree m
t'' -> Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree m
t''
            TreeItem m
_ -> String -> m (Tree m)
forall a. HasCallStack => String -> a
error String
"function passed to partiallyUpdateTree changed SubTree to something else"
        maybeupdate :: AnchoredPath -> (Name, TreeItem m) -> m (Name, TreeItem m)
maybeupdate AnchoredPath
path (Name
k, TreeItem m
item) = if AnchoredPath -> TreeItem m -> Bool
predi (AnchoredPath
path AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
k) TreeItem m
item
          then AnchoredPath -> (Name, TreeItem m) -> m (Name, TreeItem m)
update (AnchoredPath
path AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
k) (Name
k, TreeItem m
item)
          else (Name, TreeItem m) -> m (Name, TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
k, TreeItem m
item)
        update :: AnchoredPath -> (Name, TreeItem m) -> m (Name, TreeItem m)
update AnchoredPath
path (Name
k, SubTree Tree m
tree) = (\Tree m
new -> (Name
k, Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree m
new)) (Tree m -> (Name, TreeItem m))
-> m (Tree m) -> m (Name, TreeItem m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredPath -> Tree m -> m (Tree m)
go AnchoredPath
path Tree m
tree
        update    AnchoredPath
_ (Name
k, TreeItem m
item) = (\TreeItem m
new -> (Name
k, TreeItem m
new)) (TreeItem m -> (Name, TreeItem m))
-> m (TreeItem m) -> m (Name, TreeItem m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeItem m -> m (TreeItem m)
fun TreeItem m
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 :: (Monad m) => Tree m -> Tree m -> Tree m
overlay :: Tree m -> Tree m -> Tree m
overlay Tree m
base Tree m
over = Tree :: forall (m :: * -> *). Map Name (TreeItem m) -> Hash -> Tree m
Tree { items :: Map Name (TreeItem m)
items = [(Name, TreeItem m)] -> Map Name (TreeItem m)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, TreeItem m)]
immediate
                         , treeHash :: Hash
treeHash = Hash
NoHash }
    where immediate :: [(Name, TreeItem m)]
immediate = [ (Name
n, Name -> TreeItem m
get Name
n) | (Name
n, TreeItem m
_) <- Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree m
base ]
          get :: Name -> TreeItem m
get Name
n = case (Name -> Map Name (TreeItem m) -> Maybe (TreeItem m)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n (Map Name (TreeItem m) -> Maybe (TreeItem m))
-> Map Name (TreeItem m) -> Maybe (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Tree m -> Map Name (TreeItem m)
forall (m :: * -> *). Tree m -> Map Name (TreeItem m)
items Tree m
base, Name -> Map Name (TreeItem m) -> Maybe (TreeItem m)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n (Map Name (TreeItem m) -> Maybe (TreeItem m))
-> Map Name (TreeItem m) -> Maybe (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Tree m -> Map Name (TreeItem m)
forall (m :: * -> *). Tree m -> Map Name (TreeItem m)
items Tree m
over) of
                    (Just (File Blob m
_), Just f :: TreeItem m
f@(File Blob m
_)) -> TreeItem m
f
                    (Just (SubTree Tree m
b), Just (SubTree Tree m
o)) -> Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree m -> TreeItem m) -> Tree m -> TreeItem m
forall a b. (a -> b) -> a -> b
$ Tree m -> Tree m -> Tree m
forall (m :: * -> *). Monad m => Tree m -> Tree m -> Tree m
overlay Tree m
b Tree m
o
                    (Just (Stub m (Tree m)
b Hash
_), Just (SubTree Tree m
o)) -> m (Tree m) -> Hash -> TreeItem m
forall (m :: * -> *). m (Tree m) -> Hash -> TreeItem m
Stub ((Tree m -> Tree m -> Tree m) -> Tree m -> Tree m -> Tree m
forall a b c. (a -> b -> c) -> b -> a -> c
flip Tree m -> Tree m -> Tree m
forall (m :: * -> *). Monad m => Tree m -> Tree m -> Tree m
overlay Tree m
o (Tree m -> Tree m) -> m (Tree m) -> m (Tree m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` m (Tree m)
b) Hash
NoHash
                    (Just (SubTree Tree m
b), Just (Stub m (Tree m)
o Hash
_)) -> m (Tree m) -> Hash -> TreeItem m
forall (m :: * -> *). m (Tree m) -> Hash -> TreeItem m
Stub (Tree m -> Tree m -> Tree m
forall (m :: * -> *). Monad m => Tree m -> Tree m -> Tree m
overlay Tree m
b (Tree m -> Tree m) -> m (Tree m) -> m (Tree m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` m (Tree m)
o) Hash
NoHash
                    (Just (Stub m (Tree m)
b Hash
_), Just (Stub m (Tree m)
o Hash
_)) -> m (Tree m) -> Hash -> TreeItem m
forall (m :: * -> *). m (Tree m) -> Hash -> TreeItem m
Stub (do Tree m
o' <- m (Tree m)
o
                                                                   Tree m
b' <- m (Tree m)
b
                                                                   Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree m -> m (Tree m)) -> Tree m -> m (Tree m)
forall a b. (a -> b) -> a -> b
$ Tree m -> Tree m -> Tree m
forall (m :: * -> *). Monad m => Tree m -> Tree m -> Tree m
overlay Tree m
b' Tree m
o') Hash
NoHash
                    (Just TreeItem m
x, Maybe (TreeItem m)
_) -> TreeItem m
x
                    (Maybe (TreeItem m)
_, Maybe (TreeItem m)
_) -> String -> TreeItem m
forall a. HasCallStack => String -> a
error (String -> TreeItem m) -> String -> TreeItem m
forall a b. (a -> b) -> a -> b
$ String
"Unexpected case in overlay at get " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."

addMissingHashes :: (Monad m) => (TreeItem m -> m Hash) -> Tree m -> m (Tree m)
addMissingHashes :: (TreeItem m -> m Hash) -> Tree m -> m (Tree m)
addMissingHashes TreeItem m -> m Hash
make = (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m)
forall (m :: * -> *).
Monad m =>
(TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m)
updateTree TreeItem m -> m (TreeItem m)
update -- use partiallyUpdateTree here
    where update :: TreeItem m -> m (TreeItem m)
update (SubTree Tree m
t) = TreeItem m -> m Hash
make (Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree m
t) m Hash -> (Hash -> m (TreeItem m)) -> m (TreeItem m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Hash
x -> TreeItem m -> m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeItem m -> m (TreeItem m)) -> TreeItem m -> m (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree m
t { treeHash :: Hash
treeHash = Hash
x })
          update (File blob :: Blob m
blob@(Blob m ByteString
con Hash
NoHash)) =
              do Hash
hash <- TreeItem m -> m Hash
make (TreeItem m -> m Hash) -> TreeItem m -> m Hash
forall a b. (a -> b) -> a -> b
$ Blob m -> TreeItem m
forall (m :: * -> *). Blob m -> TreeItem m
File Blob m
blob
                 TreeItem m -> m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeItem m -> m (TreeItem m)) -> TreeItem m -> m (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Blob m -> TreeItem m
forall (m :: * -> *). Blob m -> TreeItem m
File (m ByteString -> Hash -> Blob m
forall (m :: * -> *). m ByteString -> Hash -> Blob m
Blob m ByteString
con Hash
hash)
          update (Stub m (Tree m)
s Hash
NoHash) = TreeItem m -> m (TreeItem m)
update (TreeItem m -> m (TreeItem m))
-> (Tree m -> TreeItem m) -> Tree m -> m (TreeItem m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree m -> m (TreeItem m)) -> m (Tree m) -> m (TreeItem m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Tree m)
s
          update TreeItem m
x = TreeItem m -> m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return TreeItem m
x

------ Private utilities shared among multiple functions. --------

unstub :: (Monad m) => TreeItem m -> m (Tree m)
unstub :: TreeItem m -> m (Tree m)
unstub (Stub m (Tree m)
s Hash
_) = m (Tree m)
s
unstub (SubTree Tree m
s) = Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree m
s
unstub TreeItem m
_ = Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree m
forall (m :: * -> *). Tree m
emptyTree

isSub :: TreeItem m -> Bool
isSub :: TreeItem m -> Bool
isSub (File Blob m
_) = Bool
False
isSub TreeItem m
_ = Bool
True

-- Properties

-- | Specification of 'explodePath'
prop_explodePath :: Tree m -> AnchoredPath -> Bool
prop_explodePath :: Tree m -> AnchoredPath -> Bool
prop_explodePath Tree m
t AnchoredPath
p =
  Tree m -> AnchoredPath -> [AnchoredPath]
forall (m :: * -> *). Tree m -> AnchoredPath -> [AnchoredPath]
explodePath Tree m
t AnchoredPath
p [AnchoredPath] -> [AnchoredPath] -> Bool
forall a. Eq a => a -> a -> Bool
== (AnchoredPath -> Bool) -> [AnchoredPath] -> [AnchoredPath]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (AnchoredPath -> AnchoredPath -> Bool
isPrefix AnchoredPath
p) (((AnchoredPath, TreeItem m) -> AnchoredPath)
-> [(AnchoredPath, TreeItem m)] -> [AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath, TreeItem m) -> AnchoredPath
forall a b. (a, b) -> a
fst (Tree m -> [(AnchoredPath, TreeItem m)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree m
t))