{- | Conflict resolution for 'RepoPatchV3' -}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Darcs.Patch.V3.Resolution () where

import Data.Maybe ( catMaybes )
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Vector as V

import Darcs.Prelude

import Darcs.Patch.Commute ( commuteFL )
import Darcs.Patch.Conflict ( Conflict(..), ConflictDetails(..), mangleOrFail )
import Darcs.Patch.Ident
    ( Ident(..)
    , SignedId(..)
    , StorableId(..)
    , findCommonFL
    )
import Darcs.Patch.Merge ( CleanMerge(..) )
import Darcs.Patch.Prim ( PrimPatch )
import Darcs.Patch.Prim.WithName ( PrimWithName, wnPatch )
import Darcs.Patch.Show hiding ( displayPatch )
import Darcs.Patch.V3.Contexted
    ( Contexted
    , ctxId
    , ctxNoConflict
    , ctxToFL
    )
import Darcs.Patch.V3.Core ( RepoPatchV3(..), (-|) )
import Darcs.Patch.Witnesses.Ordered
    ( (:/\:)(..)
    , (:>)(..)
    , (:\/:)(..)
    , FL(..)
    , Fork(..)
    , RL(..)
    , (+>+)
    , mapFL_FL
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )
import Darcs.Patch.Witnesses.Show ( Show2 )

import Darcs.Util.Graph ( Vertex, components, ltmis )
import Darcs.Util.Printer
    ( Doc
    , ($$)
    , redText
    , renderString
    )

-- * Conflict Resolution

{- This gives an overview of the algorithm for marking conflicts.

The goal is to calculate the markup for a trailing RL of patches, usually
the ones we are going to add to our repo. But since in V3 we store only the
direct conflicts, not the transitive set, we also require the full context
of all previous patches. This is needed because we may need to traverse a
(hopefully small, trailing) part of it in order to find out whether a
conflict with some older patch has been resolved or not.

The markup presents each /transitive/ unresolved conflict in the form of a
set of alternative changes that all apply at the end of the repo, such that
each alternative conflicts with all others. Constructing these alternatives
is the main part of the algorithm.

Our first goal is to construct what we call the /conflict graph/. Its
vertices are contexted named prims starting at the end of the repo. An edge
exists between two such vertices iff they conflict. So this is an undirected
graph.

Finding the vertices is the task of 'findVertices', see its documentation
for details about how this is done. We then call 'findEdges' which
determines the edges by calling 'conflictsWith' for each pair of vertices.
The graph is returned as a list of 'Node's, that is, vertices plus their
adjacency sets.

Next we partition the graph into connected components, since these are what
makes up one transitive conflict.

For each component we determine its maximal independent sets. These are
defined as the maximal subsets of vertices with the property that none of
its elements are adjacent to each other. This is done by the function
'alternatives'. Since none of the elements of an independent set conflict,
we can now convert them to plain FLs and merge them cleanly.

The result of merging all maximal independent sets in a component gives us
one set of alternatives, which is then passed as input to 'mangleUnravelled'
to generate the markup. -}

instance (SignedId name, StorableId name, PrimPatch prim) =>
         Conflict (RepoPatchV3 name prim) where
  resolveConflicts :: RL (RepoPatchV3 name prim) wO wX
-> RL (RepoPatchV3 name prim) wX wY
-> [ConflictDetails (PrimOf (RepoPatchV3 name prim)) wY]
resolveConflicts RL (RepoPatchV3 name prim) wO wX
context =
      [Node name prim wY] -> [ConflictDetails prim wY]
forall wX. [Node name prim wX] -> [ConflictDetails prim wX]
resolveComponents ([Node name prim wY] -> [ConflictDetails prim wY])
-> (RL (RepoPatchV3 name prim) wX wY -> [Node name prim wY])
-> RL (RepoPatchV3 name prim) wX wY
-> [ConflictDetails prim wY]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Contexted (PrimWithName name prim) wY] -> [Node name prim wY]
forall name (prim :: * -> * -> *) wY.
(SignedId name, PrimPatch prim) =>
[Contexted (PrimWithName name prim) wY] -> [Node name prim wY]
findEdges ([Contexted (PrimWithName name prim) wY] -> [Node name prim wY])
-> (RL (RepoPatchV3 name prim) wX wY
    -> [Contexted (PrimWithName name prim) wY])
-> RL (RepoPatchV3 name prim) wX wY
-> [Node name prim wY]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RL (RepoPatchV3 name prim) wO wX
-> RL (RepoPatchV3 name prim) wX wY
-> [Contexted (PrimWithName name prim) wY]
forall name (prim :: * -> * -> *) wO wX wY.
(SignedId name, StorableId name, PrimPatch prim) =>
RL (RepoPatchV3 name prim) wO wX
-> RL (RepoPatchV3 name prim) wX wY
-> [Contexted (PrimWithName name prim) wY]
findVertices RL (RepoPatchV3 name prim) wO wX
context
    where
      resolveComponents :: [Node name prim wX] -> [ConflictDetails prim wX]
      resolveComponents :: [Node name prim wX] -> [ConflictDetails prim wX]
