Merge.hs

-- |
-- Module      : Darcs.Patch.Merge
-- Maintainer  : darcs-devel@darcs.net
-- Stability   : experimental
-- Portability : portable

module Darcs.Patch.Merge
    ( -- * Classes
      CleanMerge(..)
    , Merge(..)
      -- * Functions
    , selfMerger
    , swapMerger
    , mergerIdFL
    , mergerFLId
    , mergerFLFL
    , cleanMergeFL
    , mergeFL
    , swapMerge
    , swapCleanMerge
    , mergeList
      -- * Properties
    , prop_mergeSymmetric
    , prop_mergeCommute
    ) where

import Control.Monad ( foldM )

import Darcs.Prelude

import Darcs.Patch.Commute ( Commute(..) )
import Darcs.Patch.CommuteFn ( MergeFn, PartialMergeFn )
import Darcs.Patch.Invert ( Invert(..) )
import Darcs.Patch.Witnesses.Eq ( Eq2(..), isIsEq )
import Darcs.Patch.Witnesses.Ordered
    ( (:\/:)(..)
    , (:/\:)(..)
    , FL(..)
    , (:>)(..)
    , (+>+)
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )

{- | Class of patches that can, possibly, be merged cleanly, that is,
without conflict.

Every patch type can be made an instance of 'CleanMerge' in a trivial way by
defining @'cleanMerge' _ = 'Nothing'@, which vacuously conforms to all
required laws.

Instances should obey the following laws:

[/symmetry/]

    prop> cleanMerge (p :\/: q) == Just (q' :/\: p') <=> cleanMerge (q :\/: p) == Just (p' :/\: q')

If an instance @'Commute' p@ exists, then we also require

[/merge-commute/]

    prop> cleanMerge (p :\/: q) == Just (q' :/\: p') ==> commute (p :> q') == Just (q :> p')

    that is, the two branches of a clean merge commute to each other.

If an instance @'Invert' p@ exists, then we also require

[/square-merge/]

    prop> cleanMerge (p :\/: q) == Just (q' :/\: p') => cleanMerge (invert p :\/: q') == Just (q :/\: invert p')

    Here is a picture that explains why we call this /square-merge/:

    >     A---p--->X          A<--p^---X
    >     |        |          |        |
    >     |        |          |        |
    >     q        q'   =>    q        q'
    >     |        |          |        |
    >     v        v          v        v
    >     Y---p'-->B          Y<--p'^--B

-}
class CleanMerge p where
  cleanMerge :: (p :\/: p) wX wY -> Maybe ((p :/\: p) wX wY)

instance CleanMerge p => CleanMerge (FL p) where
  cleanMerge (NilFL :\/: x) = return $ x :/\: NilFL
  cleanMerge (x :\/: NilFL) = return $ NilFL :/\: x
  cleanMerge ((x :>: xs) :\/: ys) = do
    ys' :/\: x' <- cleanMergeFL (x :\/: ys)
    xs' :/\: ys'' <- cleanMerge (ys' :\/: xs)
    return $ ys'' :/\: (x' :>: xs')

-- | Cleanly merge a single patch with an 'FL' of patches.
cleanMergeFL :: CleanMerge p => PartialMergeFn p (FL p)
cleanMergeFL (p :\/: NilFL) = return $ NilFL :/\: p
cleanMergeFL (p :\/: (x :>: xs)) = do
  x' :/\: p'  <- cleanMerge (p :\/: x)
  xs' :/\: p'' <- cleanMergeFL (p' :\/: xs)
  return $ (x' :>: xs') :/\: p''

{- | Patches that can always be merged, even if they conflict.

Instances should obey the following laws:

[/symmetry/]

    prop> merge (p :\/: q) == q' :/\: p' <=> merge (q :\/: p) == p' :/\: q'

[/merge-commute/]

    prop> merge (p :\/: q) == q' :/\: p' ==> commute (p :> q') == Just (q :> p')

    that is, the two branches of a merge commute to each other.

[/extension/]

    prop> cleanMerge (p :\/: q) == Just (q' :/\: p') => merge (p :\/: q) == q' :/\: p'

    that is, 'merge' is an extension of 'cleanMerge'.

-}
class CleanMerge p => Merge p where
    merge :: (p :\/: p) wX wY -> (p :/\: p) wX wY

-- | Synonym for 'merge'.
selfMerger :: Merge p => MergeFn p p
selfMerger = merge

instance Merge p => Merge (FL p) where
    merge = mergerFLFL merge

mergeFL :: Merge p
        => (p :\/: FL p) wX wY
        -> (FL p :/\: p) wX wY
