--  Copyright (C) 2009-2011 Petr Rockai
--
--  BSD3
{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, BangPatterns #-}

-- | The abstract representation of a Tree and useful abstract utilities to
-- handle those.
module Darcs.Util.Tree
    ( Tree, Blob(..), TreeItem(..), ItemType(..), Hash(..)
    , makeTree, makeTreeWithHash, emptyTree, emptyBlob, makeBlob, makeBlobBS

    -- * Unfolding stubbed (lazy) Trees.
    --
    -- | By default, Tree obtained by a read function is stubbed: it will
    -- contain Stub items that need to be executed in order to access the
    -- respective subtrees. 'expand' will produce an unstubbed Tree.
    , expandUpdate, expand, expandPath, checkExpand

    -- * Tree access and lookup.
    , items, list, listImmediate, treeHash
    , lookup, find, findFile, findTree, itemHash, itemType
    , zipCommonFiles, zipFiles, zipTrees, diffTrees

    -- * Files (Blobs).
    , readBlob

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

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

import Prelude ()
import Darcs.Prelude hiding ( 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 _ h :: Hash
h)) = Hash
h
itemHash (SubTree t :: Tree m
t) = Tree m -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree m
t
itemHash (Stub _ h :: Hash
h) = Hash
h

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

emptyTree :: Tree m
emptyTree :: Tree m
emptyTree = $WTree :: 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 str :: 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 s' :: 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 l :: [(Name, TreeItem m)]
l = $WTree :: 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 l :: [(Name, TreeItem m)]
l h :: Hash
h = $WTree :: 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 t :: Tree m
t n :: 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' t :: TreeItem m
t (AnchoredPath []) = TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just TreeItem m
t
find' (SubTree t :: Tree m
t) (AnchoredPath (d :: Name
d : rest :: [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 sub :: 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)
      Nothing -> Maybe (TreeItem m)
forall a. Maybe a
Nothing
find' _ _ = 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 t :: Tree m
t p :: 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 x :: Blob m
x) -> Blob m -> Maybe (Blob m)
forall a. a -> Maybe a
Just Blob m
x
                 _ -> 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 t :: Tree m
t p :: 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 x :: Tree m
x) -> Tree m -> Maybe (Tree m)
forall a. a -> Maybe a
Just Tree m
x
                 _ -> 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 t_ :: 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 t :: Tree m
t p :: AnchoredPath
p = [ (AnchoredPath -> Name -> AnchoredPath
appendPath AnchoredPath
p Name
n, TreeItem m
i)
                          | (n :: Name
n,i :: 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)
                             | (subn :: Name
subn, SubTree subt :: Tree m
subt) <- Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree m
t ]

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 update :: AnchoredPath -> Tree m -> m (Tree m)
update t_ :: 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 path :: AnchoredPath
path t :: Tree m
t = do
            let subtree :: (Name, TreeItem m) -> m (Name, TreeItem m)