resolveComponents = ([[Contexted (PrimWithName name prim) wX]]
 -> ConflictDetails prim wX)
-> [[[Contexted (PrimWithName name prim) wX]]]
-> [ConflictDetails prim wX]
forall a b. (a -> b) -> [a] -> [b]
map (Unravelled prim wX -> ConflictDetails prim wX
forall (prim :: * -> * -> *) wX.
PrimMangleUnravelled prim =>
Unravelled prim wX -> ConflictDetails prim wX
mangleOrFail (Unravelled prim wX -> ConflictDetails prim wX)
-> ([[Contexted (PrimWithName name prim) wX]]
    -> Unravelled prim wX)
-> [[Contexted (PrimWithName name prim) wX]]
-> ConflictDetails prim wX
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Contexted (PrimWithName name prim) wX] -> Sealed (FL prim wX))
-> [[Contexted (PrimWithName name prim) wX]] -> Unravelled prim wX
forall a b. (a -> b) -> [a] -> [b]
map [Contexted (PrimWithName name prim) wX] -> Sealed (FL prim wX)
forall wX.
[Contexted (PrimWithName name prim) wX] -> Sealed (FL prim wX)
mergeThem) ([[[Contexted (PrimWithName name prim) wX]]]
 -> [ConflictDetails prim wX])
-> ([Node name prim wX]
    -> [[[Contexted (PrimWithName name prim) wX]]])
-> [Node name prim wX]
-> [ConflictDetails prim wX]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node name prim wX] -> [[[Contexted (PrimWithName name prim) wX]]]
forall name (prim :: * -> * -> *) wX.
SignedId name =>
[Node name prim wX] -> [[[Contexted (PrimWithName name prim) wX]]]
alternatives
      mergeThem :: [Contexted (PrimWithName name prim) wX] -> Sealed (FL prim wX)
      mergeThem :: [Contexted (PrimWithName name prim) wX] -> Sealed (FL prim wX)
mergeThem = (forall wX. FL (PrimWithName name prim) wX wX -> FL prim wX wX)
-> Sealed (FL (PrimWithName name prim) wX) -> Sealed (FL prim wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal ((forall wW wY. PrimWithName name prim wW wY -> prim wW wY)
-> FL (PrimWithName name prim) wX wX -> FL prim wX wX
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall wW wY. PrimWithName name prim wW wY -> prim wW wY
forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch) (Sealed (FL (PrimWithName name prim) wX) -> Sealed (FL prim wX))
-> ([Contexted (PrimWithName name prim) wX]
    -> Sealed (FL (PrimWithName name prim) wX))
-> [Contexted (PrimWithName name prim) wX]
-> Sealed (FL prim wX)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Sealed (FL (PrimWithName name prim) wX)]
-> Sealed (FL (PrimWithName name prim) wX)
forall name (p :: * -> * -> *) wX.
(SignedId name, StorableId name, PrimPatch p) =>
[Sealed (FL (PrimWithName name p) wX)]
-> Sealed (FL (PrimWithName name p) wX)
mergeList ([Sealed (FL (PrimWithName name prim) wX)]
 -> Sealed (FL (PrimWithName name prim) wX))
-> ([Contexted (PrimWithName name prim) wX]
    -> [Sealed (FL (PrimWithName name prim) wX)])
-> [Contexted (PrimWithName name prim) wX]
-> Sealed (FL (PrimWithName name prim) wX)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Contexted (PrimWithName name prim) wX
 -> Sealed (FL (PrimWithName name prim) wX))
-> [Contexted (PrimWithName name prim) wX]
-> [Sealed (FL (PrimWithName name prim) wX)]
forall a b. (a -> b) -> [a] -> [b]
map Contexted (PrimWithName name prim) wX
-> Sealed (FL (PrimWithName name prim) wX)
forall (p :: * -> * -> *) wX. Contexted p wX -> Sealed (FL p wX)
ctxToFL

-- | A single 'Node' in the conflict graph. The 'neighbors' are those that we
-- know are in conflict with 'self'.
data Node name prim wY = Node
  { Node name prim wY -> Contexted (PrimWithName name prim) wY
self :: Contexted (PrimWithName name prim) wY
  , Node name prim wY -> Set (Contexted (PrimWithName name prim) wY)
neighbors :: S.Set (Contexted (PrimWithName name prim) wY)
  }

deriving instance (Show name, Show2 prim) => Show (Node name prim wY)

