-- 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.

{- | Definitions used in this module:

[Explicit dependencies]: The set of patches that a (named) patch depends on
  "by name", i.e. irrespective of (non-)commutation (non commuting patches are
  implicit dependencies). The most important example are tags, but non-tag
  patches can also have explicit dependencies by recording them with
  --ask-deps.

[Covered]: A patch @p@ is covered by a tag @t@ if @t@ explicitly depends on
  @p@ or a tag covered by @t@ explicitly depends on @p@. In other words, the
  transitive closure of the relation "is depended on", restricted to
  situations where the right hand side is a tag. Note that it does /not/ take
  explicit dependencies of non-tag patches into account at all.

[Clean]: A tag @t@ in a repository is clean if all patches prior to the tag are
  covered by @t@. Tags normally start out as clean tags (the exception is
  if --ask-deps is used). It typically becomes unclean when it is merged into
  another repo (here the exceptions are if --reorder-patches is used, or if
  the target repo is actually a subset of the source repo).
-}

module Darcs.Patch.Depends
    ( getUncovered
    , areUnrelatedRepos
    , findCommonAndUncommon
    , mergeThem
    , findCommonWithThem
    , countUsThem
    , removeFromPatchSet
    , slightlyOptimizePatchset
    , splitOnTag
    , patchSetUnion
    , patchSetIntersection
    , findUncommon
    , cleanLatestTag
    , contextPatches
    ) where

import Darcs.Prelude

import Data.List ( delete, intersect, (\\) )
import Data.Maybe ( fromMaybe )

import Darcs.Patch.Named ( getdeps )
import Darcs.Patch.Commute ( Commute )
import Darcs.Patch.Ident ( fastRemoveSubsequenceRL, merge2FL )
import Darcs.Patch.Info ( PatchInfo, isTag, displayPatchInfo )
import Darcs.Patch.Merge ( Merge )
import Darcs.Patch.Permutations ( partitionFL, partitionRL )
import Darcs.Patch.PatchInfoAnd( PatchInfoAnd, hopefully, hopefullyM, info )
import Darcs.Patch.Set
    ( PatchSet(..)
    , Tagged(..)
    , SealedPatchSet
    , patchSet2RL
    , appendPSFL
    , patchSetSplit
    , Origin
    )
import Darcs.Patch.Progress ( progressRL )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart )
import Darcs.Patch.Witnesses.Eq ( Eq2 )
import Darcs.Patch.Witnesses.Ordered
    ( (:\/:)(..), (:/\:)(..), (:>)(..), Fork(..),
    (+<<+), mapFL, RL(..), FL(..), isShorterThanRL, breakRL,
    (+<+), reverseFL, reverseRL, mapRL )
import Darcs.Patch.Witnesses.Sealed
    ( Sealed(..), seal )

import Darcs.Util.Printer ( renderString, vcat )

{-|
Find clean tags that are common to both argument 'PatchSet's and return a
'Fork' with the common clean tags and whatever remains of the 'PatchSet's.
The two "uncommon" sequences may still have patches in common, even clean
tags, since we look only at the "known clean" tags of the second argument,
i.e. those that are the head of a 'Tagged' section.

This is a pretty efficient function, because it makes use of the
already-broken-up nature of 'PatchSet's.

Note that the first argument should be the repository that is more cheaply
accessed (i.e. local), as 'taggedIntersection' does its best to reduce the
number of inventories that are accessed from its second argument.
-}
taggedIntersection :: forall rt p wX wY . Commute p
                   => PatchSet rt p Origin wX -> PatchSet rt p Origin wY ->
                      Fork (RL (Tagged rt p))
                           (RL (PatchInfoAnd rt p))
                           (RL (PatchInfoAnd rt p)) Origin wX wY
taggedIntersection (PatchSet NilRL ps1) s2 = Fork NilRL ps1 (patchSet2RL s2)
taggedIntersection s1 (PatchSet NilRL ps2) = Fork NilRL (patchSet2RL s1) ps2
taggedIntersection s1 (PatchSet (_ :<: Tagged t2 _ _) ps2)
    -- If t2 is the head of any of the Tagged sections of s1,
    -- unwrap everything in s1 after t2 and be done with it.
    | Just (PatchSet ts1 ps1) <- maybeSplitSetOnTag (info t2) s1 =
        Fork ts1 ps1 (unsafeCoercePStart ps2)
