{- | 'Conflictor's a la camp.

Similar to the camp paper, but with a few differences:

* no reverse conflictors and no Invert instance

* instead we directly implement cleanMerge

* minor details of merge and commute due to bug fixes

-}

{-# LANGUAGE ViewPatterns, PatternSynonyms #-}
module Darcs.Patch.V3.Core
    ( RepoPatchV3(..)
    , pattern PrimP
    , pattern ConflictorP
    , (+|)
    , (-|)
    ) where

import Control.Applicative ( Alternative(..) )
import Control.Monad ( guard )
import qualified Data.ByteString.Char8 as BC
import Data.List.Ordered ( nubSort )
import qualified Data.Set as S

import Darcs.Prelude

import Darcs.Patch.Commute ( commuteFL, commuteRL, commuteRLFL )
import Darcs.Patch.CommuteFn ( CommuteFn )
import Darcs.Patch.CommuteNoConflicts ( CommuteNoConflicts(..) )
import Darcs.Patch.Debug ( PatchDebug(..) )
import Darcs.Patch.FileHunk ( IsHunk(..) )
import Darcs.Patch.Format ( ListFormat(ListFormatV3) )
import Darcs.Patch.FromPrim ( ToPrim(..) )
import Darcs.Patch.Ident
    ( Ident(..)
    , IdEq2(..)
    , PatchId
    , SignedId(..)
    , StorableId(..)
    , commuteToPrefix
    , fastRemoveFL
    , findCommonFL
    )
import Darcs.Patch.Invert ( Invert, invert, invertFL )
import Darcs.Patch.Merge
    ( CleanMerge(..)
    , Merge(..)
    , cleanMergeFL
    , swapCleanMerge
    , swapMerge
    )
import Darcs.Patch.Prim ( PrimPatch, applyPrimFL )
import Darcs.Patch.Prim.WithName ( PrimWithName, wnPatch )
import Darcs.Patch.Read ( bracketedFL )
import Darcs.Patch.Repair (RepairToFL(..), Check(..) )
import Darcs.Patch.RepoPatch
    ( Apply(..)
    , Commute(..)
    , Effect(..)
    , Eq2(..)
    , PatchInspect(..)
    , PatchListFormat(..)
    , PrimPatchBase(..)
    , ReadPatch(..)
    , Summary(..)
    )
import Darcs.Patch.Show hiding ( displayPatch )
import Darcs.Patch.Summary
    ( ConflictState(..)
    , IsConflictedPrim(..)
    , plainSummary
    , plainSummaryFL
    )
import Darcs.Patch.Unwind ( Unwind(..), mkUnwound )
import Darcs.Patch.V3.Contexted
    ( Contexted
    , ctxId
    , ctxView
    , ctxNoConflict
    , ctx
    , ctxAddRL
    , ctxAddInvFL
    , ctxAddFL
    , commutePast
    , commutePastRL
    , ctxTouches
    , ctxHunkMatches
    , showCtx
    , readCtx
    )
import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )
import Darcs.Patch.Witnesses.Ordered
    ( (:/\:)(..)
    , (:>)(..)
    , (:\/:)(..)
    , FL(..)
    , Fork(..)
    , (+>+)
    , mapFL
    , mapFL_FL
    , reverseFL
    , reverseRL
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )
import Darcs.Patch.Witnesses.Show ( Show1, Show2, appPrec, showsPrec2 )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP1 )

import Darcs.Test.TestOnly

import Darcs.Util.Parser ( string, lexString, choice, skipSpace )
import Darcs.Util.Printer
    ( Doc
    , ($$)
    , (<+>)
    , blueText
    , redText
    , renderString
    , vcat
    )

data RepoPatchV3 name prim wX wY where
  Prim :: PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY
  Conflictor :: FL (PrimWithName name prim) wX wY             -- ^ effect
             -> S.Set (Contexted (PrimWithName name prim) wY) -- ^ conflicts
             -> Contexted (PrimWithName name prim) wY         -- ^ identity
             -> RepoPatchV3 name prim wX wY

{- Naming convention: If we don't examine the contents of a RepoPatchV3, we
use @p@ (on the lhs) and @q@ (on the rhs), otherwise these names refer to
the (uncontexted) prims they represent (regardless of whether they are
conflicted or not). The components of Conflictors are named as follows: On
the lhs we use @Conflictor r x cp@, on the rhs @Conflictor s y cq@, execpt
when we have two conflictors that may have common prims in their effects. In
that case we use @com_r@ and @com_s@ for the effects and use @r@ and @s@ for
the uncommon parts (and @com@ for the common part). Primed versions always
refer to things with the same ident/name i.e. they are commuted versions of
the un-primed ones. -}