{- | Find the set of vertices of the conflict graph by searching the history
for unresolved conflicts. The history is split into an initial 'RL' of
patches (the context) and a trailing 'RL' of patches we are interested in.

We maintain the following state: a list of contexted patches, which will
become the resulting vertices of the conflict graph; and a set of patch
identifiers. The latter serves as markers for patches further back in the
past that we have become interested in during our traversal. We maintain the
invariant that this set never contains the identifier of any patch we have
already traversed.

Any conflictor in the trailing 'RL' is a possible candidate for a vertex;
and likewise any other patch anywhere in the history which we marked as
interesting. Every patch we encounter when traversing the history is
unmarked by removing its identifier from the marker set. The traversal
terminates when the trailing 'RL' has been fully traversed and the marker
set is empty; that is, when there are no more patches to encounter that
might interest us.

If we enounter a candidate, we try to commute it to the head; if that
succeeds, then its commuted version must be a conflictor. (Either it was a
conflictor to begin with, in which case it remains one; or it is a patch
that a later conflictor conflicted with, and that means it must itself
become conflicted when commuted to the head.) We then add the contexted
patch that the conflictor represents to the result. We also mark any patch
that the candidate conflicts with as interesting by adding its identifier to
the marker set. In order to maintain our invariant, we must extract the set
of conflicts from the patch /in its uncommuted form/. (If we took them from
the commuted version, then we might mark patches that we already traversed.)

Candidate patches that cannot be commuted to the head are ignored. We do
this uniformly for every candidate, whether it is a 'Conflictor' or a
'Prim'. The rationale for this is that a patch that some other patch depends
on is either part of a conflict that has been resolved; or else it would be
subsumed by another patch in the same component of the conflict graph that
depends on it and therefore already has it in its context.

The last point is a bit subtle. RepoPatchV1 explicitly removes any vertex
from the graph that another vertex depends on (the function there has the
beautiful and expressive name 'getSupers';-). By uniformly ignoring any
patch we cannot commute to the head we achieve the same result implicitly.
-}

findVertices
  :: forall name prim wO wX wY
   . (SignedId name, StorableId name, PrimPatch prim)
  => RL (RepoPatchV3 name prim) wO wX
  -> RL (RepoPatchV3 name prim) wX wY
  -> [Contexted (PrimWithName name prim) wY]
findVertices :: RL (RepoPatchV3 name prim) wO wX
-> RL (RepoPatchV3 name prim) wX wY
-> [Contexted (PrimWithName name prim) wY]
findVertices RL (RepoPatchV3 name prim) wO wX
context RL (RepoPatchV3 name prim) wX wY
patches = Set name
-> [Contexted (PrimWithName name prim) wY]
-> RL (RepoPatchV3 name prim) wO wX
-> RL (RepoPatchV3 name prim) wX wY
-> FL (RepoPatchV3 name prim) wY wY
-> [Contexted (PrimWithName name prim) wY]
forall wA wB.
Set name
-> [Contexted (PrimWithName name prim) wY]
-> RL (RepoPatchV3 name prim) wO wA
-> RL (RepoPatchV3 name prim) wA wB
-> FL (RepoPatchV3 name prim) wB wY
-> [Contexted (PrimWithName name prim) wY]
go Set name
forall a. Set a
S.empty [] RL (RepoPatchV3 name prim) wO wX
context RL (RepoPatchV3 name prim) wX wY
patches FL (RepoPatchV3 name prim) wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL where
  go :: S.Set name
     -> [Contexted (PrimWithName name prim) wY]
     -> RL (RepoPatchV3 name prim) wO wA
     -> RL (RepoPatchV3 name prim) wA wB
     -> FL (RepoPatchV3 name prim) wB wY
     -> [Contexted (PrimWithName name prim) wY]
  go :: Set name
-> [Contexted (PrimWithName name prim) wY]
-> RL (RepoPatchV3 name prim) wO wA
-> RL (RepoPatchV3 name prim) wA wB
-> FL (RepoPatchV3 name prim) wB wY
-> [Contexted (PrimWithName name prim) wY]
go Set name
check [Contexted (PrimWithName name prim) wY]
done RL (RepoPatchV3 name prim) wO wA
cs (RL (RepoPatchV3 name prim) wA wY
ps :<: RepoPatchV3 name prim wY wB
p) FL (RepoPatchV3 name prim) wB wY
passedby
    | RepoPatchV3 name prim wY wB -> Bool
forall name (prim :: * -> * -> *) wX wY.
RepoPatchV3 name prim wX wY -> Bool
isConflicted RepoPatchV3 name prim wY wB
p Bool -> Bool -> Bool
|| RepoPatchV3 name prim wY wB -> PatchId (RepoPatchV3 name prim)
forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident RepoPatchV3 name prim wY wB
p name -> Set name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set name
check
    , Just (FL (RepoPatchV3 name prim) wY wZ
_ :> Conflictor FL (PrimWithName name prim) wZ wY
_ Set (Contexted (PrimWithName name prim) wY)
_ Contexted (PrimWithName name prim) wY
cp) <- (:>) (RepoPatchV3 name prim) (FL (RepoPatchV3 name prim)) wY wY
-> Maybe
     ((:>) (FL (RepoPatchV3 name prim)) (RepoPatchV3 name prim) wY wY)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> Maybe ((:>) (FL p) p wX wY)
commuteFL (RepoPatchV3 name prim wY wB
p RepoPatchV3 name prim wY wB
-> FL (RepoPatchV3 name prim) wB wY
-> (:>) (RepoPatchV3 name prim) (FL (RepoPatchV3 name prim)) wY wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (RepoPatchV3 name prim) wB wY
passedby) =
        Set name