taggedIntersection s1 s2@(PatchSet (ts2 :<: Tagged t2 _ t2ps) ps2) =
    -- Same case as before but now we know that t2 is not the head of any
    -- Tagged section of s1. If t2 has already been fully retrieved, then
    -- we know that the next Tagged section of s2 is available without
    -- opening another remote inventory; in this case we recurse i.e.
    -- we unwrap t2 and its patches and continue with the next Tagged of s2.
    -- Otherwise we try to make t2 clean in s1 by looking at s1's trailing
    -- patch list, too.
    -- Question by bf: Wouldn't it be better to call splitOnTag /before/ we
    -- test if t2 has already been opened? If it succeeds, then we'd get
    -- more common Tagged sections and still don't have to open a remote
    -- inventory.
    case hopefullyM t2 of
        Just _ ->
            taggedIntersection s1 (PatchSet ts2 (t2ps :<: t2 +<+ ps2))
        Nothing ->
            case splitOnTag (info t2) s1 of
                Just (PatchSet com us) ->
                      Fork com us (unsafeCoercePStart ps2)
                Nothing -> Fork NilRL (patchSet2RL s1) (patchSet2RL s2)

-- |'maybeSplitSetOnTag' takes a tag's 'PatchInfo', @t0@, and a 'PatchSet' and
-- attempts to find @t0@ in one of the 'Tagged's in the PatchSet. If the tag is
-- found, the 'PatchSet' is split up, on that tag, such that all later patches
-- are in the "since last tag" patch list. If the tag is not found, 'Nothing'
-- is returned.
-- This is a simpler version of 'splitOnTag' that only looks at the heads
-- of 'Tagged' sections and does not commute any patches.
maybeSplitSetOnTag :: PatchInfo -> PatchSet rt p wStart wX
                   -> Maybe (PatchSet rt p wStart wX)
maybeSplitSetOnTag t0 origSet@(PatchSet (ts :<: Tagged t _ pst) ps)
    | t0 == info t = Just origSet
    | otherwise = do
        PatchSet ts' ps' <- maybeSplitSetOnTag t0 (PatchSet ts (pst :<: t))
        Just $ PatchSet ts' (ps' +<+ ps)
maybeSplitSetOnTag _ _ = Nothing

-- | Take a tag's 'PatchInfo', and a 'PatchSet', and attempt to find the tag in
-- the 'PatchSet'. If found, return a new 'PatchSet', in which the tag is now
-- clean (and the last of the 'Tagged' list), while all patches that are not
-- covered by the tag are in the trailing list of patches.
-- If the tag is not in the 'PatchSet', we return 'Nothing'.
splitOnTag :: Commute p => PatchInfo -> PatchSet rt p wStart wX
           -> Maybe (PatchSet rt p wStart wX)
-- If the tag we are looking for is the first Tagged tag of the patchset, just
-- separate out the patchset's patches.
splitOnTag t s@(PatchSet (_ :<: Tagged hp _ _) _) | info hp == t = Just s
-- If the tag is the most recent patch in the set, we check if the patch is the
-- only non-depended-on patch in the set (i.e. it is a clean tag); creating a
-- new Tagged out of the patches and tag, and adding it to the patchset, if
-- this is the case. Otherwise, we try to make the tag clean.
splitOnTag t patchset@(PatchSet ts hps@(ps :<: hp)) | info hp == t =
    if getUncovered patchset == [t]
        -- If t is the only patch not covered by any tag...
        then Just $ PatchSet (ts :<: Tagged hp Nothing ps) NilRL
        else case partitionRL ((`notElem` (t : getdeps (hopefully hp))) . info) hps of
            -- Partition hps by those that are the tag and its explicit deps.
            tagAndDeps@(ds' :<: hp') :> nonDeps ->
                -- If @ds@ doesn't contain the tag of the first Tagged, that
                -- tag will also be returned by the call to getUncovered - so
                -- we need to unwrap the next Tagged in order to expose it to
                -- being partitioned out in the recursive call to splitOnTag.
                if getUncovered (PatchSet ts tagAndDeps) == [t]
                    then let tagged = Tagged hp' Nothing ds' in
                         return $ PatchSet (ts :<: tagged) nonDeps
                    else do
                        unfolded <- unwrapOneTagged $ PatchSet ts tagAndDeps
                        PatchSet xx yy <- splitOnTag t unfolded
                        return $ PatchSet xx (yy +<+ nonDeps)
            _ -> error "impossible case"
-- We drop the leading patch, to try and find a non-Tagged tag.
splitOnTag t (PatchSet ts (ps :<: p)) = do
    PatchSet ns xs <- splitOnTag t (PatchSet ts ps)
    return $ PatchSet ns (xs :<: p)
-- If there are no patches left, we "unfold" the next Tagged, and try again.
splitOnTag t0 patchset@(PatchSet (_ :<: Tagged _ _ _s) NilRL) =
    unwrapOneTagged patchset >>= splitOnTag t0
-- If we've checked all the patches, but haven't found the tag, return Nothing.
splitOnTag _ (PatchSet NilRL NilRL) = Nothing

-- | Reorder a 'PatchSet' such that the latest tag becomes clean.
cleanLatestTag :: Commute p
               => PatchSet rt p wStart wX
               -> PatchSet rt p wStart wX