-- TODO now that we export the constructors of RepoPatchV3 these
-- pattern synonyms could probably be removed
pattern PrimP :: TestOnly => PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY
pattern $mPrimP :: forall {r} {name} {prim :: * -> * -> *} {wX} {wY}.
TestOnly =>
RepoPatchV3 name prim wX wY
-> (PrimWithName name prim wX wY -> r) -> ((# #) -> r) -> r
PrimP prim <- Prim prim

pattern ConflictorP
  :: TestOnly
  => FL (PrimWithName name prim) wX wY
  -> S.Set (Contexted (PrimWithName name prim) wY)
  -> Contexted (PrimWithName name prim) wY
  -> RepoPatchV3 name prim wX wY
pattern $mConflictorP :: forall {r} {name} {prim :: * -> * -> *} {wX} {wY}.
TestOnly =>
RepoPatchV3 name prim wX wY
-> (FL (PrimWithName name prim) wX wY
    -> Set (Contexted (PrimWithName name prim) wY)
    -> Contexted (PrimWithName name prim) wY
    -> r)
-> ((# #) -> r)
-> r
ConflictorP r x cp <- Conflictor r x cp

-- * Effect

instance Effect (RepoPatchV3 name prim) where
  effect :: forall wX wY.
RepoPatchV3 name prim wX wY
-> FL (PrimOf (RepoPatchV3 name prim)) wX wY
effect (Prim PrimWithName name prim wX wY
p) = forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch PrimWithName name prim wX wY
p forall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
  effect (Conflictor FL (PrimWithName name prim) wX wY
r Set (Contexted (PrimWithName name prim) wY)
_ Contexted (PrimWithName name prim) wY
_) = 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 name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch FL (PrimWithName name prim) wX wY
r

-- * Ident

type instance PatchId (RepoPatchV3 name prim) = name

instance SignedId name => Ident (RepoPatchV3 name prim) where
  ident :: forall wX wY.
RepoPatchV3 name prim wX wY -> PatchId (RepoPatchV3 name prim)
ident (Prim PrimWithName name prim wX wY
p) = forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident PrimWithName name prim wX wY
p
  ident (Conflictor FL (PrimWithName name prim) wX wY
_ Set (Contexted (PrimWithName name prim) wY)
_ Contexted (PrimWithName name prim) wY
cp) = forall (p :: * -> * -> *) wX.
Ident p =>
Contexted p wX -> PatchId p
ctxId Contexted (PrimWithName name prim) wY
cp

-- * Merge

-- 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 :: forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch p wX wY
p = forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
ForStorage p wX wY
p

instance (SignedId name, StorableId name, PrimPatch prim) =>
         CleanMerge (RepoPatchV3 name prim) where
  cleanMerge :: forall wX wY.
(:\/:) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
-> Maybe
     ((:/\:) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY)
cleanMerge (RepoPatchV3 name prim wZ wX
p :\/: RepoPatchV3 name prim wZ wY
q)
    | forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident RepoPatchV3 name prim wZ wX
p forall a. Eq a => a -> a -> Bool
== forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident RepoPatchV3 name prim wZ wY
q = forall a. HasCallStack => [Char] -> a
error [Char]
"merging identical patches is undefined"
  cleanMerge (Prim PrimWithName name prim wZ wX
p :\/: Prim PrimWithName name prim wZ wY
q) = do
    PrimWithName name prim wX wZ
q' :/\: PrimWithName name prim wY wZ
p' <- forall (p :: * -> * -> *) wX wY.
CleanMerge p =>
(:\/:) p p wX wY -> Maybe ((:/\:) p p wX wY)
cleanMerge (PrimWithName name prim wZ wX
p forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wZ wX -> a2 wZ wY -> (:\/:) a1 a2 wX wY
:\/: PrimWithName name prim wZ wY
q)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall name (prim :: * -> * -> *) wX wY.
PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY
Prim PrimWithName name prim wX wZ
q' forall (a3 :: * -> * -> *) (a4 :: * -> * -> *) wX wY wZ.
a3 wX wZ -> a4 wY wZ -> (:/\:) a3 a4 wX wY
:/\: forall name (prim :: * -> * -> *) wX wY.
PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY
Prim PrimWithName name prim wY wZ
p'
  cleanMerge (Prim PrimWithName name prim wZ wX
p :\/: Conflictor FL (PrimWithName name prim) wZ wY
s Set (Contexted (PrimWithName name prim) wY)
y Contexted (PrimWithName name prim) wY
cq) = do
    -- note: p cannot occur in y, because every element of y already
    -- exists in the history /before/ the rhs, and PatchIds must be
    -- unique in a repo
    FL (PrimWithName name prim) wX wZ
s' :/\: PrimWithName name prim wY wZ
p' <- forall (p :: * -> * -> *). CleanMerge p => PartialMergeFn p (FL p)
cleanMergeFL (PrimWithName name prim wZ wX
p forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wZ wX -> a2 wZ wY -> (:\/:) a1 a2 wX wY
:\/: FL (PrimWithName name prim) wZ wY
s)
    let ip' :: PrimWithName name prim wZ wY
ip' = forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert PrimWithName name prim wY wZ
p'
    Contexted (PrimWithName name prim) wZ
cq' <- forall (p :: * -> * -> *) wX wY.
Commute p =>
p wX wY -> Contexted p wY -> Maybe (Contexted p wX)
commutePast PrimWithName name prim wZ wY
ip' Contexted (PrimWithName name prim) wY
cq
    Set (Contexted (PrimWithName name prim) wZ)
y' <- forall a. Ord a => [a] -> Set a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (p :: * -> * -> *) wX wY.
Commute p =>
p wX wY -> Contexted p wY -> Maybe (Contexted p wX)
commutePast PrimWithName name prim wZ wY
ip') (forall a. Set a -> [a]
S.toList Set (Contexted (PrimWithName name prim) wY)
y)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor FL (PrimWithName name prim) wX wZ
s' Set (Contexted (PrimWithName name prim) wZ)
y' Contexted (PrimWithName name prim) wZ
cq' forall (a3 :: * -> * -> *) (a4 :: * -> * -> *) wX wY wZ.
a3 wX wZ -> a4 wY wZ -> (:/\:) a3 a4 wX wY
:/\: forall name (prim :: * -> * -> *) wX wY.
PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY
Prim PrimWithName name prim wY wZ
p'
  cleanMerge pair :: (:\/:) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
pair@(Conflictor {} :\/: Prim {}) = forall (p :: * -> * -> *) wX wY.
CleanMerge p =>
(:\/:) p p wX wY -> Maybe ((:/\:) p p wX wY)
swapCleanMerge (:\/:) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
pair
  cleanMerge (Conflictor FL (PrimWithName name prim) wZ wX
com_r Set (Contexted (PrimWithName name prim) wX)
x Contexted (PrimWithName name prim) wX
cp :\/: Conflictor FL (PrimWithName name prim) wZ wY
com_s Set (Contexted (PrimWithName name prim) wY)
y Contexted (PrimWithName name prim) wY
cq) =
    case 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 (PrimWithName name prim) wZ wX
com_r FL (PrimWithName name prim) wZ wY
com_s of
      Fork FL (PrimWithName name prim) wZ wU
_ FL (PrimWithName name prim) wU wX
rev_r FL (PrimWithName name prim) wU wY
rev_s -> do
        FL (PrimWithName name prim) wX wZ
s' :/\: FL (PrimWithName name prim) wY wZ
r' <- forall (p :: * -> * -> *) wX wY.
CleanMerge p =>
(:\/:) p p wX wY -> Maybe ((:/\:) p p wX wY)
cleanMerge (FL (PrimWithName name prim) wU wX
rev_r forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wZ wX -> a2 wZ wY -> (:\/:) a1 a2 wX wY
:\/: FL (PrimWithName name prim) wU wY
rev_s)
        -- the paper uses commutePast to calculate cp' and cq', but this must
        -- succeed (and then give the same result as adding to the context)
        -- because of the ctxNoConflict guards below
        let cp' :: Contexted (PrimWithName name prim) wZ
cp' = forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wX wZ
s' Contexted (PrimWithName name prim) wX
cp
        let cq' :: Contexted (PrimWithName name prim) wZ
cq' = forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wY wZ
r' Contexted (PrimWithName name prim) wY
cq
        let x' :: Set (Contexted (PrimWithName name prim) wZ)
x' = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wX wZ
s') Set (Contexted (PrimWithName name prim) wX)
x
        let y' :: Set (Contexted (PrimWithName name prim) wZ)
y' = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wY wZ
r') Set (Contexted (PrimWithName name prim) wY)
y
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall (p :: * -> * -> *) wX.
(CleanMerge p, Commute p, Ident p) =>
Contexted p wX -> Contexted p wX -> Bool
ctxNoConflict Contexted (PrimWithName name prim) wZ
cq' Contexted (PrimWithName name prim) wZ
cp')
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (p :: * -> * -> *) wX.
(CleanMerge p, Commute p, Ident p) =>
Contexted p wX -> Contexted p wX -> Bool
ctxNoConflict Contexted (PrimWithName name prim) wZ
cq') (forall a. Ord a => Set a -> Set a -> Set a
S.difference Set (Contexted (PrimWithName name prim) wZ)
x' Set (Contexted (PrimWithName name prim) wZ)
y')
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (p :: * -> * -> *) wX.
(CleanMerge p, Commute p, Ident p) =>
Contexted p wX -> Contexted p wX -> Bool
ctxNoConflict Contexted (PrimWithName name prim) wZ
cp') (forall a. Ord a => Set a -> Set a -> Set a
S.difference Set (Contexted (PrimWithName name prim) wZ)
y' Set (Contexted (PrimWithName name prim) wZ)
x')
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor FL (PrimWithName name prim) wX wZ
s' Set (Contexted (PrimWithName name prim) wZ)
y' Contexted (PrimWithName name prim) wZ
cq' forall (a3 :: * -> * -> *) (a4 :: * -> * -> *) wX wY wZ.
a3 wX wZ -> a4 wY wZ -> (:/\:) a3 a4 wX wY
:/\: forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor FL (PrimWithName name prim) wY wZ
r' Set (Contexted (PrimWithName name prim) wZ)
x' Contexted (PrimWithName name prim) wZ
cp'

instance (SignedId name, StorableId name, PrimPatch prim) =>
         Merge (RepoPatchV3 name prim) where
  -- * no conflict
  merge :: forall wX wY.
(:\/:) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
-> (:/\:) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
merge (:\/:) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
pq | Just (:/\:) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
r <- forall (p :: * -> * -> *) wX wY.
CleanMerge p =>
(:\/:) p p wX wY -> Maybe ((:/\:) p p wX wY)
cleanMerge (:\/:) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
pq = (:/\:) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
r
  -- * conflicting prim patches:
  -- If we have p and pull conflicting q, we make a conflictor
  -- that inverts p, conflicts with p, and represents q.
  merge (Prim PrimWithName name prim wZ wX
p :\/: Prim PrimWithName name prim wZ wY
q) =
    forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert PrimWithName name prim wZ wX
p forall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) (forall a. a -> Set a
S.singleton (forall (p :: * -> * -> *) wX wY. p wX wY -> Contexted p wX
ctx PrimWithName name prim wZ wX
p)) (forall (p :: * -> * -> *) wX wY. p wX wY -> Contexted p wX
ctx PrimWithName name prim wZ wY
q)
    forall (a3 :: * -> * -> *) (a4 :: * -> * -> *) wX wY wZ.
a3 wX wZ -> a4 wY wZ -> (:/\:) a3 a4 wX wY
:/\:
    forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert PrimWithName name prim wZ wY
q forall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) (forall a. a -> Set a
S.singleton (forall (p :: * -> * -> *) wX wY. p wX wY -> Contexted p wX
ctx PrimWithName name prim wZ wY
q)) (forall (p :: * -> * -> *) wX wY. p wX wY -> Contexted p wX
ctx PrimWithName name prim wZ wX
p)
  -- * prim patch p conflicting with conflictor on the rhs:
  -- The rhs is the first to conflict with p, so must we add invert p
  -- to its effect, and to its conflicts (adding invert r as context for p).
  -- For the other branch, we add a new conflictor representing p. It
  -- conflicts with q and has no effect, since q is already conflicted.
  merge (Prim PrimWithName name prim wZ wX
p :\/: Conflictor FL (PrimWithName name prim) wZ wY
r Set (Contexted (PrimWithName name prim) wY)
x Contexted (PrimWithName name prim) wY
cq) =
    forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert PrimWithName name prim wZ wX
p forall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>: FL (PrimWithName name prim) wZ wY
r) (forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wZ wY
r (forall (p :: * -> * -> *) wX wY. p wX wY -> Contexted p wX
ctx PrimWithName name prim wZ wX
p) forall a. Ord a => a -> Set a -> Set a
+| Set (Contexted (PrimWithName name prim) wY)
x) Contexted (PrimWithName name prim) wY
cq
    forall (a3 :: * -> * -> *) (a4 :: * -> * -> *) wX wY wZ.