-> [Contexted (PrimWithName name prim) wY]
-> RL (RepoPatchV3 name prim) wO wA
-> RL (RepoPatchV3 name prim) wA wY
-> FL (RepoPatchV3 name prim) wY wY
-> [Contexted (PrimWithName name prim) wY]
forall wA wB.
Set name
-> [Contexted (PrimWithName name prim) wY]
-> RL (RepoPatchV3 name prim) wO wA
-> RL (RepoPatchV3 name prim) wA wB
-> FL (RepoPatchV3 name prim) wB wY
-> [Contexted (PrimWithName name prim) wY]
go (RepoPatchV3 name prim wY wB -> Set name
forall b (prim :: * -> * -> *) wX wX.
SignedId b =>
RepoPatchV3 b prim wX wX -> Set b
conflicts RepoPatchV3 name prim wY wB
p Set name -> Set name -> Set name
forall a. Semigroup a => a -> a -> a
<> RepoPatchV3 name prim wY wB -> PatchId (RepoPatchV3 name prim)
forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident RepoPatchV3 name prim wY wB
p name -> Set name -> Set name
forall a. Ord a => a -> Set a -> Set a
-| Set name
check) (Contexted (PrimWithName name prim) wY
cp Contexted (PrimWithName name prim) wY
-> [Contexted (PrimWithName name prim) wY]
-> [Contexted (PrimWithName name prim) wY]
forall a. a -> [a] -> [a]
: [Contexted (PrimWithName name prim) wY]
done) RL (RepoPatchV3 name prim) wO wA
cs RL (RepoPatchV3 name prim) wA wY
ps (RepoPatchV3 name prim wY wB
p RepoPatchV3 name prim wY wB
-> FL (RepoPatchV3 name prim) wB wY
-> FL (RepoPatchV3 name prim) wY wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (RepoPatchV3 name prim) wB wY
passedby)
    | Bool
otherwise =
        Set name
-> [Contexted (PrimWithName name prim) wY]
-> RL (RepoPatchV3 name prim) wO wA
-> RL (RepoPatchV3 name prim) wA wY
-> FL (RepoPatchV3 name prim) wY wY
-> [Contexted (PrimWithName name prim) wY]
forall wA wB.
Set name
-> [Contexted (PrimWithName name prim) wY]
-> RL (RepoPatchV3 name prim) wO wA
-> RL (RepoPatchV3 name prim) wA wB
-> FL (RepoPatchV3 name prim) wB wY
-> [Contexted (PrimWithName name prim) wY]
go (RepoPatchV3 name prim wY wB -> PatchId (RepoPatchV3 name prim)
forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident RepoPatchV3 name prim wY wB
p name -> Set name -> Set name
forall a. Ord a => a -> Set a -> Set a
-| Set name
check) [Contexted (PrimWithName name prim) wY]
done RL (RepoPatchV3 name prim) wO wA
cs RL (RepoPatchV3 name prim) wA wY
ps (RepoPatchV3 name prim wY wB
p RepoPatchV3 name prim wY wB
-> FL (RepoPatchV3 name prim) wB wY
-> FL (RepoPatchV3 name prim) wY wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (RepoPatchV3 name prim) wB wY
passedby)
  go Set name
check [Contexted (PrimWithName name prim) wY]
done RL (RepoPatchV3 name prim) wO wA
_ RL (RepoPatchV3 name prim) wA wB
NilRL FL (RepoPatchV3 name prim) wB wY
_
    | Set name -> Bool
forall a. Set a -> Bool
S.null Set name
check = [Contexted (PrimWithName name prim) wY]
done
  go Set name
check [Contexted (PrimWithName name prim) wY]
done (RL (RepoPatchV3 name prim) wO wY
cs :<: RepoPatchV3 name prim wY wA
p) RL (RepoPatchV3 name prim) wA wB
NilRL FL (RepoPatchV3 name prim) wB wY
passedby
    | RepoPatchV3 name prim wY wA -> PatchId (RepoPatchV3 name prim)
forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident RepoPatchV3 name prim wY wA
p name -> Set name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set name
check
    , Just (FL (RepoPatchV3 name prim) wY wZ
_ :> Conflictor FL (PrimWithName name prim) wZ wY
_ Set (Contexted (PrimWithName name prim) wY)
_ Contexted (PrimWithName name prim) wY
cp) <- (:>) (RepoPatchV3 name prim) (FL (RepoPatchV3 name prim)) wY wY
-> Maybe
     ((:>) (FL (RepoPatchV3 name prim)) (RepoPatchV3 name prim) wY wY)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> Maybe ((:>) (FL p) p wX wY)
commuteFL (RepoPatchV3 name prim wY wA
p RepoPatchV3 name prim wY wA
-> FL (RepoPatchV3 name prim) wA wY
-> (:>) (RepoPatchV3 name prim) (FL (RepoPatchV3 name prim)) wY wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (RepoPatchV3 name prim) wA wY
FL (RepoPatchV3 name prim) wB wY
passedby) =
        Set name
