1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280
|
% Copyright (C) 2005 Juliusz Chroboczek
%
% This program is free software; you can redistribute it and/or modify
% it under the terms of the GNU General Public License as published by
% the Free Software Foundation; either version 2, or (at your option)
% any later version.
%
% This program is distributed in the hope that it will be useful,
% but WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
% GNU General Public License for more details.
%
% You should have received a copy of the GNU General Public License
% along with this program; if not, write to the Free Software Foundation,
% Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
\begin{code}
module GitRepo ( read_repo, slurpHead, writePatch, updateInventory
) where
#ifdef ENABLE_GIT
import PatchCommute ( merge )
import Git ( GitSlurpy, gitHeadCommit, readGitCommit, gitCommitParents,
gitCommitToPatch', gitCommitToPatchInfo, emptyGitSlurpy,
slurpGitCommit, gitSlurpyToSlurpy, purifyGitSlurpy,
applyToGitSlurpy, writeGitCommit, updateHead, gitCommitDatePS )
import PatchSet ( PatchSet )
import DarcsUtils ( withCurrentDirectory )
import SlurpDirectory ( Slurpy )
import Patch ( patch2patchinfo )
import PatchCore ( Patch( ComP ) )
import PatchInfo ( PatchInfo )
import Maybe ( fromJust, fromMaybe )
import Monad ( liftM )
import List ( find, sortBy )
#include "impossible.h"
-- String-indexed sequences
type SSequence a = [(String, a)]
-- A GitSequence is a SSequence of patches (almost, because David
-- didn't make PatchInfos lazy).
type GitSubsequence = [(PatchInfo, Maybe Patch)]
type GitSequence = SSequence GitSubsequence
-- The sequence caching monad.
-- This is a state passing monad in which the state is monotonic and
-- has a very particular shape.
data SC a b = SC !([SSequence a] -> (b, [SSequence a]))
type GSC a = SC [(PatchInfo, Maybe Patch)] a
instance Monad (SC a) where
return x = SC (\s -> (x, s))
(SC a) >>= f = SC (\s -> let (a', s') = (a s)
(SC f') = f a'
in f' s')
-- remember updates the state.
remember :: (SSequence a) -> SC a (SSequence a)
remember ss =
SC (\sseq -> (ss, (sseq ++ [ss])))
-- recall reads the cached state. It uses find_sequence, which also
-- checks for a proper tail of a cached sequence
recall :: String -> (SC a (Maybe (SSequence a)))
recall s = SC (\ss -> ((find_sequence s ss), ss))
run :: SC a b -> b
run (SC f) = fst (f [])
--
read_repo :: String -> IO PatchSet
read_repo repo = withCurrentDirectory repo $
do h <- gitHeadCommit "HEAD"
return $
map snd (run (really_read_repo repo h))
really_read_repo :: String -> String -> GSC GitSequence
really_read_repo repo sha1 =
do found <- recall sha1
case found of
Just s -> return s
Nothing -> do
let commit = readGitCommit repo sha1
parents = gitCommitParents commit
case parents of
[] ->
remember [(sha1, [gitCommitToPIMP repo commit Nothing])]
[p] ->
do let p' = readGitCommit repo p
slurpy = slurpGitCommit repo p'
history <- really_read_repo repo p
remember $
((sha1,
[gitCommitToPIMP repo commit (Just slurpy)]) :
history)
ps ->
do histories <- mapM (really_read_repo repo) ps
let (ancestor, history) =
merge_multiple_sequences histories
a_commit = readGitCommit repo `liftM` ancestor
a_slurpy = slurpGitCommit repo `liftM` a_commit
slurpy =
applySequenceToGitSlurpy ancestor history $
(fromMaybe emptyGitSlurpy a_slurpy)
remember $
((sha1,
[gitCommitToPIMP repo commit (Just slurpy)]) :
history)
where gitCommitToPIMP r gc reference =
(gitCommitToPatchInfo r gc,
Just (gitCommitToPatch' r gc reference))
merge_multiple_sequences ::
[GitSequence] -> (Maybe String, GitSequence)
merge_multiple_sequences [] = impossible
merge_multiple_sequences [_] = impossible
merge_multiple_sequences hs =
let (ancestor, h1, h2, otherhs) = find_merge_candidates repo hs
history = merge_sequences ancestor h1 h2
in case otherhs of
[] -> (ancestor, history)
_ -> merge_multiple_sequences (history:otherhs)
insequence :: String -> (SSequence a) -> Bool
insequence _ [] = False
insequence "" _ = False
insequence a ((b,_):_) | a == b = True
insequence a (_:bs) = insequence a bs
sequence_head :: [(String, a)] -> String
sequence_head ((a, _):_) = a
sequence_head _ = impossible
split_sequence :: Maybe String -> (SSequence [a]) -> ([a], SSequence [a])
split_sequence _ [] = ([], [])
split_sequence Nothing l = (concat (map snd l), [])
split_sequence (Just s) l | s == sequence_head l = ([], l)
split_sequence (Just s) ((_,l0):l) =
let (h, t) = split_sequence (Just s) l
in ((l0 ++ h), t)
find_sequence :: String -> [SSequence a] -> Maybe (SSequence a)
find_sequence _ [] = Nothing
find_sequence "" _ = Nothing
find_sequence a (h:t) =
case find_sequence' a h of
Nothing -> find_sequence a t
Just s' -> Just s'
where find_sequence' _ [] = Nothing
find_sequence' a' s@((b,_):_) | a' == b = Just s
find_sequence' a' (_:bs) = find_sequence' a' bs
common_ancestor :: (SSequence a) -> (SSequence b) -> Maybe String
common_ancestor [] _ = Nothing
common_ancestor _ [] = Nothing
common_ancestor ((s, _):_) b | s `insequence` b = Just s
common_ancestor a ((s, _):_) | s `insequence` a = Just s
common_ancestor (_:a) (_:b) = common_ancestor a b
-- given a list of histories, finds the two that should be merged
-- first. Returns the common ancestor, the two distinguished
-- histories, and the remaining histories.
find_merge_candidates ::
String -> [GitSequence] ->
(Maybe String, GitSequence, GitSequence, [GitSequence])
find_merge_candidates _ [] = impossible
find_merge_candidates _ [_] = impossible
find_merge_candidates _ [h1, h2] = ((common_ancestor h1 h2), h1, h2, [])
find_merge_candidates repo hs =
-- GitSequences don't implement Eq -- we need to number the
-- sequences to be able to find them again
let nhs = zip [(1::Int)..] hs
npairs = all_pairs nhs
pairs = map (\((_,h),(_,h')) -> (h,h')) npairs
ancestors = map (uncurry common_ancestor) pairs
ancestor = youngest ancestors
((n1, h1), (n2, h2)) = snd (fromJust (find (\(a, _) -> (a == ancestor))
(zip ancestors npairs)))
othernhs = filter (\(n,_) -> n /= n1 && n /= n2) nhs
otherhs = map snd othernhs
in (ancestor, h1, h2, otherhs)
where youngest :: [Maybe String] -> (Maybe String)
-- what we really need is an ancestor that is minimal in the
-- set of ancestors. We assume that dates make sense, and
-- simply choose the youngest one.
youngest l = last (sortBy
(\a b -> compare (ancestorDate a)
(ancestorDate b))
l)
ancestorDate Nothing = Nothing
ancestorDate (Just a) =
Just $ gitCommitDatePS repo $ readGitCommit repo a
all_pairs [] = []
all_pairs (x:l) = [ (x,y) | y <- l ] ++ all_pairs l
merge_sequences :: (Maybe String) -> GitSequence -> GitSequence -> GitSequence
merge_sequences _ l1 [] = l1
merge_sequences _ [] l2 = l2
merge_sequences ancestor l1 l2 | length l2 < length l1 =
merge_sequences ancestor l2 l1
merge_sequences ancestor l1 l2 =
let (l1', rest) = split_sequence ancestor l1
(l2', _) = split_sequence ancestor l2
m = merge_subsequences l1' l2'
in ("", m) : rest
merge_patches_after_patches :: [Patch] -> [Patch] -> [Patch]
merge_patches_after_patches l1 l2 =
let (Just ((ComP l), _)) = merge ((ComP l1), (ComP l2))
in l
merge_subsequences :: GitSubsequence -> GitSubsequence -> GitSubsequence
merge_subsequences l1 l2 | length l2 < length l1 =
merge_subsequences l2 l1
merge_subsequences l1 l2 =
let l1' = map (fromJust . snd) l1
l2' = map (fromJust . snd) l2
l = copy_list_lazily (length l1) $
merge_patches_after_patches (reverse l1') (reverse l2')
in (zip (map fst l1) (map Just (reverse l))) ++ l2
where copy_list_lazily 0 _ = []
copy_list_lazily n l = (head l):(copy_list_lazily (n - 1) (tail l))
slurpHead :: String -> IO Slurpy
slurpHead repo = withCurrentDirectory repo $ do
h <- gitHeadCommit "HEAD"
return $ gitSlurpyToSlurpy (slurpGitCommit repo (readGitCommit repo h))
applySequenceToGitSlurpy :: Maybe String -> GitSequence -> GitSlurpy ->
GitSlurpy
applySequenceToGitSlurpy Nothing [] s = s
applySequenceToGitSlurpy (Just a) ((b, _) : _) s | (b /= "") && (a == b)
= s
applySequenceToGitSlurpy a ((_, l) : sq) s =
applySubsequenceToGitSlurpy l (applySequenceToGitSlurpy a sq s)
applySequenceToGitSlurpy _ _ _ = impossible
applySubsequenceToGitSlurpy :: GitSubsequence -> GitSlurpy -> GitSlurpy
applySubsequenceToGitSlurpy [] s = s
applySubsequenceToGitSlurpy ((_, Just p):l) s =
applyToGitSlurpy True p (applySubsequenceToGitSlurpy l s)
applySubsequenceToGitSlurpy _ _ = impossible
writePatch :: String -> Patch -> IO (Patch, String)
writePatch repo patch = withCurrentDirectory repo $
do oldhead <- gitHeadCommit "HEAD"
let oldslurpy = slurpGitCommit repo (readGitCommit repo oldhead)
let slurpy = applyToGitSlurpy False patch oldslurpy
pureslurpy <- purifyGitSlurpy repo slurpy
newhead <- writeGitCommit (fromJust (patch2patchinfo patch))
pureslurpy oldhead
return (patch, newhead)
updateInventory :: [String] -> IO ()
updateInventory l = updateHead "HEAD" (last l)
#else
gni :: IO a
gni = fail "Sorry, this version of Darcs doesn't support Git repositories."
read_repo :: a -> IO b
read_repo _ = gni
slurpHead :: a -> IO b
slurpHead _ = gni
writePatch :: a -> b -> IO c
writePatch _ _ = gni
updateInventory :: a -> IO b
updateInventory _ = gni
#endif
\end{code}
|