a3 wX wZ -> a4 wY wZ -> (:/\:) a3 a4 wX wY
:/\:
    forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor forall (a :: * -> * -> *) wX. FL a wX wX
NilFL (forall a. a -> Set a
S.singleton Contexted (PrimWithName name prim) wY
cq) (forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wZ wY
r (forall (p :: * -> * -> *) wX wY. p wX wY -> Contexted p wX
ctx PrimWithName name prim wZ wX
p))
  -- same as previous case with both sides swapped
  merge pair :: (:\/:) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
pair@(Conflictor {} :\/: Prim {}) = forall (p :: * -> * -> *) wX wY.
Merge p =>
(:\/:) p p wX wY -> (:/\:) p p wX wY
swapMerge (:\/:) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
pair
  -- * conflictor c1 conflicts with conflictor c2:
  -- If we pull c2 onto c1, we remove everything common to both effects
  -- from the effect of c2 (but still remember that we conflict with them).
  -- We also record that we now conflict with c1, too, and as before keep
  -- our identity unchanged. The rest consists of adapting contexts.
  --
  -- Note: we assume that the uncommon parts of the effects of both
  -- conflictors do not themselves conflict with each other, so we can
  -- use cleanMerge for them.
  merge (lhs :: RepoPatchV3 name prim wZ wX
lhs@(Conflictor FL (PrimWithName name prim) wZ wX
com_r Set (Contexted (PrimWithName name prim) wX)
x Contexted (PrimWithName name prim) wX
cp) :\/: rhs :: RepoPatchV3 name prim wZ wY
rhs@(Conflictor FL (PrimWithName name prim) wZ wY
com_s Set (Contexted (PrimWithName name prim) wY)
y Contexted (PrimWithName name prim) wY
cq)) =
    case 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 (PrimWithName name prim) wZ wX
com_r FL (PrimWithName name prim) wZ wY
com_s of
      Fork FL (PrimWithName name prim) wZ wU
_ FL (PrimWithName name prim) wU wX
r FL (PrimWithName name prim) wU wY
s ->
        case forall (p :: * -> * -> *) wX wY.
CleanMerge p =>
(:\/:) p p wX wY -> Maybe ((:/\:) p p wX wY)
cleanMerge (FL (PrimWithName name prim) wU wX
r forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wZ wX -> a2 wZ wY -> (:\/:) a1 a2 wX wY
:\/: FL (PrimWithName name prim) wU wY
s) of
          Just (FL (PrimWithName name prim) wX wZ
s' :/\: FL (PrimWithName name prim) wY wZ
r') ->
            let cp' :: Contexted (PrimWithName name prim) wZ
cp' = forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wX wZ
s' Contexted (PrimWithName name prim) wX
cp
                cq' :: Contexted (PrimWithName name prim) wZ
cq' = forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wY wZ
r' Contexted (PrimWithName name prim) wY
cq
                x' :: Set (Contexted (PrimWithName name prim) wZ)
x' = Contexted (PrimWithName name prim) wZ
cq' forall a. Ord a => a -> Set a -> Set a
+| forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wX wZ
s') Set (Contexted (PrimWithName name prim) wX)
x
                y' :: Set (Contexted (PrimWithName name prim) wZ)
y' = Contexted (PrimWithName name prim) wZ
cp' forall a. Ord a => a -> Set a -> Set a
+| forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wY wZ
r') Set (Contexted (PrimWithName name prim) wY)
y
            in forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor FL (PrimWithName name prim) wX wZ
s' Set (Contexted (PrimWithName name prim) wZ)
y' Contexted (PrimWithName name prim) wZ
cq' forall (a3 :: * -> * -> *) (a4 :: * -> * -> *) wX wY wZ.
a3 wX wZ -> a4 wY wZ -> (:/\:) a3 a4 wX wY
:/\: forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor FL (PrimWithName name prim) wY wZ
r' Set (Contexted (PrimWithName name prim) wZ)
x' Contexted (PrimWithName name prim) wZ
cp'
          Maybe
  ((:/\:)
     (FL (PrimWithName name prim)) (FL (PrimWithName name prim)) wX wY)
Nothing ->
            forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ Doc -> [Char]
renderString forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
redText [Char]
"uncommon effects can't be merged cleanly:"
              Doc -> Doc -> Doc
$$ [Char] -> Doc
redText [Char]
"lhs:" Doc -> Doc -> Doc
$$ forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch RepoPatchV3 name prim wZ wX
lhs
              Doc -> Doc -> Doc
$$ [Char] -> Doc
redText [Char]
"rhs:" Doc -> Doc -> Doc
$$ forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch RepoPatchV3 name prim wZ wY
rhs
              Doc -> Doc -> Doc
$$ [Char] -> Doc
redText [Char]
"r:" Doc -> Doc -> Doc
$$ forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimWithName name prim) wU wX
r
              Doc -> Doc -> Doc
$$ [Char] -> Doc
redText [Char]
"s:" Doc -> Doc -> Doc
$$ forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimWithName name prim) wU wY
s

-- * CommuteNoConflicts

instance (SignedId name, StorableId name, PrimPatch prim)
  => CommuteNoConflicts (RepoPatchV3 name prim) where

  -- two prim patches that commute
  commuteNoConflicts :: forall wX wY.
(:>) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
-> Maybe
     ((:>) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY)