-> [Contexted (PrimWithName name prim) wY]
-> RL (RepoPatchV3 name prim) wO wY
-> RL (RepoPatchV3 name prim) wY wY
-> FL (RepoPatchV3 name prim) wY wY
-> [Contexted (PrimWithName name prim) wY]
forall wA wB.
Set name
-> [Contexted (PrimWithName name prim) wY]
-> RL (RepoPatchV3 name prim) wO wA
-> RL (RepoPatchV3 name prim) wA wB
-> FL (RepoPatchV3 name prim) wB wY
-> [Contexted (PrimWithName name prim) wY]
go (RepoPatchV3 name prim wY wA -> Set name
forall b (prim :: * -> * -> *) wX wX.
SignedId b =>
RepoPatchV3 b prim wX wX -> Set b
conflicts RepoPatchV3 name prim wY wA
p Set name -> Set name -> Set name
forall a. Semigroup a => a -> a -> a
<> RepoPatchV3 name prim wY wA -> PatchId (RepoPatchV3 name prim)
forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident RepoPatchV3 name prim wY wA
p name -> Set name -> Set name
forall a. Ord a => a -> Set a -> Set a
-| Set name
check) (Contexted (PrimWithName name prim) wY
cp Contexted (PrimWithName name prim) wY
-> [Contexted (PrimWithName name prim) wY]
-> [Contexted (PrimWithName name prim) wY]
forall a. a -> [a] -> [a]
: [Contexted (PrimWithName name prim) wY]
done) RL (RepoPatchV3 name prim) wO wY
cs RL (RepoPatchV3 name prim) wY wY
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL (RepoPatchV3 name prim wY wA
p RepoPatchV3 name prim wY wA
-> FL (RepoPatchV3 name prim) wA wY
-> FL (RepoPatchV3 name prim) wY wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (RepoPatchV3 name prim) wA wY
FL (RepoPatchV3 name prim) wB wY
passedby)
    | Bool
otherwise =
        Set name
-> [Contexted (PrimWithName name prim) wY]
-> RL (RepoPatchV3 name prim) wO wY
-> RL (RepoPatchV3 name prim) wY wY
-> FL (RepoPatchV3 name prim) wY wY
-> [Contexted (PrimWithName name prim) wY]
forall wA wB.
Set name
-> [Contexted (PrimWithName name prim) wY]
-> RL (RepoPatchV3 name prim) wO wA
-> RL (RepoPatchV3 name prim) wA wB
-> FL (RepoPatchV3 name prim) wB wY
-> [Contexted (PrimWithName name prim) wY]
go (RepoPatchV3 name prim wY wA -> PatchId (RepoPatchV3 name prim)
forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident RepoPatchV3 name prim wY wA
p name -> Set name -> Set name
forall a. Ord a => a -> Set a -> Set a
-| Set name
check) [Contexted (PrimWithName name prim) wY]
done RL (RepoPatchV3 name prim) wO wY
cs RL (RepoPatchV3 name prim) wY wY
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL (RepoPatchV3 name prim wY wA
p RepoPatchV3 name prim wY wA
-> FL (RepoPatchV3 name prim) wA wY
-> FL (RepoPatchV3 name prim) wY wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (RepoPatchV3 name prim) wA wY
FL (RepoPatchV3 name prim) wB wY
passedby)
  go Set name
_ [Contexted (PrimWithName name prim) wY]
_ RL (RepoPatchV3 name prim) wO wA
NilRL RL (RepoPatchV3 name prim) wA wB
NilRL FL (RepoPatchV3 name prim) wB wY
_ = String -> [Contexted (PrimWithName name prim) wY]
forall a. HasCallStack => String -> a
error String
"autsch, hit the bottom"

  isConflicted :: RepoPatchV3 name prim wX wY -> Bool
isConflicted Conflictor{} = Bool
True
  isConflicted Prim{} = Bool
False

  conflicts :: RepoPatchV3 b prim wX wX -> Set b
conflicts (Conflictor FL (PrimWithName b prim) wX wX
_ Set (Contexted (PrimWithName b prim) wX)
x Contexted (PrimWithName b prim) wX
_) = (Contexted (PrimWithName b prim) wX -> b)
-> Set (Contexted (PrimWithName b prim) wX) -> Set b
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Contexted (PrimWithName b prim) wX -> b
forall (p :: * -> * -> *) wX.
Ident p =>
Contexted p wX -> PatchId p
ctxId Set (Contexted (PrimWithName b prim) wX)
x
  conflicts RepoPatchV3 b prim wX wX
_ = Set b
forall a. Set a
S.empty

