%  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}