cleanLatestTag inp@(PatchSet ts ps) =
  case breakRL (isTag . info) ps of
    NilRL :> _ -> inp -- no tag among the ps -> we are done
    (left@(_ :<: t) :> right) ->
      case splitOnTag (info t) (PatchSet ts left) of
        Just (PatchSet ts' ps') -> PatchSet ts' (ps' +<+ right)
        _ -> error "impossible case" -- because t is in left

-- |'unwrapOneTagged' unfolds a single Tagged object in a PatchSet, adding the
-- tag and patches to the PatchSet's patch list.
unwrapOneTagged :: PatchSet rt p wX wY -> Maybe (PatchSet rt p wX wY)
unwrapOneTagged (PatchSet (ts :<: Tagged t _ tps) ps) =
    Just $ PatchSet ts (tps :<: t +<+ ps)
unwrapOneTagged _ = Nothing

-- | Return the 'PatchInfo' for all the patches in a 'PatchSet'
-- that are not depended on by any tag (in the given 'PatchSet').
--
-- This is exactly the set of patches that a new tag recorded on top
-- of the 'PatchSet' would explicitly depend on.
getUncovered :: PatchSet rt p wStart wX -> [PatchInfo]
getUncovered patchset = case patchset of
    (PatchSet NilRL ps) -> findUncovered (mapRL infoAndExplicitDeps ps)
    (PatchSet (_ :<: Tagged t _ _) ps) ->
        findUncovered (mapRL infoAndExplicitDeps (NilRL :<: t +<+ ps))
  where
    findUncovered :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo]
    findUncovered [] = []
    findUncovered ((pi, Nothing) : rest) = pi : findUncovered rest
    findUncovered ((pi, Just deps) : rest) =
        pi : findUncovered (dropDepsIn deps rest)

    -- |dropDepsIn traverses the list of patches, dropping any patches that
    -- occur in the dependency list; when a patch is dropped, its dependencies
    -- are added to the dependency list used for later patches.
    dropDepsIn :: [PatchInfo] -> [(PatchInfo, Maybe [PatchInfo])]
               -> [(PatchInfo, Maybe [PatchInfo])]
    dropDepsIn [] pps = pps
    dropDepsIn _  []  = []
    dropDepsIn ds (hp : pps)
        | fst hp `elem` ds =
            let extraDeps = fromMaybe [] $ snd hp in
            dropDepsIn (extraDeps ++ delete (fst hp) ds) pps
        | otherwise = hp : dropDepsIn ds pps

    -- |infoAndExplicitDeps returns the patch info and (for tags only) the list
    -- of explicit dependencies of a patch.
    infoAndExplicitDeps :: PatchInfoAnd rt p wX wY
                        -> (PatchInfo, Maybe [PatchInfo])
    infoAndExplicitDeps p
        | isTag (info p) = (info p, getdeps `fmap` hopefullyM p)
        | otherwise = (info p, Nothing)

-- | Create a new 'Tagged' section for the most recent clean tag found in the
-- tail of un-'Tagged' patches without re-ordering patches. Note that earlier
-- tags may remain un-'Tagged' even if they are actually clean.
slightlyOptimizePatchset :: PatchSet rt p wStart wX -> PatchSet rt p wStart wX
slightlyOptimizePatchset (PatchSet ts0 ps0) =
    go $ PatchSet ts0 (progressRL "Optimizing inventory" ps0)
  where
    go :: PatchSet rt p wStart wY -> PatchSet rt p wStart wY
    go (PatchSet ts NilRL) = PatchSet ts NilRL
    go s@(PatchSet ts (ps :<: hp))
        | isTag (info hp)
        , [info hp] == getUncovered s =
            PatchSet (ts :<: Tagged hp Nothing ps) NilRL
        | otherwise = appendPSFL (go (PatchSet ts ps)) (hp :>: NilFL)

removeFromPatchSet :: (Commute p, Eq2 p) => FL (PatchInfoAnd rt p) wX wY
                   -> PatchSet rt p wStart wY -> Maybe (PatchSet rt p wStart wX)