-- | Note that 'ctxNoConflict' also regards dependent contexted prims as
-- "conflicting". That is, if @q@ depends on @p@, then
-- 
-- prop> 'ctxNoConflict' ('ctx' p) ('ctxAdd' p ('ctx' q) == 'False'
-- 
-- This is what we need here, too, in order to avoid conflicts between
-- the separately mangled components.
conflictsWith
  :: (SignedId name, PrimPatch prim)
  => Contexted (PrimWithName name prim) wX
  -> Contexted (PrimWithName name prim) wX
  -> Bool
conflictsWith :: Contexted (PrimWithName name prim) wX
-> Contexted (PrimWithName name prim) wX -> Bool
conflictsWith Contexted (PrimWithName name prim) wX
cp Contexted (PrimWithName name prim) wX
cq = Bool -> Bool
not (Contexted (PrimWithName name prim) wX
-> Contexted (PrimWithName name prim) wX -> Bool
forall (p :: * -> * -> *) wX.
(CleanMerge p, Commute p, Ident p) =>
Contexted p wX -> Contexted p wX -> Bool
ctxNoConflict Contexted (PrimWithName name prim) wX
cp Contexted (PrimWithName name prim) wX
cq)

-- | Determine the conflict graph from a set of contexted prims.
-- This calls 'conflictsWith' for every pair of elements and from that
-- builds a list of 'Node's repesenting this graph.
--
-- TODO: optimize this to calculate only one triangle of the adjacency
-- matrix, then complete the graph by adding inverted edges.
findEdges
  :: (SignedId name, PrimPatch prim)
  => [Contexted (PrimWithName name prim) wY] -> [Node name prim wY]
findEdges :: [Contexted (PrimWithName name prim) wY] -> [Node name prim wY]
findEdges = Set (Contexted (PrimWithName name prim) wY) -> [Node name prim wY]
forall name (prim :: * -> * -> *) wX.
(SignedId name, CleanMerge prim, Commute prim, Invert prim,
 Eq2 prim, IsHunk prim, PatchInspect prim, RepairToFL prim,
 Show2 prim, PrimConstruct prim, PrimCanonize prim,
 PrimClassify prim, PrimDetails prim, PrimApply prim, PrimSift prim,
 PrimMangleUnravelled prim, ReadPatch prim, ShowPatch prim,
 ShowContextPatch prim, PatchListFormat prim) =>
Set (Contexted (PrimWithName name prim) wX) -> [Node name prim wX]
fromVertexSet (Set (Contexted (PrimWithName name prim) wY)
 -> [Node name prim wY])
-> ([Contexted (PrimWithName name prim) wY]
    -> Set (Contexted (PrimWithName name prim) wY))
-> [Contexted (PrimWithName name prim) wY]
-> [Node name prim wY]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Contexted (PrimWithName name prim) wY]
-> Set (Contexted (PrimWithName name prim) wY)
forall a. Ord a => [a] -> Set a
S.fromList
  where
    -- Note we could as well fold over the original input list,
    -- but going via the set has the advantage that the result is
    -- now sorted and therefore independent of the order of patches
    -- in the repo.
    fromVertexSet :: Set (Contexted (PrimWithName name prim) wX) -> [Node name prim wX]
fromVertexSet Set (Contexted (PrimWithName name prim) wX)
vs = (Contexted (PrimWithName name prim) wX
 -> [Node name prim wX] -> [Node name prim wX])
-> [Node name prim wX]
-> Set (Contexted (PrimWithName name prim) wX)
-> [Node name prim wX]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Contexted (PrimWithName name prim) wX
-> [Node name prim wX] -> [Node name prim wX]
go [] Set (Contexted (PrimWithName name prim) wX)
vs
      where
        go :: Contexted (PrimWithName name prim) wX
-> [Node name prim wX] -> [Node name prim wX]
go Contexted (PrimWithName name prim) wX
cp [Node name prim wX]
ns = Contexted (PrimWithName name prim) wX
-> Set (Contexted (PrimWithName name prim) wX) -> Node name prim wX
forall name (prim :: * -> * -> *) wY.
Contexted (PrimWithName name prim) wY
-> Set (Contexted (PrimWithName name prim) wY) -> Node name prim wY
Node Contexted (PrimWithName name prim) wX
cp ((Contexted (PrimWithName name prim) wX -> Bool)
-> Set (Contexted (PrimWithName name prim) wX)
-> Set (Contexted (PrimWithName name prim) wX)
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Contexted (PrimWithName name prim) wX
-> Contexted (PrimWithName name prim) wX -> Bool
forall name (prim :: * -> * -> *) wX.
(SignedId name, PrimPatch prim) =>
Contexted (PrimWithName name prim) wX
-> Contexted (PrimWithName name prim) wX -> Bool
conflictsWith Contexted (PrimWithName name prim) wX
cp) Set (Contexted (PrimWithName name prim) wX)
vs) Node name prim wX -> [Node name prim wX] -> [Node name prim wX]
forall a. a -> [a] -> [a]
: [Node name prim wX]
ns

-- | The input is a list of nodes with no duplicates representing a connected
-- component of the conflict graph. The list contains an element for
-- each node in the graph, but the conflicts (edges) may refer to non-nodes.
-- The output is a list of the maximal independent sets of the conflict graph:
-- each one can be merged cleanly.
alternatives
  :: SignedId name
  => [Node name prim wX]
  -> [[[Contexted (PrimWithName name prim) wX]]]