commuteNoConflicts (Prim PrimWithName name prim wX wZ
p :> Prim PrimWithName name prim wZ wY
q)
    | Just (PrimWithName name prim wX wZ
q' :> PrimWithName name prim wZ wY
p') <- forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (PrimWithName name prim wX wZ
p forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> PrimWithName name prim wZ wY
q) = forall a. a -> Maybe a
Just (forall name (prim :: * -> * -> *) wX wY.
PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY
Prim PrimWithName name prim wX wZ
q' forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> forall name (prim :: * -> * -> *) wX wY.
PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY
Prim PrimWithName name prim wZ wY
p')
  -- commute a conflictor past a prim patch where everything goes smoothly
  commuteNoConflicts (Conflictor FL (PrimWithName name prim) wX wZ
r Set (Contexted (PrimWithName name prim) wZ)
x Contexted (PrimWithName name prim) wZ
cp :> Prim PrimWithName name prim wZ wY
q)
    | Just (PrimWithName name prim wX wZ
q' :> RL (PrimWithName name prim) wZ wY
r') <- forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) (RL p) p wX wY -> Maybe ((:>) p (RL p) wX wY)
commuteRL (forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PrimWithName name prim) wX wZ
r forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> PrimWithName name prim wZ wY
q)
    , let iq :: PrimWithName name prim wY wZ
iq = forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert PrimWithName name prim wZ wY
q
    , Just Contexted (PrimWithName name prim) wY
cp' <- forall (p :: * -> * -> *) wX wY.
Commute p =>
p wX wY -> Contexted p wY -> Maybe (Contexted p wX)
commutePast PrimWithName name prim wY wZ
iq Contexted (PrimWithName name prim) wZ
cp
    , Just Set (Contexted (PrimWithName name prim) wY)
x' <- forall a. Ord a => [a] -> Set a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (p :: * -> * -> *) wX wY.
Commute p =>
p wX wY -> Contexted p wY -> Maybe (Contexted p wX)
commutePast PrimWithName name prim wY wZ
iq) (forall a. Set a -> [a]
S.toList Set (Contexted (PrimWithName name prim) wZ)
x) =
        forall a. a -> Maybe a
Just (forall name (prim :: * -> * -> *) wX wY.
PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY
Prim PrimWithName name prim wX wZ
q' forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor (forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL (PrimWithName name prim) wZ wY
r') Set (Contexted (PrimWithName name prim) wY)
x' Contexted (PrimWithName name prim) wY
cp')
  -- commute a prim patch past a conflictor where everything goes smoothly
  commuteNoConflicts (Prim PrimWithName name prim wX wZ
p :> Conflictor FL (PrimWithName name prim) wZ wY
s Set (Contexted (PrimWithName name prim) wY)
y Contexted (PrimWithName name prim) wY
cq)
    | Just (FL (PrimWithName name prim) wX wZ
s' :> PrimWithName name prim wZ wY
p') <- forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> Maybe ((:>) (FL p) p wX wY)
commuteFL (PrimWithName name prim wX wZ
p forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PrimWithName name prim) wZ wY
s)
    , Just Contexted (PrimWithName name prim) wZ
cq' <- forall (p :: * -> * -> *) wX wY.
Commute p =>
p wX wY -> Contexted p wY -> Maybe (Contexted p wX)
commutePast PrimWithName name prim wZ wY
p' Contexted (PrimWithName name prim) wY
cq
    , Just Set (Contexted (PrimWithName name prim) wZ)
y' <- forall a. Ord a => [a] -> Set a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (p :: * -> * -> *) wX wY.
Commute p =>
p wX wY -> Contexted p wY -> Maybe (Contexted p wX)
commutePast PrimWithName name prim wZ wY
p') (forall a. Set a -> [a]
S.toList Set (Contexted (PrimWithName name prim) wY)
y) =
        forall a. a -> Maybe a
Just (forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor FL (PrimWithName name prim) wX wZ
s' Set (Contexted (PrimWithName name prim) wZ)
y' Contexted (PrimWithName name prim) wZ
cq' forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> forall name (prim :: * -> * -> *) wX wY.
PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY
Prim PrimWithName name prim wZ wY
p')
  -- commuting a conflictor past another one
  -- e.g. [z^, {:z}, :y] :> [, {:z}, :x] where x :> y <-> y :> x
  commuteNoConflicts (Conflictor FL (PrimWithName name prim) wX wZ
com_r Set (Contexted (PrimWithName name prim) wZ)
x Contexted (PrimWithName name prim) wZ
cp :> Conflictor FL (PrimWithName name prim) wZ wY
s Set (Contexted (PrimWithName name prim) wY)
y Contexted (PrimWithName name prim) wY
cq) = do
    -- com = prims in the effect of the lhs that the rhs also conflicts with
    FL (PrimWithName name prim) wX wZ
com :> RL (PrimWithName name prim) wZ wZ
rr <- forall (p :: * -> * -> *) wX wY.
(Commute p, Ident p) =>
Set (PatchId p) -> FL p wX wY -> Maybe ((:>) (FL p) (RL p) wX wY)
commuteToPrefix (forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall a. SignedId a => a -> a
invertId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) wX.
Ident p =>
Contexted p wX -> PatchId p
ctxId) Set (Contexted (PrimWithName name prim) wY)
y) FL (PrimWithName name prim) wX wZ
com_r
    FL (PrimWithName name prim) wZ wZ
s' :> RL (PrimWithName name prim) wZ wY
rr' <- forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) (RL p) (FL p) wX wY -> Maybe ((:>) (FL p) (RL p) wX wY)
commuteRLFL (RL (PrimWithName name prim) wZ wZ
rr forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PrimWithName name prim) wZ wY
s)
    Contexted (PrimWithName name prim) wY
cp' <- forall (p :: * -> * -> *) wX wY.
Commute p =>
RL p wX wY -> Contexted p wY -> Maybe (Contexted p wX)
commutePastRL (forall (p :: * -> * -> *) wX wY.
Invert p =>
FL p wX wY -> RL p wY wX
invertFL FL (PrimWithName name prim) wZ wY
s) Contexted (PrimWithName name prim) wZ
cp
    Contexted (PrimWithName name prim) wZ
cq' <- forall (p :: * -> * -> *) wX wY.
Commute p =>
RL p wX wY -> Contexted p wY -> Maybe (Contexted p wX)
commutePastRL RL (PrimWithName name prim) wZ wY
rr' Contexted (PrimWithName name prim) wY
cq
    let sq :: Contexted (PrimWithName name prim) wZ
sq = forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wY -> Contexted p wX
ctxAddFL FL (PrimWithName name prim) wZ wY
s Contexted (PrimWithName name prim) wY
cq
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall (p :: * -> * -> *) wX.
(CleanMerge p, Commute p, Ident p) =>
Contexted p wX -> Contexted p wX -> Bool
ctxNoConflict Contexted (PrimWithName name prim) wZ
sq Contexted (PrimWithName name prim) wZ
cp)
    let sy :: Set (Contexted (PrimWithName name prim) wZ)
sy = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wY -> Contexted p wX
ctxAddFL FL (PrimWithName name prim) wZ wY
s) Set (Contexted (PrimWithName name prim) wY)
y
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (p :: * -> * -> *) wX.
(CleanMerge p, Commute p, Ident p) =>
Contexted p wX -> Contexted p wX -> Bool
ctxNoConflict Contexted (PrimWithName name prim) wZ
sq) (forall a. Ord a => Set a -> Set a -> Set a
S.difference Set (Contexted (PrimWithName name prim) wZ)
x Set (Contexted (PrimWithName name prim) wZ)
sy)
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (p :: * -> * -> *) wX.
(CleanMerge p, Commute p, Ident p) =>
Contexted p wX -> Contexted p wX -> Bool
ctxNoConflict Contexted (PrimWithName name prim) wZ
cp) (forall a. Ord a => Set a -> Set a -> Set a
S.difference Set (Contexted (PrimWithName name prim) wZ)
sy Set (Contexted (PrimWithName name prim) wZ)
x)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
      forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor (FL (PrimWithName name prim) wX wZ
com forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimWithName name prim) wZ wZ
s') (forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
RL p wX wY -> Contexted p wY -> Contexted p wX
ctxAddRL RL (PrimWithName name prim) wZ wY
rr') Set (Contexted (PrimWithName name prim) wY)
y) Contexted (PrimWithName name prim) wZ
cq'
      forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:>
      forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor (forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL (PrimWithName name prim) wZ wY
rr') (forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wZ wY
s) Set (Contexted (PrimWithName name prim) wZ)
x) Contexted (PrimWithName name prim) wY
cp'
  commuteNoConflicts (:>) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
_ = forall a. Maybe a
Nothing

-- * Commute

-- commuting a conflicted merge; these cases follow directly from merge
commuteConflicting
  :: (SignedId name, StorableId name, PrimPatch prim)
  => CommuteFn (RepoPatchV3 name prim) (RepoPatchV3 name prim)
