-- 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
    , findCommon
    , findCommonWithThem
    , findUncommon
    , patchSetMerge
    , countUsThem
    , removeFromPatchSet
    , slightlyOptimizePatchset
    , fullyOptimizePatchSet
    , splitOnTag
    , patchSetUnion
    , patchSetIntersection
    , cleanLatestTag
    , contextPatches
    ) where

import Darcs.Prelude

import Control.Applicative ( (<|>) )
import Data.List ( delete, foldl1', intersect, (\\) )

import Darcs.Patch.Named ( getdeps )
import Darcs.Patch.Commute ( Commute )
import Darcs.Patch.Ident
    ( fastRemoveSubsequenceRL
    , findCommonRL
    , findCommonWithThemRL
    )
import Darcs.Patch.Info ( PatchInfo, isTag )
import Darcs.Patch.Merge ( Merge(..) )
import Darcs.Patch.Permutations ( partitionRL )
import Darcs.Patch.PatchInfoAnd( PatchInfoAnd, hopefully, info )
import Darcs.Patch.Set
    ( Origin
    , PatchSet(..)
    , SealedPatchSet
    , Tagged(..)
    , appendPSFL
    , emptyPatchSet
    , patchSet2FL
    , patchSet2RL
    , patchSetSplit
    )
import Darcs.Patch.Progress ( progressRL )
import Darcs.Patch.Witnesses.Unsafe ( 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 )

{-|
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 p wX wY . Commute p
                   => PatchSet p Origin wX -> PatchSet p Origin wY ->
                      Fork (RL (Tagged p))
                           (RL (PatchInfoAnd p))
                           (RL (PatchInfoAnd 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 (ts2 :<: Tagged t2ps t2 _) ps2) =
  -- First try to find t2 in the heads of Tagged sections of s1;
  -- if that fails, try to reorder patches in s1 so that it does;
  -- otherwise t2 does not occur in s1, so recurse with the current
  -- Tagged section of s2 unwrapped.
  case maybeSplitSetOnTag (info t2) s1 <|> splitOnTag (info t2) s1 of
    Just (PatchSet ts1 ps1) -> Fork ts1 ps1 (unsafeCoercePStart ps2)
    Nothing -> taggedIntersection s1 (PatchSet ts2 (t2ps :<: t2 +<+ ps2))

-- |'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 p wStart wX
                   -> Maybe (PatchSet p wStart wX)
maybeSplitSetOnTag t0 origSet@(PatchSet (ts :<: Tagged pst t _) 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 p wStart wX
           -> Maybe (PatchSet p wStart wX)
-- If the tag we are looking for is the first Tagged tag of the patchset, we
-- are done.
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]
        then
          -- If t is the only patch not covered by any tag, then it is clean
          Just $ PatchSet (ts :<: Tagged ps hp Nothing) NilRL
        else
          -- Make it clean by commuting out patches not explicitly depended on
          -- by @t@; since we do this with just the trailing sequence @hps@ i.e.
          -- we don't include the tag of the next Tagged, we have to make an
          -- extra check to see if this tag is covered, too, and otherwise
          -- recurse with the next Tagged section unwrapped. Note that we cannot
          -- simply check if @t@ depends on this tag because it may depend
          -- indirectly via unclean tags contained in @hps@.
          case partitionRL ((`notElem` (t : getdeps (hopefully hp))) . info) hps of
            tagAndDeps@(ds' :<: hp') :> nonDeps ->
                -- check if t is now fully clean
                if getUncovered (PatchSet ts tagAndDeps) == [t]
                    then let tagged = Tagged ds' hp' Nothing in
                         return $ PatchSet (ts :<: tagged) nonDeps
                    else do
                        unfolded <- unwrapOneTagged $ PatchSet ts tagAndDeps
                        PatchSet ts' ps' <- splitOnTag t unfolded
                        return $ PatchSet ts' (ps' +<+ 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 _ _ _) 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 p wStart wX
               -> PatchSet 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

-- | Create a 'Tagged' section for every clean tag. For unclean tags we try to
-- make them clean, but only if that doesn't make an earlier clean tag dirty.
-- This means that the operation is idempotent and in particular monotonic,
-- which justifies the "optimize" in the name.
fullyOptimizePatchSet
  :: forall p wZ . Commute p => PatchSet p Origin wZ -> PatchSet p Origin wZ
fullyOptimizePatchSet = go emptyPatchSet . patchSet2FL
  where
    go :: PatchSet p Origin wY -> FL (PatchInfoAnd p) wY wZ -> PatchSet p Origin wZ
    go s NilFL = s
    go s@(PatchSet ts ps) (q:>:qs)
      | isTag qi, getUncovered s' == [qi] =
          -- tag is clean
          go (PatchSet (ts :<: Tagged ps q Nothing) NilRL) qs
      | isTag qi, Just s'' <- makeClean s q = go s'' qs
      | otherwise = go s' qs
      where
        qi = info q
        s' = PatchSet ts (ps:<:q)

-- | Take a 'PatchSet' and an adjacent tag and try to make the tag clean
-- by commuting out trailing patches that are not covered by the tag.
makeClean
  :: Commute p
  => PatchSet p Origin wY
  -> PatchInfoAnd p wY wZ
  -> Maybe (PatchSet p Origin wZ)
makeClean (PatchSet ts ps) t =
  let ti = info t in
  case partitionRL ((`notElem` (ti : getdeps (hopefully t))) . info) (ps :<: t) of
    tagAndDeps@(ds :<: t') :> nonDeps ->
      -- check if tag really became clean
      if getUncovered (PatchSet ts tagAndDeps) == [ti]
        then Just $ PatchSet (ts :<: Tagged ds t' Nothing) nonDeps
        else Nothing
    _ -> error "imposible"

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

-- | Return the 'PatchInfo' for all the patches in a 'PatchSet' that are not
-- *explicitly* 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.
--
-- Note that the result is not minimal with respect to dependencies, not even
-- explicit dependencies: explicit dependencies of regular (non-tag) patches
-- are completely ignored.
getUncovered :: PatchSet p wStart wX -> [PatchInfo]
getUncovered (PatchSet tagged patches) =
  findUncovered $
    case tagged of
      NilRL -> mapRL infoAndExplicitDeps patches
      _ :<: Tagged _ t _ -> mapRL infoAndExplicitDeps patches ++ [(info t, [])]
  where
    -- Both findUncovered and dropDepsIn are basically graph algorithms. We
    -- present the (directed, acyclic) graph as a topologically sorted list of
    -- vertices together with the targets of their outgoing edges. The problem
    -- findUncovered solves is to find all vertices with no incoming edges.
    -- This is done by removing all vertices reachable from any vertex in the
    -- graph.
    findUncovered :: Eq a => [(a, [a])] -> [a]
    findUncovered [] = []
    findUncovered ((pi, deps) : rest) =
        pi : findUncovered (dropDepsIn deps rest)

    -- Remove the given list of vertices from the graph, as well as all
    -- vertices reachable from them.
    dropDepsIn :: Eq a => [a] -> [(a, [a])] -> [(a, [a])]
    dropDepsIn [] ps = ps
    dropDepsIn _  [] = []
    dropDepsIn ds (hp@(hpi,hpds) : ps)
        | hpi `elem` ds = dropDepsIn (delete hpi ds ++ hpds) ps
        | otherwise = hp : dropDepsIn ds ps

    -- The patch info together with the list of explicit dependencies in case
    -- it is a tag. This constructs one element of the graph representation.
    -- It cannot be used for the tag of a Tagged section as that may not be
    -- available in a lazy repo. That's okay because we already know it is
    -- clean, so no patches preceding it it can be uncovered.
    infoAndExplicitDeps :: PatchInfoAnd p wX wY -> (PatchInfo, [PatchInfo])
    infoAndExplicitDeps p
        | isTag (info p) = (info p, getdeps $ hopefully p)
        | otherwise = (info p, [])

-- | 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 p wStart wX -> PatchSet p wStart wX
slightlyOptimizePatchset (PatchSet ts0 ps0) =
    go $ PatchSet ts0 (progressRL "Optimizing inventory" ps0)
  where
    go :: PatchSet p wStart wY -> PatchSet 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 ps hp Nothing) NilRL
        | otherwise = appendPSFL (go (PatchSet ts ps)) (hp :>: NilFL)

removeFromPatchSet
  :: (Commute p, Eq2 p)
  => FL (PatchInfoAnd p) wX wY
  -> PatchSet p wStart wY
  -> Maybe (PatchSet p wStart wX)
removeFromPatchSet bad s@(PatchSet ts ps)
  | all (`elem` mapRL info ps) (mapFL info bad) = do
    ps' <- fastRemoveSubsequenceRL (reverseFL bad) ps
    return (PatchSet ts ps')
  | otherwise = removeFromPatchSet bad =<< unwrapOneTagged s

-- | The symmetric difference between two 'PatchSet's, expressed as a 'Fork'
-- consisting of the intersection 'PatchSet' and the trailing lists of
-- left-only and right-only patches.
--
-- From a purely functional point of view this is a symmetric function.
-- However, laziness effects make it asymmetric: the LHS is more likely to be
-- evaluated fully, while the RHS is evaluated as sparingly as possible. For
-- efficiency, the LHS should come from the local repo and the RHS from the
-- remote one. This asymmetry can also have a semantic effect, namely if
-- 'PatchSet's have *unavailable* patches or inventories, for instance when we
-- deal with a lazy clone of a repo that is no longer accessible. In this case
-- the order of arguments may determine whether the command fails or succeeds.
findCommon
  :: Commute p
  => PatchSet p Origin wX
  -> PatchSet p Origin wY
  -> Fork (PatchSet p) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) Origin wX wY
findCommon us them =
  case taggedIntersection us them of
    Fork common us' them' ->
      case findCommonRL us' them' of
        Fork more_common us'' them'' ->
          Fork (PatchSet common more_common) (reverseRL us'') (reverseRL them'')

findCommonWithThem
  :: Commute p
  => PatchSet p Origin wX
  -> PatchSet p Origin wY
  -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wX
findCommonWithThem us them =
  case taggedIntersection us them of
    Fork common us' them' ->
      case findCommonWithThemRL us' them' of
        more_common :> us'' ->
          PatchSet common more_common :> reverseRL us''

findUncommon
  :: Commute p
  => PatchSet p Origin wX
  -> PatchSet p Origin wY
  -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wX wY
findUncommon us them =
  case taggedIntersection us them of
    Fork _ us' them' ->
      case (findCommonWithThemRL us' them', findCommonWithThemRL them' us') of
        (_ :> us'', _ :> them'') ->
          reverseRL us'' :\/: unsafeCoercePStart (reverseRL them'')

countUsThem :: Commute p
            => PatchSet p Origin wX
            -> PatchSet 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)

patchSetMerge
  :: (Commute p, Merge p)
  => PatchSet p Origin wX
  -> PatchSet p Origin wY
  -> (FL (PatchInfoAnd p) :/\: FL (PatchInfoAnd p)) wX wY
patchSetMerge us them = merge (findUncommon us them)

-- | A 'PatchSet' consisting of the patches common to all input 'PatchSet's.
-- This is *undefined* for the empty list since intersection of 'PatchSet's
-- has no unit.
patchSetIntersection
  :: Commute p => [SealedPatchSet p Origin] -> SealedPatchSet p Origin
patchSetIntersection = foldr1 go
  where
    go (Sealed ps) (Sealed acc) =
      case findCommonWithThem ps acc of
        common :> _ -> seal common

-- | A 'PatchSet' consisting of the patches contained in any of the input
-- 'PatchSet's. The input 'PatchSet's are merged in left to right order, left
-- patches first.
patchSetUnion
  :: (Commute p, Merge p) => [SealedPatchSet p Origin] -> SealedPatchSet p Origin
-- You may consider simplifying this to a plain foldr'. However, this is
-- extremely inefficient because we have to build everything up from an empty
-- PatchSet. In principle this could be avoided by merging right patches first,
-- but then we get a failure in the conflict-chain-resolution test for darcs-1.
patchSetUnion [] = seal emptyPatchSet
patchSetUnion [x] = x
patchSetUnion xs = foldl1' go xs
  where
    go (Sealed acc) (Sealed ps) =
      case patchSetMerge acc ps of
        ps_only :/\: _ -> seal $ appendPSFL acc ps_only

-- | Two 'PatchSet's are considered unrelated unless they share a common
-- inventory, or either 'PatchSet' has less than 5 patches, or they have at
-- least one patch in common.
areUnrelatedRepos
  :: Commute p => PatchSet p Origin wX -> PatchSet p Origin wY -> Bool
areUnrelatedRepos us them =
  case taggedIntersection us them of
    Fork NilRL u t
      | t `isShorterThanRL` 5 -> False
      | u `isShorterThanRL` 5 -> False
      | otherwise -> null $ intersect (mapRL info u) (mapRL info t)
    _ -> False

-- | 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 p wX wY
               -> (PatchSet p :> RL (PatchInfoAnd p)) wX wY
contextPatches = patchSetSplit . slightlyOptimizePatchset