subtree (name :: Name
name, sub :: 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@(_, item :: 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 t :: Tree m
t (AnchoredPath []) = Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree m
t
expandPath t :: Tree m
t (AnchoredPath (n :: Name
n:rest :: [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 item :: 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
    _ -> 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 t' :: Tree m
t' name :: Name
name rest' :: [Name]
rest' sub :: 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 hashFunc :: TreeItem IO -> IO Hash
hashFunc t :: 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 path :: AnchoredPath
path t_ :: Tree IO
t_ = do
        let
            subtree :: (Name, TreeItem IO)
-> IO
     (Either [(AnchoredPath, Hash, Maybe Hash)] (Name, TreeItem IO))
subtree (name :: Name
name, sub :: 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
                     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 sub'' :: 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 problems :: [(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 :: 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 (_, f :: TreeItem IO
f@(File (Blob _ h :: 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 _ = 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
name, f :: TreeItem IO
f@(File (Blob _ h :: 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
name, _) = (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@(_, item :: 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 predicate :: AnchoredPath -> TreeItem m -> Bool
predicate t_ :: Tree m
t_ = Tree m -> AnchoredPath -> Tree m
filter' Tree m
t_ ([Name] -> AnchoredPath
AnchoredPath [])
        where filter' :: Tree m -> AnchoredPath -> Tree m
filter' t :: Tree m
t path :: 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 path :: AnchoredPath
path name :: Name
name item :: 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 npath :: AnchoredPath
npath (SubTree t :: 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 npath :: AnchoredPath
npath (Stub stub :: m (Tree m)
stub h :: 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 _ x :: 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 guide :: Tree n
guide tree :: 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 path :: AnchoredPath
path item :: 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 _), SubTree _) -> Bool
True
                (Just (SubTree _), Stub _ _) -> Bool
True
                (Just (File _), File _) -> Bool
True
                (Just (Stub _ _), _) ->
                    String -> Bool
forall a. String -> a
bug "*sulk* Go away, you, you precondition violator!"
                (_, _) -> 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 r :: m ByteString
r _) = 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 f :: AnchoredPath -> Blob m -> Blob m -> a
f a :: Tree m
a b :: 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
                                   | (p :: AnchoredPath
p, File x :: 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 f :: AnchoredPath -> Maybe (Blob m) -> Maybe (Blob m) -> a
f a :: Tree m
a b :: 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 t :: Tree m
t = [AnchoredPath] -> [AnchoredPath]
forall a. Ord a => [a] -> [a]
sort [ AnchoredPath
p | (p :: AnchoredPath
p, File _) <- 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 f :: AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a
f a :: Tree m
a b :: 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 t :: Tree m
t = [AnchoredPath] -> [AnchoredPath]
forall a. Ord a => [a] -> [a]
sort [ AnchoredPath
p | (p :: AnchoredPath
p, _) <- 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 [] ys :: [AnchoredPath]
ys = [AnchoredPath]
ys
sortedUnion xs :: [AnchoredPath]
xs [] = [AnchoredPath]
xs
sortedUnion a :: [AnchoredPath]
a@(x :: AnchoredPath
x:xs :: [AnchoredPath]
xs) b :: [AnchoredPath]
b@(y :: AnchoredPath
y:ys :: [AnchoredPath]
ys) = case AnchoredPath -> AnchoredPath -> Ordering
forall a. Ord a => a -> a -> Ordering
compare AnchoredPath
x AnchoredPath
y of
                                LT -> AnchoredPath
x AnchoredPath -> [AnchoredPath] -> [AnchoredPath]
forall a. a -> [a] -> [a]
: [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
sortedUnion [AnchoredPath]
xs [AnchoredPath]
b
                                EQ -> AnchoredPath
x AnchoredPath -> [AnchoredPath] -> [AnchoredPath]
forall a. a -> [a] -> [a]
: [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
sortedUnion [AnchoredPath]
xs [AnchoredPath]
ys
                                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 left :: Tree m
left right :: 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 _) = Bool
True
        isFile _ = 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 x :: m (Tree m)
x _) = m (Tree m)
x
        subtree (SubTree x :: Tree m
x) = Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree m
x
        subtree (File _) = String -> m (Tree m)
forall a. String -> a
bug "diffTrees tried to descend a File as a subtree"
        maybeUnfold :: TreeItem m -> m (TreeItem m)
maybeUnfold (Stub x :: m (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` (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 x :: 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 i :: 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 t :: Tree m
t = [ Name
n | (n :: Name
n, _) <- 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 left' :: Tree m
left' right' :: 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 l :: TreeItem m
l, 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)
                     (Nothing, Just r :: 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 l :: TreeItem m
l, Just r :: 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
                                (x' :: Tree m
x', y' :: 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')
                     _ -> String -> m (Name, Maybe (TreeItem m), Maybe (TreeItem m))
forall a. String -> a
bug "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) | (n :: Name
n, Just l :: TreeItem m
l, _) <- [(Name, Maybe (TreeItem m), Maybe (TreeItem m))]
is ]
              is_r :: [(Name, TreeItem m)]
is_r = [ (Name
n, TreeItem m
r) | (n :: Name
n, _, Just r :: 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 t_ :: Tree m
t_ p_ :: AnchoredPath
p_ i_ :: 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 t :: Tree m
t unmod :: Bool
unmod items' :: 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)
forall a b. a -> b -> b
`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 t :: Tree m
t (AnchoredPath []) (Just (SubTree sub :: 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 t :: Tree m
t (AnchoredPath [n :: Name
n]) (Just item :: 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
                                             Nothing -> Hash
NoHash
                                             Just i :: TreeItem m
i -> TreeItem m -> Hash
forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i

        go t :: Tree m
t (AnchoredPath [n :: Name
n]) 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 t :: Tree m
t path :: AnchoredPath
path@(AnchoredPath (n :: Name
n:r :: [Name]
r)) item :: 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 s :: 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 s :: Tree m
s) -> let (mod' :: Bool
mod', sub'' :: 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 s :: m (Tree m)
s _) -> (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)
                    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)
                    _ -> String -> (Bool, TreeItem m)
forall a. String -> a
bug (String -> (Bool, TreeItem m)) -> String -> (Bool, TreeItem m)
forall a b. (a -> b) -> a -> b
$ "Modify tree at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
forall a. Show a => a -> String
show AnchoredPath
path

        go _ (AnchoredPath []) (Just (Stub _ _)) =
            String -> (Bool, Tree m)
forall a. String -> a
bug (String -> (Bool, Tree m)) -> String -> (Bool, Tree m)
forall a b. (a -> b) -> a -> b
$ "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 _ (AnchoredPath []) (Just (File _)) =
            String -> (Bool, Tree m)
forall a. String -> a
bug (String -> (Bool, Tree m)) -> String -> (Bool, Tree m)
forall a b. (a -> b) -> a -> b
$ "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 _ (AnchoredPath []) Nothing =
            String -> (Bool, Tree m)
forall a. String -> a
bug (String -> (Bool, Tree m)) -> String -> (Bool, Tree m)
forall a b. (a -> b) -> a -> b
$ "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 (\_ i :: Int
i -> Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) 0

updateSubtrees :: (Tree m -> Tree m) -> Tree m -> Tree m
updateSubtrees :: (Tree m -> Tree m) -> Tree m -> Tree m
updateSubtrees fun :: Tree m -> Tree m
fun t :: 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 (k :: a
k, SubTree s :: 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 (k :: a
k, File f :: Blob m
f) = (a
k, Blob m -> TreeItem m
forall (m :: * -> *). Blob m -> TreeItem m
File Blob m
f)
        update (_, Stub _ _) = String -> (a, TreeItem m)
forall a. String -> a
bug "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 fun :: TreeItem m -> m (TreeItem m)
fun t :: 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 (\_ _ -> 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 fun :: TreeItem m -> m (TreeItem m)
fun predi :: AnchoredPath -> TreeItem m -> Bool
predi t' :: 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 path :: AnchoredPath
path t :: 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 t'' :: Tree m
t'' -> Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree m
t''
            _ -> String -> m (Tree m)
forall a. String -> a
bug "function passed to partiallyUpdateTree didn't changed SubTree to something else"
        maybeupdate :: AnchoredPath -> (Name, TreeItem m) -> m (Name, TreeItem m)
maybeupdate path :: AnchoredPath
path (k :: Name
k, item :: 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 path :: AnchoredPath
path (k :: Name
k, SubTree tree :: Tree m
tree) = (\new :: 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    _ (k :: Name
k, item :: TreeItem m
item) = (\new :: 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 base :: Tree m
base over :: Tree m
over = $WTree :: 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) | (n :: Name
n, _) <- Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree m
base ]
          get :: Name -> TreeItem m
get n :: 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 _), Just f :: TreeItem m
f@(File _)) -> TreeItem m
f
                    (Just (SubTree b :: Tree m
b), Just (SubTree o :: 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 b :: m (Tree m)
b _), Just (SubTree o :: 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 b :: Tree m
b), Just (Stub o :: m (Tree m)
o _)) -> 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 b :: m (Tree m)
b _), Just (Stub o :: m (Tree m)
o _)) -> 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 x :: TreeItem m
x, _) -> TreeItem m
x
                    (_, _) -> String -> TreeItem m
forall a. String -> a
bug (String -> TreeItem m) -> String -> TreeItem m
forall a b. (a -> b) -> a -> b
$ "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]
++ "."

addMissingHashes :: (Monad m) => (TreeItem m -> m Hash) -> Tree m -> m (Tree m)
addMissingHashes :: (TreeItem m -> m Hash) -> Tree m -> m (Tree m)
addMissingHashes make :: 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 t :: 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
>>= \x :: 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 con :: m ByteString
con 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 s :: m (Tree m)
s 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 x :: 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 s :: m (Tree m)
s _) = m (Tree m)
s
unstub (SubTree s :: Tree m
s) = Tree m -> m (Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree m
s
unstub _ = 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 _) = Bool
False
isSub _ = Bool
True