-- if we have a prim and a conflictor that only conflicts with that prim,
-- they trade places
-- [p] :> [p^, {:p}, :q] <-> [q] :> [q^, {:q}, :p]
commuteConflicting :: forall name (prim :: * -> * -> *) wX wY.
(SignedId name, StorableId name, PrimPatch prim) =>
(:>) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
-> Maybe
     ((:>) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY)
commuteConflicting (Prim PrimWithName name prim wX wZ
p :> Conflictor (PrimWithName name prim wZ wY
ip:>:FL (PrimWithName name prim) wY wY
NilFL) Set (Contexted (PrimWithName name prim) wY)
ys cq :: Contexted (PrimWithName name prim) wY
cq@(forall (p :: * -> * -> *) wX.
Contexted p wX -> Sealed ((:>) (FL p) p wX)
ctxView -> Sealed (FL (PrimWithName name prim) wY wZ
NilFL :> PrimWithName name prim wZ wX
q)))
  | [forall (p :: * -> * -> *) wX.
Contexted p wX -> Sealed ((:>) (FL p) p wX)
ctxView -> Sealed (FL (PrimWithName name prim) wY wZ
NilFL :> PrimWithName name prim wZ wX
p')] <- forall a. Set a -> [a]
S.toList Set (Contexted (PrimWithName name prim) wY)
ys
  , EqCheck wX wY
IsEq <- forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert PrimWithName name prim wX wZ
p forall (p :: * -> * -> *) wA wB wC.
Eq2 p =>
p wA wB -> p wA wC -> EqCheck wB wC
=\/= PrimWithName name prim wZ wY
ip
  , EqCheck wZ wX
IsEq <- PrimWithName name prim wX wZ
p forall (p :: * -> * -> *) wA wB wC.
Eq2 p =>
p wA wB -> p wA wC -> EqCheck wB wC
=\/= PrimWithName name prim wZ wX
p' =
      forall a. a -> Maybe a
Just (forall name (prim :: * -> * -> *) wX wY.
PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY
Prim PrimWithName name prim wZ wX
q forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert PrimWithName name prim wZ wX
q forall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) (forall a. a -> Set a
S.singleton Contexted (PrimWithName name prim) wY
cq) (forall (p :: * -> * -> *) wX wY. p wX wY -> Contexted p wX
ctx PrimWithName name prim wX wZ
p))
-- similar to above case: a prim and a conflictor that conflicts with the prim
-- but also conflicts with other patches
-- [p] :> [p^ s, {s^:p} U Y, cq] <-> [s, Y, cq] :> [, {cq}, s^:p]
commuteConflicting (Prim PrimWithName name prim wX wZ
p :> Conflictor FL (PrimWithName name prim) wZ wY
s Set (Contexted (PrimWithName name prim) wY)
y Contexted (PrimWithName name prim) wY
cq)
  | forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident PrimWithName name prim wX wZ
p forall a. Ord a => a -> Set a -> Bool
`S.member` forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map forall (p :: * -> * -> *) wX.
Ident p =>
Contexted p wX -> PatchId p
ctxId Set (Contexted (PrimWithName name prim) wY)
y =
      case forall (p :: * -> * -> *) wX wY wZ.
(Commute p, Ident p) =>
p wX wY -> FL p wX wZ -> Maybe (FL p wY wZ)
fastRemoveFL (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert PrimWithName name prim wX wZ
p) FL (PrimWithName name prim) wZ wY
s of
        Maybe (FL (PrimWithName name prim) wX wY)
Nothing ->
          forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ Doc -> [Char]
renderString forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
redText [Char]
"commuteConflicting: cannot remove (invert lhs):"
            Doc -> Doc -> Doc
$$ forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert PrimWithName name prim wX wZ
p)
            Doc -> Doc -> Doc
$$ [Char] -> Doc
redText [Char]
"from effect of rhs:"
            Doc -> Doc -> Doc
$$ forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimWithName name prim) wZ wY
s
        Just FL (PrimWithName name prim) wX wY
r ->
          let cp :: Contexted (PrimWithName name prim) wY
cp = forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wX wY
r (forall (p :: * -> * -> *) wX wY. p wX wY -> Contexted p wX
ctx PrimWithName name prim wX wZ
p)
          in forall a. a -> Maybe a
Just (forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor FL (PrimWithName name prim) wX wY
r (Contexted (PrimWithName name prim) wY
cp forall a. Ord a => a -> Set a -> Set a
-| Set (Contexted (PrimWithName name prim) wY)
y) Contexted (PrimWithName name prim) wY
cq forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor forall (a :: * -> * -> *) wX. FL a wX wX
NilFL (forall a. a -> Set a
S.singleton Contexted (PrimWithName name prim) wY
cq) Contexted (PrimWithName name prim) wY
cp)
-- if we have two conflictors where the rhs conflicts /only/ with the lhs,
-- the latter becomes a prim patch
-- [r, X, cp] [, {cp}, r^:q] <-> [q] [q^r, {r^:q} U X, cp]
commuteConflicting (lhs :: RepoPatchV3 name prim wX wZ
lhs@(Conflictor FL (PrimWithName name prim) wX wZ
r Set (Contexted (PrimWithName name prim) wZ)
x Contexted (PrimWithName name prim) wZ
cp) :> rhs :: RepoPatchV3 name prim wZ wY
rhs@(Conflictor FL (PrimWithName name prim) wZ wY
NilFL Set (Contexted (PrimWithName name prim) wY)
y Contexted (PrimWithName name prim) wY
cq))
  | Set (Contexted (PrimWithName name prim) wY)
y forall a. Eq a => a -> a -> Bool
== forall a. a -> Set a
S.singleton Contexted (PrimWithName name prim) wZ
cp =
      case forall (p :: * -> * -> *) wX.
Contexted p wX -> Sealed ((:>) (FL p) p wX)
ctxView (forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wY -> Contexted p wX
ctxAddFL FL (PrimWithName name prim) wX wZ
r Contexted (PrimWithName name prim) wY
cq) of
        Sealed (FL (PrimWithName name prim) wX wZ
NilFL :> PrimWithName name prim wZ wX
cq') ->
          forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            forall name (prim :: * -> * -> *) wX wY.
PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY
Prim PrimWithName name prim wZ wX
cq'
            forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:>
            forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert PrimWithName name prim wZ wX
cq' forall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>: FL (PrimWithName name prim) wX wZ
r) (Contexted (PrimWithName name prim) wY
cq forall a. Ord a => a -> Set a -> Set a
+| Set (Contexted (PrimWithName name prim) wZ)
x) Contexted (PrimWithName name prim) wZ
cp
        Sealed (FL (PrimWithName name prim) wX wZ
c' :> PrimWithName name prim wZ wX
_) ->
          forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ Doc -> [Char]
renderString forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
redText [Char]
"remaining context in commute:"
            Doc -> Doc -> Doc
$$ forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimWithName name prim) wX wZ
c'
            Doc -> Doc -> Doc
$$ [Char] -> Doc
redText [Char]
"lhs:" Doc -> Doc -> Doc
$$ forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch RepoPatchV3 name prim wX wZ
lhs
            Doc -> Doc -> Doc
