%  Copyright (C) 2003-2004 David Roundy
%
%  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; see the file COPYING.  If not, write to
%  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
%  Boston, MA 02110-1301, USA.

\section{Dependencies}
\begin{code}
module Depends ( get_common_and_uncommon, get_tags_right,
                 get_common_and_uncommon_or_missing,
                 optimize_patchset, deep_optimize_patchset,
                 slightly_optimize_patchset,
                 get_patches_beyond_tag, get_patches_in_tag,
                 is_tag,
                 patchset_union, patchset_intersection,
                 commute_to_end,
               ) where
import List ( delete, intersect )
import Monad ( liftM, liftM2 )
import Control.Monad.Error (Error(..), MonadError(..))

import Patch ( Patch, getdeps, join_patches, flatten, commute,
               patch2patchinfo, merge )
import PatchInfo ( PatchInfo, just_name, human_friendly )
import PatchSet ( PatchSet )
import Printer ( errorDoc, ($$), text )
#include "impossible.h"
\end{code}

\begin{code}
get_tags_right :: PatchSet -> [PatchInfo]
get_common_and_uncommon :: (PatchSet,PatchSet) ->
                           ([PatchInfo],PatchSet,PatchSet)
get_common_and_uncommon_or_missing :: (PatchSet,PatchSet) ->
                                      Either PatchInfo ([PatchInfo],PatchSet,PatchSet)
\end{code}

\begin{code}
get_common_and_uncommon = 
    either missingPatchError id . get_common_and_uncommon_err

get_common_and_uncommon_or_missing = 
    either (\(MissingPatch x) -> Left x) Right . get_common_and_uncommon_err

get_common_and_uncommon_err :: (PatchSet,PatchSet) ->
                               Either MissingPatch ([PatchInfo],PatchSet,PatchSet)
get_common_and_uncommon_err (ps1,ps2) = gcau (optimize_patchset ps1) ps2

{-
with_partial_intersection takes two PatchSets and splits them into a common
intersection portion and two sets of patches.  The intersection, however,
is only lazily determined, so there is no guarantee that all intersecting
patches will be included in the intersection PatchSet.  This is a pretty
efficient function, because it makes use of the already-broken-up nature of
PatchSets.

PatchSets have the property that if

(fst $ last $ head a) == (fst $ last $ head b)

then (tail a) and (tail b) are identical repositories, and we want to take
advantage of this if possible, to avoid reading too many inventories.  In
the case of --partial repositories or patch bundles, it is crucial that we
don't need to read the whole history, since it isn't available.

TODO:

The length equalising isn't necessarily right. We probably also be
thinking about not going past the end of a partial repository, or favour
local repository stuff over remote repository stuff.

Also, when comparing l1 to l2, we should really be comparing the
newly discovered one to /all/ the lasts in the other patch set
that we've got so far.
-}

with_partial_intersection :: PatchSet -> PatchSet
                          -> (PatchSet -> [(PatchInfo, Maybe Patch)]
                                       -> [(PatchInfo, Maybe Patch)] -> a)
                          -> a
with_partial_intersection [] ps2 j = j [[]] [] (concat ps2)
with_partial_intersection ps1 [] j = j [[]] (concat ps1) []
with_partial_intersection ([]:ps1) ps2 j =
    with_partial_intersection ps1 ps2 j
with_partial_intersection ps1 ([]:ps2) j =
    with_partial_intersection ps1 ps2 j
-- NOTE: symmetry is broken here, so we want the PatchSet with more history
-- first!
with_partial_intersection ([(pi1,_)]:common) ([(pi2,_)]:_) j
    | pi1 == pi2 = j common [] []