alternatives :: [Node name prim wX] -> [[[Contexted (PrimWithName name prim) wX]]]
alternatives [Node name prim wX]
nodes =
    (Component -> [[Contexted (PrimWithName name prim) wX]])
-> [Component] -> [[[Contexted (PrimWithName name prim) wX]]]
forall a b. (a -> b) -> [a] -> [b]
map (([Int] -> [Contexted (PrimWithName name prim) wX])
-> [[Int]] -> [[Contexted (PrimWithName name prim) wX]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Contexted (PrimWithName name prim) wX]
fromVertexSet ([[Int]] -> [[Contexted (PrimWithName name prim) wX]])
-> (Component -> [[Int]])
-> Component
-> [[Contexted (PrimWithName name prim) wX]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, Bool) -> Component -> [[Int]]
ltmis (Bool
True, Bool
True)) ([Component] -> [[[Contexted (PrimWithName name prim) wX]]])
-> [Component] -> [[[Contexted (PrimWithName name prim) wX]]]
forall a b. (a -> b) -> a -> b
$ Graph -> [Component]
components Graph
graph
  where
    -- a map from indexes (of type Vertex) to nodes
    from_index :: Vector (Contexted (PrimWithName name prim) wX)
from_index = [Contexted (PrimWithName name prim) wX]
-> Vector (Contexted (PrimWithName name prim) wX)
forall a. [a] -> Vector a
V.fromList ([Contexted (PrimWithName name prim) wX]
 -> Vector (Contexted (PrimWithName name prim) wX))
-> [Contexted (PrimWithName name prim) wX]
-> Vector (Contexted (PrimWithName name prim) wX)
forall a b. (a -> b) -> a -> b
$ (Node name prim wX -> Contexted (PrimWithName name prim) wX)
-> [Node name prim wX] -> [Contexted (PrimWithName name prim) wX]
forall a b. (a -> b) -> [a] -> [b]
map Node name prim wX -> Contexted (PrimWithName name prim) wX
forall name (prim :: * -> * -> *) wY.
Node name prim wY -> Contexted (PrimWithName name prim) wY
self [Node name prim wX]
nodes
    -- a map from prim IDs (representing nodes) to indexes
    to_index :: Map name Int
to_index = [(name, Int)] -> Map name Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(name, Int)] -> Map name Int) -> [(name, Int)] -> Map name Int
forall a b. (a -> b) -> a -> b
$ [name] -> [Int] -> [(name, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Node name prim wX -> name) -> [Node name prim wX] -> [name]
forall a b. (a -> b) -> [a] -> [b]
map (Contexted (PrimWithName name prim) wX -> name
forall (p :: * -> * -> *) wX.
Ident p =>
Contexted p wX -> PatchId p
ctxId (Contexted (PrimWithName name prim) wX -> name)
-> (Node name prim wX -> Contexted (PrimWithName name prim) wX)
-> Node name prim wX
-> name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node name prim wX -> Contexted (PrimWithName name prim) wX
forall name (prim :: * -> * -> *) wY.
Node name prim wY -> Contexted (PrimWithName name prim) wY
self) [Node name prim wX]
nodes) [(Int
0::Vertex) ..]
    -- the full component of the conflict graph with each node
    -- represented by an index of type Vertex
    graph :: Graph
graph = [[Int]] -> Graph
forall a. [a] -> Vector a
V.fromList ([[Int]] -> Graph) -> [[Int]] -> Graph
forall a b. (a -> b) -> a -> b
$ (Node name prim wX -> [Int]) -> [Node name prim wX] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map Node name prim wX -> [Int]
forall (prim :: * -> * -> *) wX. Node name prim wX -> [Int]
adj_list [Node name prim wX]
nodes
    -- the adjacency list of a single node
    adj_list :: Node name prim wX -> [Int]
adj_list =
      [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Int] -> [Int])
-> (Node name prim wX -> [Maybe Int]) -> Node name prim wX -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Contexted (PrimWithName name prim) wX -> Maybe Int)
-> [Contexted (PrimWithName name prim) wX] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map ((name -> Map name Int -> Maybe Int)
-> Map name Int -> name -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip name -> Map name Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map name Int
to_index (name -> Maybe Int)
-> (Contexted (PrimWithName name prim) wX -> name)
-> Contexted (PrimWithName name prim) wX
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contexted (PrimWithName name prim) wX -> name
forall (p :: * -> * -> *) wX.
Ident p =>
Contexted p wX -> PatchId p
ctxId) ([Contexted (PrimWithName name prim) wX] -> [Maybe Int])
-> (Node name prim wX -> [Contexted (PrimWithName name prim) wX])
-> Node name prim wX
-> [Maybe Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Contexted (PrimWithName name prim) wX)
-> [Contexted (PrimWithName name prim) wX]
forall a. Set a -> [a]
S.toList (Set (Contexted (PrimWithName name prim) wX)
 -> [Contexted (PrimWithName name prim) wX])
