wip

Annex/Import.hs

@@ -105,9 +105,9 @@ buildImportCommit remote importtreeconfig importcommitconfig importable =
 	go basecommit = do
 		imported@(History finaltree _) <-
 			buildImportTrees basetree subdir importable
-		skipOldHistory basecommit imported >>= \case
-			Just toadd -> do
-				finalcommit <- mkcommits basecommit toadd
+		whatToCommit basecommit imported >>= \case
+			Just (toadd, basecommit') -> do
+				finalcommit <- mkcommits basecommit' toadd
 				updatestate finaltree
 				return (Just finalcommit)
 			Nothing -> return Nothing
@@ -177,14 +177,14 @@ buildImportCommit remote importtreeconfig importcommitconfig importable =
 {- Finds what to commit to update a basecommit with an imported History
  - of git trees.
  -
- - Returns a generally truncated History, as well as the Sha that it should
- - be committed on top of. Typically, the latter is the same as the
- - basecommit.
+ - Returns the part of the imported history that should be committed, 
+ - as well as the commit sha that it should be committed on top of. 
+ - Typically, the latter is the same as the basecommit.
  -
  - This uses skipOldHistory to try to match up common trees.
  - Sometimes, that matching doesn't work. For example, a remote without an
- - atomic rename operation might result in a History with two trees for
- - each rename, one with the old file removed an another with the new file
+ - atomic rename operation might result in an imported History with two trees
+ - for each rename, one with the old file removed an another with the new file
  - added. Since the remote tracking branch is updated on export to the git
  - commit that was exported, the basecommit could have a single tree for a
  - rename.
@@ -192,35 +192,37 @@ buildImportCommit remote importtreeconfig importcommitconfig importable =
  - In that situation, the top tree in the History will match the
  - basecommit's tree, but then there will be a run of different trees
  - before they re-converge. That is detected, and the History returned is
- - truncated to the part above the re-convergence point, and the Sha
- - returned is the re-convergence point.
+ - truncated to the part above the re-convergence point, to be committed
+ - on top of the re-convergence point.
  -}
-whatToCommit :: Maybe Sha -> History Sha -> Annex (Maybe (History Sha, Sha))
-whatToCommit Nothing importedhistory = return (Just importedhistory)
-whatToCommit (Just basecommit) importedhistory =
-	maybe (Just importedhistory) (whatToCommit' importedhistory) 
-		<$> getknownhistory
+whatToCommit :: Maybe Sha -> History Sha -> Annex (Maybe (History Sha, Maybe Sha))
+whatToCommit (Just basecommit) importedhistory = getknownhistory >>= return . \case
+	Just knownhistory -> whatToCommit' importedhistory basecommit knownhistory
+	Nothing -> Just (importedhistory, Nothing)
   where
-	getknownhistory = inRepo (getTreeHistoryToDepth (historyDepth importedhistory) basecommit)
+	getknownhistory = inRepo $
+		getHistoryToDepth (historyDepth importedhistory) basecommit
+whatToCommit Nothing importedhistory = return $ Just (importedhistory, Nothing)
 
-whatToCommit' :: History Sha -> History Sha -> Maybe (History Sha, Sha)
-whatToCommit' importedhistory knownhistory@(History ktop _) =
-	case skipOldHistory knownhistory importedhistory of
+whatToCommit' :: History Sha -> Sha -> History HistoryCommit -> Maybe (History Sha, Maybe Sha)
+whatToCommit' importedhistory basecommit knownhistory@(History ktop _) =
+	case skipOldHistory (mapHistory historyCommitTree knownhistory) importedhistory of
 		Nothing -> Nothing
 		Just newhistory@(History ntop _)
-			| ntop /= ktop -> newhistory
-			| otherwise -> 
-				-- XXX find convergence point
+			| ntop /= historyCommitTree ktop -> 
+				Just (newhistory, Just basecommit)
+			-- XXX find convergence point
+			| otherwise -> undefined
 
 {- Finds the part of the importedhistory of git trees that is new and
  - should be committed on top of the knownhistory, skipping parts that have
  - already been committed.
  -
- - Will be Nothing if the knownhistory already matches the top of the
- - importedhistory.
+ - Will be Nothing if the knownhistory is already present at the top of
+ - the importedhistory.
  -
  - In the simple case where there is only one level of importedhistory,
- - when the knownhistory is has the same tree at its top, there's nothing
+ - when the knownhistory has the same tree at its top, there's nothing
  - to commit. And otherwise it should be committed on top of the knownhistory.
  -
  - In the complex case where there are several levels of importedhistory, 
@@ -235,7 +237,7 @@ skipOldHistory knownhistory importedhistory@(History top rest)
 	| sametodepth importedhistory knownhistory = Nothing
 	| otherwise = Just $ 
 		History top $ S.fromList $ catMaybes $
-			map (skipOldHistory' knownhistory) (S.toList rest)
+			map (skipOldHistory knownhistory) (S.toList rest)
   where
 	sametodepth a b = a == truncateHistoryToDepth (historyDepth a) b
 

Git/History.hs

@@ -37,22 +37,29 @@ truncateHistoryToDepth n (History t ps) = History t (go 1 ps)
 			in flip S.map s $ \(History t' s') ->
 				History t' (go depth' s')
 
-{- Gets a History of trees from commits starting with the provided commit,
- - and down to the requested depth. -}
-getTreeHistoryToDepth :: Integer -> Ref -> Repo -> IO (Maybe (History Sha))
-getTreeHistoryToDepth n commit r = do
+
+data HistoryCommit = HistoryCommit
+	{ historyCommit :: Sha
+	, historyCommitTree :: Sha
+	, historyCommitParents :: [Sha]
+	} deriving (Show, Eq, Ord)
+
+{- Gets a History starting with the provided commit, and down to the
+ - requested depth. -}
+getHistoryToDepth :: Integer -> Ref -> Repo -> IO (Maybe (History HistoryCommit))
+getHistoryToDepth n commit r = do
 	(_, Just inh, _, pid) <- createProcess (gitCreateProcess params r)
 		{ std_out = CreatePipe }
 	!h <- fmap (truncateHistoryToDepth n) 
 		. build Nothing 
-		. map treecommitparents 
+		. map parsehistorycommit
 		. lines
 		<$> hGetContents inh
 	hClose inh
 	void $ waitForProcess pid
 	return h
   where
-	build h [] = fmap (mapHistory fst) h
+	build h [] = h
 	build _ (Nothing:_) = Nothing
 	build Nothing (Just v:rest) =
 		build (Just (History v S.empty)) rest
@@ -63,20 +70,21 @@ getTreeHistoryToDepth n commit r = do
 			-- have been found, and avoid processing any more,
 			-- this makes it much faster when there is a lot of
 			-- history.
-			if parentsfound 1 h' then [] else rest
+			if parentsfound h' then [] else rest
 
-	traverseadd v@(t, (c, ps)) (History v'@(t', (c', ps')) s)
-		| c `elem` ps' =
-			let ps'' = filter (/= c) ps'
-			    v'' = (t', (c', ps''))
-			in History v'' (S.insert (History v S.empty) s)
-		| otherwise = History v' (S.map (traverseadd v) s)
+	traverseadd hc (History hc' s)
+		| historyCommit hc `elem` historyCommitParents hc' =
+			let otherps = filter (/= historyCommit hc) (historyCommitParents hc')
+			    hc'' = hc' { historyCommitParents = otherps }
+			in History hc'' (S.insert (History hc S.empty) s)
+		| otherwise = History hc' (S.map (traverseadd hc) s)
 
-	parentsfound depth (History (_t, (_c, ps)) s)
-		| not (null ps) = False
-		| null ps && depth == n = True
+	parentsfound = parentsfound' 1
+	parentsfound' depth (History hc s)
+		| not (null (historyCommitParents hc)) = False
+		| null (historyCommitParents hc) && depth == n = True
 		| depth >= n = True
-		| otherwise = all (parentsfound (succ depth)) (S.toList s)
+		| otherwise = all (parentsfound' (succ depth)) (S.toList s)
 
 	params =
 		[ Param "log"
@@ -86,6 +94,10 @@ getTreeHistoryToDepth n commit r = do
 		, Param "--format=%T %H %P"
 		]
 	
-	treecommitparents l = case map extractSha (splitc ' ' l) of
-		(Just t:Just c:ps) -> Just (t, (c, catMaybes ps))
+	parsehistorycommit l = case map extractSha (splitc ' ' l) of
+		(Just t:Just c:ps) -> Just $ HistoryCommit
+			{ historyCommit = c
+			, historyCommitTree = t
+			, historyCommitParents = catMaybes ps
+			}
 		_ -> Nothing