$$ [Char] -> Doc
redText [Char]
"rhs:" Doc -> Doc -> Doc
$$ forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch RepoPatchV3 name prim wZ wY
rhs
-- conflicting conflictors where the rhs conflicts with lhs but
-- also conflicts with other patches
-- [com r, X, cp] [s, y=({s^cp} U Y'), cq] <-> [com s', r'Y', r'cq] [r', {cq} U s^X, s^cp]
commuteConflicting (Conflictor FL (PrimWithName name prim) wX wZ
com_r Set (Contexted (PrimWithName name prim) wZ)
x Contexted (PrimWithName name prim) wZ
cp :> Conflictor FL (PrimWithName name prim) wZ wY
s Set (Contexted (PrimWithName name prim) wY)
y Contexted (PrimWithName name prim) wY
cq)
  | let is_cp :: Contexted (PrimWithName name prim) wY
is_cp = forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wZ wY
s Contexted (PrimWithName name prim) wZ
cp
  , Contexted (PrimWithName name prim) wY
is_cp forall a. Ord a => a -> Set a -> Bool
`S.member` Set (Contexted (PrimWithName name prim) wY)
y
  , let y' :: Set (Contexted (PrimWithName name prim) wY)
y' = Contexted (PrimWithName name prim) wY
is_cp forall a. Ord a => a -> Set a -> Set a
-| Set (Contexted (PrimWithName name prim) wY)
y =
      case forall (p :: * -> * -> *) wX wY.
(Commute p, Ident p) =>
Set (PatchId p) -> FL p wX wY -> Maybe ((:>) (FL p) (RL p) wX wY)
commuteToPrefix (forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall a. SignedId a => a -> a
invertId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) wX.
Ident p =>
Contexted p wX -> PatchId p
ctxId) Set (Contexted (PrimWithName name prim) wY)
y') FL (PrimWithName name prim) wX wZ
com_r of
        Maybe
  ((:>)
     (FL (PrimWithName name prim)) (RL (PrimWithName name prim)) wX wZ)
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"commuteConflicting: cannot commute common effects"
        Just (FL (PrimWithName name prim) wX wZ
com :> RL (PrimWithName name prim) wZ wZ
rr) ->
          case forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) (RL p) (FL p) wX wY -> Maybe ((:>) (FL p) (RL p) wX wY)
commuteRLFL (RL (PrimWithName name prim) wZ wZ
rr forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PrimWithName name prim) wZ wY
s) of
            Maybe
  ((:>)
     (FL (PrimWithName name prim)) (RL (PrimWithName name prim)) wZ wY)
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"commuteConflicting: cannot commute uncommon effects"
            Just (FL (PrimWithName name prim) wZ wZ
s' :> RL (PrimWithName name prim) wZ wY
rr') ->
              forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor (FL (PrimWithName name prim) wX wZ
com forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimWithName name prim) wZ wZ
s')
                  (forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
RL p wX wY -> Contexted p wY -> Contexted p wX
ctxAddRL RL (PrimWithName name prim) wZ wY
rr') Set (Contexted (PrimWithName name prim) wY)
y')
                  (forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
RL p wX wY -> Contexted p wY -> Contexted p wX
ctxAddRL RL (PrimWithName name prim) wZ wY
rr' Contexted (PrimWithName name prim) wY
cq)
                forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:>
                forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor (forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL (PrimWithName name prim) wZ wY
rr')
                  (Contexted (PrimWithName name prim) wY
cq forall a. Ord a => a -> Set a -> Set a
+| forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall (p :: * -> * -> *) wX wY.
(Commute p, Invert p, Ident p) =>
FL p wX wY -> Contexted p wX -> Contexted p wY
ctxAddInvFL FL (PrimWithName name prim) wZ wY
s) Set (Contexted (PrimWithName name prim) wZ)
x)
                  Contexted (PrimWithName name prim) wY
is_cp
commuteConflicting (:>) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
_ = forall a. Maybe a
Nothing

instance (SignedId name, StorableId name, PrimPatch prim) =>
         Commute (RepoPatchV3 name prim) where
  commute :: forall wX wY.
(:>) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
-> Maybe
     ((:>) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY)
commute (:>) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
pair = forall name (prim :: * -> * -> *) wX wY.
(SignedId name, StorableId name, PrimPatch prim) =>
(:>) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
-> Maybe
     ((:>) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY)
commuteConflicting (:>) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
pair forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (p :: * -> * -> *) wX wY.
CommuteNoConflicts p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commuteNoConflicts (:>) (RepoPatchV3 name prim) (RepoPatchV3 name prim) wX wY
pair

-- * PatchInspect

-- Note: in contrast to RepoPatchV2 we do not look at the list of conflicts
-- here. I see no reason why we should: the conflicts are only needed for the
-- instance Commute. We do however look at the patches that we undo.
instance PatchInspect prim => PatchInspect (RepoPatchV3 name prim) where
  listTouchedFiles :: forall wX wY. RepoPatchV3 name prim wX wY -> [AnchoredPath]
listTouchedFiles (Prim PrimWithName name prim wX wY
p) = forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles PrimWithName name prim wX wY
p
  listTouchedFiles (Conflictor FL (PrimWithName name prim) wX wY
r Set (Contexted (PrimWithName name prim) wY)
_ Contexted (PrimWithName name prim) wY
cp) =
    forall a. Ord a => [a] -> [a]
nubSort forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles FL (PrimWithName name prim) wX wY
r) forall a. [a] -> [a] -> [a]
++ forall (p :: * -> * -> *) wX.
PatchInspect p =>
Contexted p wX -> [AnchoredPath]
ctxTouches Contexted (PrimWithName name prim) wY
cp
  hunkMatches :: forall wX wY.
(ByteString -> Bool) -> RepoPatchV3 name prim wX wY -> Bool
hunkMatches ByteString -> Bool
f (Prim PrimWithName name prim wX wY
p) = forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
(ByteString -> Bool) -> p wX wY -> Bool
hunkMatches ByteString -> Bool
f PrimWithName name prim wX wY
p
  hunkMatches ByteString -> Bool
f (Conflictor FL (PrimWithName name prim) wX wY
r Set (Contexted (PrimWithName name prim) wY)
_ Contexted (PrimWithName name prim) wY
cp) = forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
(ByteString -> Bool) -> p wX wY -> Bool
hunkMatches ByteString -> Bool
f FL (PrimWithName name prim) wX wY
r Bool -> Bool -> Bool
|| forall (p :: * -> * -> *) wX.
PatchInspect p =>
(ByteString -> Bool) -> Contexted p wX -> Bool
ctxHunkMatches ByteString -> Bool
f Contexted (PrimWithName name prim) wY
cp

-- * Boilerplate instances

instance (SignedId name, Eq2 prim, Commute prim) => Eq2 (RepoPatchV3 name prim) where
    (Prim PrimWithName name prim wA wB
p) =\/= :: forall wA wB wC.
RepoPatchV3 name prim wA wB
-> RepoPatchV3 name prim wA wC -> EqCheck wB wC
=\/= (Prim PrimWithName name prim wA wC
q) = PrimWithName name prim wA wB
p forall (p :: * -> * -> *) wA wB wC.
Eq2 p =>
p wA wB -> p wA wC -> EqCheck wB wC
=\/= PrimWithName name prim wA wC
q
    (Conflictor FL (PrimWithName name prim) wA wB
r Set (Contexted (PrimWithName name prim) wB)
x Contexted (PrimWithName name prim) wB
cp) =\/= (Conflictor FL (PrimWithName name prim) wA wC
s Set (Contexted (PrimWithName name prim) wC)
y Contexted (PrimWithName name prim) wC
cq)
        | EqCheck wB wC
IsEq <- FL (PrimWithName name prim) wA wB
r forall (p :: * -> * -> *) wA wB wC.
IdEq2 p =>
p wA wB -> p wA wC -> EqCheck wB wC
=\^/= FL (PrimWithName name prim) wA wC
s -- more efficient than IsEq <- r =\/= s
        , Set (Contexted (PrimWithName name prim) wB)
x forall a. Eq a => a -> a -> Bool
== Set (Contexted (PrimWithName name prim) wC)
y
        , Contexted (PrimWithName name prim) wB
cp forall a. Eq a => a -> a -> Bool
== Contexted (PrimWithName name prim) wC
cq = forall wA. EqCheck wA wA
IsEq
    RepoPatchV3 name prim wA wB
_ =\/= RepoPatchV3 name prim wA wC
_ = forall wA wB. EqCheck wA wB
NotEq

instance (Show name, Show2 prim) => Show (RepoPatchV3 name prim wX wY) where
  showsPrec :: Int -> RepoPatchV3 name prim wX wY -> ShowS
showsPrec Int
d RepoPatchV3 name prim wX wY
rp = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
appPrec) forall a b. (a -> b) -> a -> b
$
    case RepoPatchV3 name prim wX wY