removeFromPatchSet bad (PatchSet ts ps) | all (`elem` mapRL info ps) (mapFL info bad) = do
    ps' <- fastRemoveSubsequenceRL (reverseFL bad) ps
    return (PatchSet ts ps')
removeFromPatchSet _ (PatchSet NilRL _) = Nothing
removeFromPatchSet bad (PatchSet (ts :<: Tagged t _ tps) ps) =
    removeFromPatchSet bad (PatchSet ts (tps :<: t +<+ ps))

findCommonAndUncommon :: forall rt p wX wY . Commute p
                      => PatchSet rt p Origin wX -> PatchSet rt p Origin wY
                      -> Fork (PatchSet rt p)
                              (FL (PatchInfoAnd rt p))
                              (FL (PatchInfoAnd rt p)) Origin wX wY
findCommonAndUncommon us them = case taggedIntersection us them of
    Fork common us' them' ->
        case partitionFL (infoIn them') $ reverseRL us' of
            _ :> bad@(_ :>: _) :> _ ->
                error $ "Failed to commute common patches:\n"
                      ++ renderString
                          (vcat $ mapRL (displayPatchInfo . info) $ reverseFL bad)
            (common2 :> NilFL :> only_ours) ->
                case partitionFL (infoIn us') $ reverseRL them' of
                    _ :> bad@(_ :>: _) :> _ ->
                        error $ "Failed to commute common patches:\n"
                            ++ renderString (vcat $
                                mapRL (displayPatchInfo . info) $ reverseFL bad)
                    _ :> NilFL :> only_theirs ->
                        Fork (PatchSet common (reverseFL common2))
                            only_ours (unsafeCoercePStart only_theirs)
  where
    infoIn inWhat = (`elem` mapRL info inWhat) . info

findCommonWithThem :: Commute p
                   => PatchSet rt p Origin wX
                   -> PatchSet rt p Origin wY
                   -> (PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin wX
findCommonWithThem us them = case taggedIntersection us them of
    Fork common us' them' ->
        case partitionFL ((`elem` mapRL info them') . info) $ reverseRL us' of
            _ :> bad@(_ :>: _) :> _ ->
                error $ "Failed to commute common patches:\n"
                      ++ renderString
                          (vcat $ mapRL (displayPatchInfo . info) $ reverseFL bad)
            common2 :> _nilfl :> only_ours ->
                PatchSet common (reverseFL common2) :> unsafeCoerceP only_ours

findUncommon :: Commute p
             => PatchSet rt p Origin wX -> PatchSet rt p Origin wY
             -> (FL (PatchInfoAnd rt p) :\/: FL (PatchInfoAnd rt p)) wX wY
findUncommon us them =
    case findCommonWithThem us them of
        _common :> us' -> case findCommonWithThem them us of
            _ :> them' -> unsafeCoercePStart us' :\/: them'

countUsThem :: Commute p
            => PatchSet rt p Origin wX
            -> PatchSet rt p Origin wY
            -> (Int, Int)
countUsThem us them =
    case taggedIntersection us them of
        Fork _ us' them' -> let uu = mapRL info us'
                                tt = mapRL info them' in
                            (length $ uu \\ tt, length $ tt \\ uu)

mergeThem :: (Commute p, Merge p)
          => PatchSet rt p Origin wX -> PatchSet rt p Origin wY
          -> Sealed (FL (PatchInfoAnd rt p) wX)
mergeThem us them =
    case taggedIntersection us them of
        Fork _ us' them' ->
            case merge2FL (reverseRL us') (reverseRL them') of
               them'' :/\: _ -> Sealed them''

patchSetIntersection :: Commute p
                   => [SealedPatchSet rt p Origin]
                   -> SealedPatchSet rt p Origin
patchSetIntersection [] = seal $ PatchSet NilRL NilRL
patchSetIntersection [x] = x
patchSetIntersection (Sealed y : ys) =
    case patchSetIntersection ys of
        Sealed z -> case taggedIntersection y z of
            Fork common a b -> case mapRL info a `intersect` mapRL info b of
                morecommon ->
                    case partitionRL (\e -> info e `notElem` morecommon) a of
                        commonps :> _ -> seal $ PatchSet common commonps

patchSetUnion :: (Commute p, Merge p, Eq2 p)
            => [SealedPatchSet rt p Origin]
            -> SealedPatchSet rt p Origin
patchSetUnion [] = seal $ PatchSet NilRL NilRL
patchSetUnion [x] = x
patchSetUnion (Sealed y@(PatchSet tsy psy) : Sealed y2 : ys) =
    case mergeThem y y2 of
        Sealed p2 ->
            patchSetUnion $ seal (PatchSet tsy (psy +<<+ p2)) : ys

areUnrelatedRepos :: Commute p
                  => PatchSet rt p Origin wX
                  -> PatchSet rt p Origin wY -> Bool
areUnrelatedRepos us them =
    case taggedIntersection us them of
        Fork c u t -> checkit c u t
  where
    checkit (_ :<: Tagged{}) _ _ = False
    checkit _ u t | t `isShorterThanRL` 5 = False
                  | u `isShorterThanRL` 5 = False
                  | otherwise = null $ intersect (mapRL info u) (mapRL info t)

-- | Split a 'PatchSet' at the latest clean tag. The left part is what comes
-- before the tag, the right part is the tag and its non-dependencies.
contextPatches :: PatchSet rt p wX wY
               -> (PatchSet rt p :> RL (PatchInfoAnd rt p)) wX wY
contextPatches = patchSetSplit . slightlyOptimizePatchset