-> (Node name prim wX
    -> Set (Contexted (PrimWithName name prim) wX))
-> Node name prim wX
-> [Contexted (PrimWithName name prim) wX]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node name prim wX -> Set (Contexted (PrimWithName name prim) wX)
forall name (prim :: * -> * -> *) wY.
Node name prim wY -> Set (Contexted (PrimWithName name prim) wY)
neighbors
    fromVertexSet :: [Int] -> [Contexted (PrimWithName name prim) wX]
fromVertexSet = (Int -> Contexted (PrimWithName name prim) wX)
-> [Int] -> [Contexted (PrimWithName name prim) wX]
forall a b. (a -> b) -> [a] -> [b]
map (Vector (Contexted (PrimWithName name prim) wX)
from_index Vector (Contexted (PrimWithName name prim) wX)
-> Int -> Contexted (PrimWithName name prim) wX
forall a. Vector a -> Int -> a
V.!)

-- This is similar to the mergeList in Darcs.Patch.CommuteNoConflicts
-- but not the same since we have PatchIds.
mergeList
  :: (SignedId name, StorableId name, PrimPatch p)
  => [Sealed (FL (PrimWithName name p) wX)] -> Sealed (FL (PrimWithName name p) wX)
mergeList :: [Sealed (FL (PrimWithName name p) wX)]
-> Sealed (FL (PrimWithName name p) wX)
mergeList = (Sealed (FL (PrimWithName name p) wX)
 -> Sealed (FL (PrimWithName name p) wX)
 -> Sealed (FL (PrimWithName name p) wX))
-> Sealed (FL (PrimWithName name p) wX)
-> [Sealed (FL (PrimWithName name p) wX)]
-> Sealed (FL (PrimWithName name p) wX)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Sealed (FL (PrimWithName name p) wX)
-> Sealed (FL (PrimWithName name p) wX)
-> Sealed (FL (PrimWithName name p) wX)
forall (p :: * -> * -> *) wX.
(Commute p, Ident p, CleanMerge p, PatchListFormat p,
 ShowPatchBasic p) =>
Sealed (FL p wX) -> Sealed (FL p wX) -> Sealed (FL p wX)
mergeTwo (FL (PrimWithName name p) wX wX
-> Sealed (FL (PrimWithName name p) wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL (PrimWithName name p) wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
  where
    mergeTwo :: Sealed (FL p wX) -> Sealed (FL p wX) -> Sealed (FL p wX)
mergeTwo (Sealed FL p wX wX
ps) (Sealed qs) =
      case FL p wX wX -> FL p wX wX -> Fork (FL p) (FL p) (FL p) wX wX wX
forall (p :: * -> * -> *) wX wY wZ.
(Commute p, Ident p) =>
FL p wX wY -> FL p wX wZ -> Fork (FL p) (FL p) (FL p) wX wY wZ
findCommonFL FL p wX wX
ps FL p wX wX
qs of
        Fork FL p wX wU
com FL p wU wX
ps' FL p wU wX
qs' ->
          case (:\/:) (FL p) (FL p) wX wX -> Maybe ((:/\:) (FL p) (FL p) wX wX)
forall (p :: * -> * -> *) wX wY.
CleanMerge p =>
(:\/:) p p wX wY -> Maybe ((:/\:) p p wX wY)
cleanMerge (FL p wU wX
ps' FL p wU wX -> FL p wU wX -> (:\/:) (FL p) (FL p) wX wX
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wZ wX -> a2 wZ wY -> (:\/:) a1 a2 wX wY
:\/: FL p wU wX
qs') of
            Just (FL p wX wZ
qs'' :/\: FL p wX wZ
_) -> FL p wX wZ -> Sealed (FL p wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (FL p wX wZ -> Sealed (FL p wX)) -> FL p wX wZ -> Sealed (FL p wX)
forall a b. (a -> b) -> a -> b
$ FL p wX wU
com FL p wX wU -> FL p wU wZ -> FL p wX wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL p wU wX
ps' FL p wU wX -> FL p wX wZ -> FL p wU wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL p wX wZ
qs''
            Maybe ((:/\:) (FL p) (FL p) wX wX)
Nothing ->
              String -> Sealed (FL p wX)
forall a. HasCallStack => String -> a
error (String -> Sealed (FL p wX)) -> String -> Sealed (FL p wX)
forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString
                (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
redText String
"resolutions conflict:"
                Doc -> Doc -> Doc
$$ FL p wX wX -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL p wX wX
ps
                Doc -> Doc -> Doc
$$ String -> Doc
redText String
"conflicts with"
                Doc -> Doc -> Doc
$$ FL p wX wX -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL p wX wX
qs

-- We only use displayPatch for error messages here, so it makes sense
-- to use the storage format that contains the patch names.
displayPatch :: ShowPatchBasic p => p wX wY -> Doc
displayPatch :: p wX wY -> Doc
displayPatch p wX wY
p = ShowPatchFor -> p wX wY -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
ForStorage p wX wY
p