rp of
      Prim PrimWithName name prim wX wY
prim ->
        [Char] -> ShowS
showString [Char]
"Prim " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) wX wY. Show2 a => Int -> a wX wY -> ShowS
showsPrec2 (Int
appPrec forall a. Num a => a -> a -> a
+ Int
1) PrimWithName name prim wX wY
prim
      Conflictor FL (PrimWithName name prim) wX wY
r Set (Contexted (PrimWithName name prim) wY)
x Contexted (PrimWithName name prim) wY
cp -> [Char] -> ShowS
showString [Char]
"Conflictor " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a} {a}.
(Show a, Show a, Show a) =>
a -> a -> a -> ShowS
showContent FL (PrimWithName name prim) wX wY
r Set (Contexted (PrimWithName name prim) wY)
x Contexted (PrimWithName name prim) wY
cp
    where
      showContent :: a -> a -> a -> ShowS
showContent a
r a
x a
cp =
        forall a. Show a => Int -> a -> ShowS
showsPrec (Int
appPrec forall a. Num a => a -> a -> a
+ Int
1) a
r forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          [Char] -> ShowS
showString [Char]
" " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec (Int
appPrec forall a. Num a => a -> a -> a
+ Int
1) a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          [Char] -> ShowS
showString [Char]
" " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec (Int
appPrec forall a. Num a => a -> a -> a
+ Int
1) a
cp

instance (Show name, Show2 prim) => Show1 (RepoPatchV3 name prim wX)

instance (Show name, Show2 prim) => Show2 (RepoPatchV3 name prim)

instance PrimPatch prim => PrimPatchBase (RepoPatchV3 name prim) where
  type PrimOf (RepoPatchV3 name prim) = prim

instance ToPrim (RepoPatchV3 name prim) where
  toPrim :: forall wX wY.
RepoPatchV3 name prim wX wY
-> Maybe (PrimOf (RepoPatchV3 name prim) wX wY)
toPrim (Conflictor {}) = forall a. Maybe a
Nothing
  toPrim (Prim PrimWithName name prim wX wY
p) = forall a. a -> Maybe a
Just (forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch PrimWithName name prim wX wY
p)

instance PatchDebug prim => PatchDebug (RepoPatchV3 name prim)

instance PrimPatch prim => Apply (RepoPatchV3 name prim) where
  type ApplyState (RepoPatchV3 name prim) = ApplyState prim
  apply :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (RepoPatchV3 name prim)) m =>
RepoPatchV3 name prim wX wY -> m ()
apply = forall (prim :: * -> * -> *) (m :: * -> *) wX wY.
(PrimApply prim, ApplyMonad (ApplyState prim) m) =>
FL prim wX wY -> m ()
applyPrimFL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect
  unapply :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (RepoPatchV3 name prim)) m =>
RepoPatchV3 name prim wX wY -> m ()
unapply = forall (prim :: * -> * -> *) (m :: * -> *) wX wY.
(PrimApply prim, ApplyMonad (ApplyState prim) m) =>
FL prim wX wY -> m ()
applyPrimFL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect

instance PatchListFormat (RepoPatchV3 name prim) where
  patchListFormat :: ListFormat (RepoPatchV3 name prim)
patchListFormat = forall (p :: * -> * -> *). ListFormat p
ListFormatV3

instance IsHunk prim => IsHunk (RepoPatchV3 name prim) where
  isHunk :: forall wX wY. RepoPatchV3 name prim wX wY -> Maybe (FileHunk wX wY)
isHunk RepoPatchV3 name prim wX wY
rp = do
    Prim PrimWithName name prim wX wY
p <- forall (m :: * -> *) a. Monad m => a -> m a
return RepoPatchV3 name prim wX wY
rp
    forall (p :: * -> * -> *) wX wY.
IsHunk p =>
p wX wY -> Maybe (FileHunk wX wY)
isHunk PrimWithName name prim wX wY
p

instance Summary (RepoPatchV3 name prim) where
  conflictedEffect :: forall wX wY.
RepoPatchV3 name prim wX wY
-> [IsConflictedPrim (PrimOf (RepoPatchV3 name prim))]
conflictedEffect (Conflictor FL (PrimWithName name prim) wX wY
_ Set (Contexted (PrimWithName name prim) wY)
_ (forall (p :: * -> * -> *) wX.
Contexted p wX -> Sealed ((:>) (FL p) p wX)
ctxView -> Sealed (FL (PrimWithName name prim) wY wZ
_ :> PrimWithName name prim wZ wX
p))) = [forall (prim :: * -> * -> *) wX wY.
ConflictState -> prim wX wY -> IsConflictedPrim prim
IsC ConflictState
Conflicted (forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch PrimWithName name prim wZ wX
p)]
  conflictedEffect (Prim PrimWithName name prim wX wY
p) = [forall (prim :: * -> * -> *) wX wY.
ConflictState -> prim wX wY -> IsConflictedPrim prim
IsC ConflictState
Okay (forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch PrimWithName name prim wX wY
p)]

instance (Invert prim, Commute prim, Eq2 prim) => Unwind (RepoPatchV3 name prim) where
  fullUnwind :: forall wX wY.
RepoPatchV3 name prim wX wY
-> Unwound (PrimOf (RepoPatchV3 name prim)) wX wY
fullUnwind (Prim PrimWithName name prim wX wY
p)
    = forall (prim :: * -> * -> *) wA wB wC wD.