mergeFL = mergerIdFL merge

-- | Lift a merge function over @p :\/: q@
-- to a merge function over @p :\/: FL q@
mergerIdFL :: MergeFn p q -> MergeFn p (FL q)
mergerIdFL _mergeFn (p :\/: NilFL) = NilFL :/\: p
mergerIdFL  mergeFn (p :\/: (x :>: xs)) =
  case mergeFn (p :\/: x) of
    x' :/\: p' -> case mergerIdFL mergeFn (p' :\/: xs) of
      xs' :/\: p'' -> (x' :>: xs') :/\: p''

-- | Lift a merge function over @p :\/: q@
-- to a merge function over @FL p :\/: q@
mergerFLId :: MergeFn p q -> MergeFn (FL p) q
mergerFLId mergeFn = swapMerger (mergerIdFL (swapMerger mergeFn))

-- | Lift a merge function over @p :\/: q@
-- to a merge function over @FL p :\/: FL q@
mergerFLFL :: MergeFn p q -> MergeFn (FL p) (FL q)
mergerFLFL mergeFn = mergerIdFL (mergerFLId mergeFn)

-- | Swap the two patches, 'merge', then swap again. Used to exploit
-- 'prop_mergeSymmetric' when defining 'merge'.
swapMerge :: Merge p => (p :\/: p) wX wY -> (p :/\: p) wX wY
swapMerge = swapMerger merge

-- | Swap the two patches, apply an arbitrary merge function, then swap again.
swapMerger :: MergeFn p q -> MergeFn q p
swapMerger mergeFn (x :\/: y) = case mergeFn (y :\/: x) of x' :/\: y' -> y' :/\: x'

-- | Swap the two patches, 'cleanMerge', then swap again. Used to exploit
-- 'prop_cleanMergeSymmetric' when defining 'cleanMerge'.
swapCleanMerge :: CleanMerge p => (p :\/: p) wX wY -> Maybe ((p :/\: p) wX wY)
swapCleanMerge (x :\/: y) = do
  x' :/\: y' <- cleanMerge (y :\/: x)
  return $ y' :/\: x'

-- | Combine a list of patch sequences, all starting at the same state, into a
-- single sequence that also starts at the same state, using cleanMerge.
-- If the merge fails, we return the two sequences that
-- could not be merged so we can issue more detailed error messages.
mergeList :: CleanMerge p
          => [Sealed (FL p wX)]
          -> Either (Sealed (FL p wX), Sealed (FL p wX)) (Sealed (FL p wX))
mergeList = foldM mergeTwo (Sealed NilFL)
  where
    mergeTwo (Sealed ps) (Sealed qs) =
      case cleanMerge (ps :\/: qs) of
        Just (qs' :/\: _) -> Right $ Sealed $ ps +>+ qs'
        Nothing -> Left (Sealed ps, Sealed qs)

-- | This function serves no purpose except to demonstrate how merge together
-- with the square commute law allows us to commute any pair of adjacent
-- patches.
-- Note that using this function introduces inverse conflictors if the regular
-- commute would fail. This is problematic because it invalidates another
-- global invariant we rely on, namely that we can always drop (obliterate or
-- amend) patches from the end of a repo. This is because inverse conflictors
-- contain references to patches that come after it, so dropping them would
-- make the inverse conflictor inconsistent.
_forceCommute :: (Commute p, Merge p, Invert p) => (p :> p) wX wY -> (p :> p) wX wY
_forceCommute (p :> q) =
  case commute (p :> q) of
    Just (q' :> p') -> q' :> p'
    Nothing ->
      case merge (invert p :\/: q) of
        q' :/\: ip' -> q' :> invert ip'

-- | Whether the given pair of patches satisfies the /symmetry/ law.
prop_mergeSymmetric :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool
prop_mergeSymmetric (p :\/: q) =
  case merge (p :\/: q) of
    q' :/\: p' ->
      case merge (q :\/: p) of
        p'' :/\: q'' ->
          isIsEq (q' =\/= q'') && isIsEq (p' =\/= p'')

-- | Whether the given pair of patches satisfies the /merge-commute/ law.
prop_mergeCommute :: (Commute p, Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool
prop_mergeCommute (p :\/: q) =
  case merge (p :\/: q) of
    q' :/\: p' ->
      case commute (p :> q') of
        Nothing -> False
        Just (q'' :> p'') ->
          isIsEq (q'' =\/= q) && isIsEq (p'' =/\= p')
      &&
      case commute (q :> p') of
        Nothing -> False
        Just (p'' :> q'') ->
          isIsEq (p'' =\/= p) && isIsEq (q'' =/\= q')