with_partial_intersection (orig_ps1:orig_ps1s) (orig_ps2:orig_ps2s) j
 = f (length orig_ps1) (fst $ last orig_ps1) [orig_ps1] orig_ps1s
     (length orig_ps2) (fst $ last orig_ps2) [orig_ps2] orig_ps2s
    where {- Invariants: nx = length $ cr psx
                         lx = last $ cr psx   -}
          f _n1 l1 ps1 ps1s _n2 l2 ps2 _ps2s
           | l1 == l2 = j ps1s (cr ps1) (cr ps2)
          f n1 l1 ps1 ps1s n2 l2 ps2 ps2s
           = case compare n1 n2 of
             GT -> case dropWhile null ps2s of
                   ps2':ps2s' ->
                       f n1 l1 ps1 ps1s
                         (n2 + length ps2') (fst $ last ps2') (ps2':ps2) ps2s'
                   [] -> -- We keep going round f so the l1 == l2 case
                         -- has a chance to kick in
                         case dropWhile null ps1s of
                         ps1':ps1s' ->
                             f (n1 + length ps1') (fst $ last ps1')
                               (ps1':ps1) ps1s'
                               n2 l2 ps2 ps2s
                         [] -> j [[]] (cr ps1) (cr ps2)
             _  -> case dropWhile null ps1s of
                   ps1':ps1s' ->
                       f (n1 + length ps1') (fst $ last ps1') (ps1':ps1) ps1s'
                         n2 l2 ps2 ps2s
                   [] -> -- We keep going round f so the l1 == l2 case
                         -- has a chance to kick in
                         case dropWhile null ps2s of
                         ps2':ps2s' ->
                             f n1 l1 ps1 []
                               (n2 + length ps2') (fst $ last ps2')
                               (ps2':ps2) ps2s'
                         [] -> j [[]] (cr ps1) (cr ps2)
          cr = concat . reverse

{-
gcau determines a list of "common" patches and patches unique to each of
the two PatchSets.  The list of "common" patches only needs to include all
patches that are not interspersed with the "unique" patches, but including
more patches in the list of "common" patches doesn't really hurt, except
for efficiency considerations.  Mostly, we want to access as few elements
as possible of the PatchSet list, since those can be expensive (or
unavailable).

PatchSets have the property that if

(fst $ last $ head a) == (fst $ last $ head b)

then (tail a) and (tail b) are identical repositories, and we want to take
advantage of this if possible, to avoid reading too many inventories.  In
the case of --partial repositories or patch bundles, it is crucial that we
don't need to read the whole history, since it isn't available.

TODO:

The length equalising isn't necessarily right. We probably also be
thinking about not going past the end of a partial repository, or favour
local repository stuff over remote repo stuff.

Also, when comparing l1 to l2, we should really be comparing the
newly discovered one to /all/ the lasts in the other patch set
that we've got so far.
-}


gcau :: PatchSet -> PatchSet
     -> Either MissingPatch ([PatchInfo],PatchSet,PatchSet)
gcau [] ps2 = return ([], [[]], [concat ps2])
gcau ps1 [] = return ([], [concat ps1], [[]])
gcau ([]:ps1) ps2 = gcau ps1 ps2
gcau ps1 ([]:ps2) = gcau ps1 ps2
gcau ([(pi1,_)]:_) ([(pi2,_)]:_)
 | pi1 == pi2 = return ([pi1], [[]], [[]])
gcau (orig_ps1:orig_ps1s) (orig_ps2:orig_ps2s)
 = f (length orig_ps1) (fst $ last orig_ps1) [orig_ps1] orig_ps1s
     (length orig_ps2) (fst $ last orig_ps2) [orig_ps2] orig_ps2s
    where {- Invariants: nx = length $ cr psx
                         lx = last $ cr psx   -}
          f _n1 l1 ps1 _ps1s _n2 l2 ps2 _ps2s
           | l1 == l2 = gcau_simple (cr ps1) (cr ps2)
          f n1 l1 ps1 ps1s n2 l2 ps2 ps2s
           = case compare n1 n2 of
             GT -> case dropWhile null ps2s of
                   ps2':ps2s' ->
                       f n1 l1 ps1 ps1s
                         (n2 + length ps2') (fst $ last ps2') (ps2':ps2) ps2s'
                   [] -> -- We keep going round f so the l1 == l2 case
                         -- has a chance to kick in
                         case dropWhile null ps1s of
                         ps1':ps1s' ->
                             f (n1 + length ps1') (fst $ last ps1')
                               (ps1':ps1) ps1s'
                               n2 l2 ps2 ps2s
                         [] -> gcau_simple (cr ps1) (cr ps2)
             _  -> case dropWhile null ps1s of
                   ps1':ps1s' ->
                       f (n1 + length ps1') (fst $ last ps1') (ps1':ps1) ps1s'
                         n2 l2 ps2 ps2s
                   [] -> -- We keep going round f so the l1 == l2 case
                         -- has a chance to kick in
                         case dropWhile null ps2s of
                         ps2':ps2s' ->
                             f n1 l1 ps1 []
                               (n2 + length ps2') (fst $ last ps2')
                               (ps2':ps2) ps2s'
                         [] -> gcau_simple (cr ps1) (cr ps2)
          cr = concat . reverse

gcau_simple :: [(PatchInfo, Maybe Patch)] -> [(PatchInfo, Maybe Patch)]
            -> Either MissingPatch ([PatchInfo],PatchSet,PatchSet)
gcau_simple ps1 ps2 = do
 ex1 <- get_extra (return []) common ps1
 ex2 <- get_extra (return []) common ps2
 let ps1' = filter ((`elem` common) . fst) ps1
 return (map fst $ head $ ((optimize_patchset [ps1']) ++ [[]]) , [ex1] , [ex2])
  where common = map fst ps1 `intersect` map fst ps2

newtype MissingPatch = MissingPatch PatchInfo

instance Error MissingPatch where
    -- we don't really need those methods
    noMsg = MissingPatch (error "MissingPatch: bug in get_extra (noMsg)")
    strMsg msg = MissingPatch (error ("MissingPatch: " ++ msg))

get_extra :: Either MissingPatch [Patch]
          -> [PatchInfo]
          -> [(PatchInfo, Maybe Patch)]
          -> Either MissingPatch [(PatchInfo, Maybe Patch)]
get_extra _ _ [] = return []
get_extra skipped common ((pinfo, mp):pps) =
    if pinfo `elem` common && is_tag pinfo
    then case liftM getdeps mp of
         Just ds -> get_extra (liftM2 (:) ep skipped) (ds++delete pinfo common) pps
         Nothing -> get_extra (liftM2 (:) ep skipped) (delete pinfo common) pps
    else if pinfo `elem` common
         then get_extra (liftM2 (:) ep skipped) (delete pinfo common) pps
         else do
            p <- ep
            skpd <- skipped
            case commute (join_patches skpd, p) of
              Just (p', skipped_patch') -> do
                  x <- get_extra (return (flatten skipped_patch')) common pps
                  return ((pinfo, Just p') : x)
              Nothing -> errorDoc $ text "bug in get_extra commuting patch:"
                         $$ human_friendly pinfo
    where ep = case mp of
              Just p' -> return p'
              Nothing -> throwError (MissingPatch pinfo)

missingPatchError :: MissingPatch -> a
missingPatchError (MissingPatch pinfo) =
    errorDoc
        ( text "failed to read patch in get_extra:"
          $$ human_friendly pinfo
          $$ text "Perhaps this is a 'partial' repository?" )

get_extra_old :: [Patch]
              -> [PatchInfo]
              -> [(PatchInfo, Maybe Patch)]
              -> [(PatchInfo, Maybe Patch)]
get_extra_old skipped common pps =
    either missingPatchError id (get_extra (return skipped) common pps)
              
\end{code}

\begin{code}
get_patches_beyond_tag :: PatchInfo -> PatchSet -> PatchSet
get_patches_beyond_tag t ([(pinfo,_)]:_) | pinfo == t = [[]]
get_patches_beyond_tag t patchset@(((pinfo,mp):ps):pps) =
    if pinfo == t
    then if get_tags_right patchset == [pinfo]
         then [[]] -- special case to avoid looking at redundant patches
         else [get_extra_old [] [t] $ concat patchset]
    else (pinfo,mp) -:- get_patches_beyond_tag t (ps:pps)
get_patches_beyond_tag t ([]:pps) = get_patches_beyond_tag t pps
get_patches_beyond_tag _ [] = [[]]

get_patches_in_tag :: PatchInfo -> PatchSet -> PatchSet
get_patches_in_tag t pps@([(pinfo,_)]:xs)
    | pinfo == t = pps
    | otherwise = get_patches_in_tag t xs

get_patches_in_tag t (((pinfo,_):ps):xs)
    | pinfo /= t = get_patches_in_tag t (ps:xs)

get_patches_in_tag _ ((pa@(_, Just tp):ps):xs) = gpit thepis [pa] (ps:xs)
    where thepis = getdeps tp
          gpit _ sofar [] = [reverse sofar]
          gpit deps sofar ([(tinfo,thisp)]:xs')
              | tinfo `elem` deps = (reverse $ (tinfo,thisp) : sofar) : xs'
              | otherwise = gpit deps sofar xs'
          gpit deps sofar ([]:xs') = gpit deps sofar xs'
          gpit deps sofar (((pinf, Just p):ps'):xs')
              | pinf `elem` deps
                  = let odeps = filter (/=pinf) deps
                        alldeps = if is_tag pinf
                                  then odeps ++ getdeps p
                                  else odeps
                    in gpit alldeps ((pinf, Just p):sofar) (ps':xs')
              | otherwise
                  = gpit deps (commute_by sofar p) (ps':xs')
          gpit _ _ (((pinf, Nothing):_):_)
              = errorDoc $ text "Failure reading patch file"
                        $$ human_friendly pinf

get_patches_in_tag t _ = errorDoc $ text "Couldn't read tag"
                                 $$ human_friendly t

commute_by :: [(PatchInfo, Maybe Patch)] -> Patch
           -> [(PatchInfo, Maybe Patch)]
commute_by [] _ = []
commute_by ((pinf, Just a):xs) p =
    case commute (a,p) of
    Nothing -> bug "Failure commuting patches in commute_by called by gpit!"
    Just (p', a') -> (pinf, Just a') : commute_by xs p'
commute_by ((pinf, Nothing):_) _ =
    errorDoc $ text "Couldn't read patch:"
            $$ human_friendly pinf
\end{code}

\begin{code}
is_tag :: PatchInfo -> Bool
is_tag pinfo = take 4 (just_name pinfo) == "TAG "

get_tags_right [] = []
get_tags_right (ps:_) = get_tags_r ps
    where
    get_tags_r [] = []
    get_tags_r ((pinfo,mp):pps)
        | is_tag pinfo = case liftM getdeps mp of
                         Just ds -> pinfo : get_tags_r (drop_tags_r ds pps)
                         Nothing -> pinfo : map fst pps
        | otherwise = pinfo : get_tags_r pps
    drop_tags_r :: [PatchInfo]
                -> [(PatchInfo, Maybe Patch)] -> [(PatchInfo, Maybe Patch)]
    drop_tags_r [] pps = pps
    drop_tags_r _ [] = []
    drop_tags_r ds ((pinfo,mp):pps)
        | pinfo `elem` ds && is_tag pinfo =
            case liftM getdeps mp of
            Just ds' -> drop_tags_r (ds'++delete pinfo ds) pps
            Nothing -> drop_tags_r (delete pinfo ds) pps
        | pinfo `elem` ds = drop_tags_r (delete pinfo ds) pps
        | otherwise = (pinfo,mp) : drop_tags_r ds pps
\end{code}

\begin{code}
deep_optimize_patchset :: PatchSet -> PatchSet
deep_optimize_patchset pss = optimize_patchset [concat pss]

optimize_patchset :: PatchSet -> PatchSet
optimize_patchset [] = []
optimize_patchset (ps:pss) = opsp ps ++ pss
opsp :: [(PatchInfo,Maybe Patch)] -> PatchSet
opsp [] = []
opsp ((pinfo,mp):pps)
     | is_tag pinfo && get_tags_right [(pinfo,mp):pps] == [pinfo]
         = [(pinfo,mp)] : opsp pps
     | otherwise = (pinfo,mp) -:- opsp pps

(-:-) :: (PatchInfo, Maybe Patch) -> PatchSet -> PatchSet
pp -:- [] = [[pp]]
pp -:- (p:ps) = ((pp:p) : ps)

slightly_optimize_patchset :: PatchSet -> PatchSet
slightly_optimize_patchset [] = []
slightly_optimize_patchset (ps:pss) = sops ps ++ pss
    where sops [] = []
          sops [(pinfo,mp)] = [[(pinfo,mp)]]
          sops ((pinfo,mp):pps) | is_tag pinfo &&
                                  get_tags_right [(pinfo,mp):pps] == [pinfo]
                                      = [(pinfo,mp)] : [pps]
                                | otherwise = (pinfo,mp) -:- sops pps
\end{code}

\begin{code}
commute_to_end :: [Patch] -> PatchSet -> ([Patch],[Patch])
commute_to_end select from =
   ctt [] (map (fromJust.patch2patchinfo) select) (concat from)
   where
      ctt :: [Patch] -> [PatchInfo]
          -> [(PatchInfo, Maybe Patch)] -> ([Patch], [Patch])
      ctt skp [] _ = ([],skp)
      ctt skp sel ((pinf, Just p):ps)
         | pinf `elem` sel
            = case cmt_by (skp, p) of
              Nothing -> bug "patches to commute_to_end does not commute (1)"
              Just (p', skp') ->
                 let (ps', skp'') = ctt skp' (delete pinf sel) ps
                 in (p':ps', skp'')
         | otherwise
            = ctt (p:skp) sel ps
      ctt _ _ _ = bug "patches to commute_to_end does not commute (2)"
      cmt_by :: ([Patch], Patch) -> Maybe (Patch, [Patch])
      cmt_by ([], a) = Just (a, [])
      cmt_by (p:ps, a) =
          case commute (p, a) of
          Nothing -> Nothing
          Just (a', p') -> case cmt_by (ps, a') of
                           Nothing -> Nothing
                           Just (a'', ps') -> Just (a'', p':ps')

segregate_patches :: (PatchInfo -> Bool) -> PatchSet -> ([Patch],[Patch])
segregate_patches select_first from =
   ctt [] [] (concat from)
   where
      ctt :: [Patch] -> [Patch] -> [(PatchInfo, Maybe Patch)]
          -> ([Patch], [Patch])
      ctt las fir [] = (reverse las, reverse fir)
      ctt las fir ((pinf, Just p):ps)
         | select_first pinf = ctt las (p:fir) ps
         | otherwise =
             case cmt_by (fir, p) of
             Nothing -> bug "patches to segregate_patches does not commute (1)"
             Just (p', fir') -> ctt (p':las) fir' ps
      ctt _ _ ((pinf, Nothing):_) =
          errorDoc ( text "failed to read patch in get_extra:"
                     $$ human_friendly pinf
                     $$ text "Perhaps this is a 'partial' repository?" )
      cmt_by :: ([Patch], Patch) -> Maybe (Patch, [Patch])
      cmt_by (ps, a) = do (a', jps') <- commute (join_patches ps, a)
                          return (a', flatten jps')
\end{code}

\begin{code}
patchset_intersection :: [PatchSet] -> PatchSet
patchset_intersection [] = [[]]
patchset_intersection [x] = x
patchset_intersection (y:ys) =
    with_partial_intersection y (patchset_intersection ys) $
    \common a b ->        
        let morecommon = map fst a `intersect` map fst b
            (_,commonps) = segregate_patches (`elem` morecommon) [a]
        in
        (map (\p -> (fromJust $ patch2patchinfo p, Just p)) commonps) : common

patchset_union :: [PatchSet] -> PatchSet
patchset_union [] = [[]]
patchset_union [x] = x
patchset_union (y:ys) =
    with_partial_intersection y (patchset_union ys) $
    \common a b ->
        case gcau_simple a b of
        Left e -> missingPatchError e
        Right (_, [a'], [b']) -> (merge_sets a' b' ++ b) : common
        _ -> impossible

merge_sets :: [(PatchInfo, Maybe Patch)] -> [(PatchInfo, Maybe Patch)]
           -> [(PatchInfo, Maybe Patch)]
merge_sets l r =
    let pl = join_patches $ map (fromJust . snd) $ reverse l
        pr = join_patches $ map (fromJust . snd) $ reverse r
        p2pimp p = (fromJust $ patch2patchinfo p, Just p)
    in case merge (pl, pr) of
       Just (pl',_) -> map p2pimp $ reverse $ flatten pl'
       Nothing -> impossible
\end{code}