(Commute prim, Invert prim, Eq2 prim) =>
FL prim wA wB
-> FL prim wB wC -> FL prim wC wD -> Unwound prim wA wD
mkUnwound forall (a :: * -> * -> *) wX. FL a wX wX
NilFL (forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch PrimWithName name prim wX wY
p forall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
  fullUnwind
    (Conflictor
      (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 name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch -> FL prim wX wY
es)
      Set (Contexted (PrimWithName name prim) wY)
_
      (forall (p :: * -> * -> *) wX.
Contexted p wX -> Sealed ((:>) (FL p) p wX)
ctxView -> Sealed ((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 name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch -> FL prim wY wZ
cs) :> (forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch -> prim wZ wX
i)))
    ) =
    forall (prim :: * -> * -> *) wA wB wC wD.
(Commute prim, Invert prim, Eq2 prim) =>
FL prim wA wB
-> FL prim wB wC -> FL prim wC wD -> Unwound prim wA wD
mkUnwound
      (FL prim wX wY
es forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL prim wY wZ
cs)
      (prim wZ wX
i forall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
      (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert prim wZ wX
i forall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>: forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL prim wY wZ
cs forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)

-- * More boilerplate instances

instance PrimPatch prim => Check (RepoPatchV3 name prim)
  -- use the default implementation for method isInconsistent

instance PrimPatch prim => RepairToFL (RepoPatchV3 name prim)
  -- use the default implementation for method applyAndTryToFixFL

instance (SignedId name, StorableId name, PrimPatch prim)
  => ShowPatch (RepoPatchV3 name prim) where

  summary :: forall wX wY. RepoPatchV3 name prim wX wY -> Doc
summary = forall (e :: * -> * -> *) wX wY.
(Summary e, PrimDetails (PrimOf e)) =>
e wX wY -> Doc
plainSummary
  summaryFL :: forall wX wY. FL (RepoPatchV3 name prim) wX wY -> Doc
summaryFL = forall (e :: * -> * -> *) wX wY.
(Summary e, PrimDetails (PrimOf e)) =>
FL e wX wY -> Doc
plainSummaryFL
  thing :: forall wX wY. RepoPatchV3 name prim wX wY -> [Char]
thing RepoPatchV3 name prim wX wY
_ = [Char]
"change"

instance (StorableId name, PrimPatch prim)
  => ShowContextPatch (RepoPatchV3 name prim) where

  showContextPatch :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (RepoPatchV3 name prim)) m =>
ShowPatchFor -> RepoPatchV3 name prim wX wY -> m Doc
showContextPatch ShowPatchFor
f (Prim PrimWithName name prim wX wY
p) = forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(ShowContextPatch p, ApplyMonad (ApplyState p) m) =>
ShowPatchFor -> p wX wY -> m Doc
showContextPatch ShowPatchFor
f PrimWithName name prim wX wY
p
  showContextPatch ShowPatchFor
f RepoPatchV3 name prim wX wY
p = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
f RepoPatchV3 name prim wX wY
p

-- * Read and Write

instance (SignedId name, StorableId name, PrimPatch prim)
  => ReadPatch (RepoPatchV3 name prim) where

  readPatch' :: forall wX. Parser (Sealed (RepoPatchV3 name prim wX))
readPatch' = do
    Parser ()
skipSpace
    forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
      [ do ByteString -> Parser ()
string ([Char] -> ByteString
BC.pack [Char]
"conflictor")
           (Sealed FL (PrimWithName name prim) wX wX
r, Set (Contexted (PrimWithName name prim) Any)
x, Contexted (PrimWithName name prim) Any
p) <- forall {wX} {wX} {wX}.
Parser
  ByteString
  (Sealed (FL (PrimWithName name prim) wX),
   Set (Contexted (PrimWithName name prim) wX),
   Contexted (PrimWithName name prim) wX)
readContent
           forall (m :: * -> *) a. Monad m => a -> m a
return (forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (forall name (prim :: * -> * -> *) wX wY.
FL (PrimWithName name prim) wX wY
-> Set (Contexted (PrimWithName name prim) wY)
-> Contexted (PrimWithName name prim) wY
-> RepoPatchV3 name prim wX wY
Conflictor FL (PrimWithName name prim) wX wX
r (forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map forall (a :: * -> *) wX wY. a wX -> a wY
unsafeCoerceP1 Set (Contexted (PrimWithName name prim) Any)
x) (forall (a :: * -> *) wX wY. a wX -> a wY
unsafeCoerceP1 Contexted (PrimWithName name prim) Any
p)))
      , do forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall name (prim :: * -> * -> *) wX wY.
PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY
Prim forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch'
      ]
    where
      readContent :: Parser
  ByteString
  (Sealed (FL (PrimWithName name prim) wX),
   Set (Contexted (PrimWithName name prim) wX),
   Contexted (PrimWithName name prim) wX)
readContent = do
        Sealed (FL (PrimWithName name prim) wX)
r <- forall (p :: * -> * -> *) wX.
(forall wY. Parser (Sealed (p wY)))
-> Char -> Char -> Parser (Sealed (FL p wX))
bracketedFL forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch' Char
'[' Char
']'
        Set (Contexted (PrimWithName name prim) wX)
x <- forall {wX}.
Parser ByteString (Set (Contexted (PrimWithName name prim) wX))
readCtxSet
        Contexted (PrimWithName name prim) wX
p <- forall (p :: * -> * -> *) wX.
(ReadPatch p, PatchListFormat p) =>
Parser (Contexted p wX)
readCtx
        forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimWithName name prim) wX)
r, Set (Contexted (PrimWithName name prim) wX)
x, Contexted (PrimWithName name prim) wX
p)
      readCtxSet :: Parser ByteString (Set (Contexted (PrimWithName name prim) wX))
readCtxSet = (ByteString -> Parser ()
lexString ([Char] -> ByteString
BC.pack [Char]
"{{") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {wX}.
Parser ByteString (Set (Contexted (PrimWithName name prim) wX))
go) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Set a
S.empty
        where
          go :: Parser ByteString (Set (Contexted (PrimWithName name prim) wX))
go = (ByteString -> Parser ()
lexString ([Char] -> ByteString
BC.pack [Char]
"}}") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Set a
S.empty) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Ord a => a -> Set a -> Set a
S.insert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (p :: * -> * -> *) wX.
(ReadPatch p, PatchListFormat p) =>
Parser (Contexted p wX)
readCtx forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString (Set (Contexted (PrimWithName name prim) wX))
go

instance (StorableId name, PrimPatch prim)
  => ShowPatchBasic (RepoPatchV3 name prim) where

  showPatch :: forall wX wY. ShowPatchFor -> RepoPatchV3 name prim wX wY -> Doc
showPatch ShowPatchFor
fmt RepoPatchV3 name prim wX wY
rp =
    case RepoPatchV3 name prim wX wY
rp of
      Prim PrimWithName name prim wX wY
p -> forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
fmt PrimWithName name prim wX wY
p
      Conflictor FL (PrimWithName name prim) wX wY
r Set (Contexted (PrimWithName name prim) wY)
x Contexted (PrimWithName name prim) wY
cp -> [Char] -> Doc
blueText [Char]
"conflictor" Doc -> Doc -> Doc
<+> forall {a :: * -> * -> *} {p :: * -> * -> *} {p :: * -> * -> *}
       {wX} {wY} {wX} {wX}.
(ShowPatchBasic a, ShowPatchBasic p, ShowPatchBasic p,
 PatchListFormat p, PatchListFormat p) =>
FL a wX wY -> Set (Contexted p wX) -> Contexted p wX -> Doc
showContent FL (PrimWithName name prim) wX wY
r Set (Contexted (PrimWithName name prim) wY)
x Contexted (PrimWithName name prim) wY
cp
    where
      showContent :: FL a wX wY -> Set (Contexted p wX) -> Contexted p wX -> Doc
showContent FL a wX wY
r Set (Contexted p wX)
x Contexted p wX
cp = forall {a :: * -> * -> *} {wX} {wY}.
ShowPatchBasic a =>
FL a wX wY -> Doc
showEffect FL a wX wY
r Doc -> Doc -> Doc
<+> forall {p :: * -> * -> *} {wX}.
(ShowPatchBasic p, PatchListFormat p) =>
Set (Contexted p wX) -> Doc
showCtxSet Set (Contexted p wX)
x Doc -> Doc -> Doc
$$ forall (p :: * -> * -> *) wX.
(ShowPatchBasic p, PatchListFormat p) =>
ShowPatchFor -> Contexted p wX -> Doc
showCtx ShowPatchFor
fmt Contexted p wX
cp
      showEffect :: FL a wX wY -> Doc
showEffect FL a wX wY
NilFL = [Char] -> Doc
blueText [Char]
"[]"
      showEffect FL a wX wY
ps = [Char] -> Doc
blueText [Char]
"[" Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat (forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL (forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
fmt) FL a wX wY
ps) Doc -> Doc -> Doc
$$ [Char] -> Doc
blueText [Char]
"]"
      showCtxSet :: Set (Contexted p wX) -> Doc
showCtxSet Set (Contexted p wX)
xs =
        case forall a. Set a -> Maybe (a, Set a)
S.minView Set (Contexted p wX)
xs of
          Maybe (Contexted p wX, Set (Contexted p wX))
Nothing -> forall a. Monoid a => a
mempty
          Just (Contexted p wX, Set (Contexted p wX))
_ ->
            [Char] -> Doc
blueText [Char]
"{{"
              Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) wX.
(ShowPatchBasic p, PatchListFormat p) =>
ShowPatchFor -> Contexted p wX -> Doc
showCtx ShowPatchFor
fmt) (forall a. Set a -> [a]
S.toAscList Set (Contexted p wX)
xs))
              Doc -> Doc -> Doc
$$ [Char] -> Doc
blueText [Char]
"}}"

-- * Local helper functions

infixr +|, -|

-- | A handy synonym for 'S.insert'.
(+|) :: Ord a => a -> S.Set a -> S.Set a
a
c +| :: forall a. Ord a => a -> Set a -> Set a
+| Set a
cs = forall a. Ord a => a -> Set a -> Set a
S.insert a
c Set a
cs

-- | A handy synonym for 'S.delete'.
(-|) :: Ord a => a -> S.Set a -> S.Set a
a
c -| :: forall a. Ord a => a -> Set a -> Set a
-| Set a
cs = forall a. Ord a => a -> Set a -> Set a
S.delete a
c Set a
cs