{- | Generic coalesce functions

Some of the algorithms in this module do complex recursive operations on
sequences of patches in order to simplify them. These algorithms require
that we know whether some intermediate step has made any progress. If not,
we want to terminate or try something different.

We capture this as an effect by tagging intermediate data with the 'Any'
monoid, a newtype wrapper for 'Bool' with disjunction as 'mappend'. The
standard @instance 'Monoid' a => 'Monad' (a,)'@ defined in the base package
then gives use the desired semantics. That is, when we sequence operations
using '>>=', the result tells us whether 'Any' of the two operations have
made progress. -}

module Darcs.Patch.Prim.Coalesce
    ( coalesce
    , defaultTryToShrink
    , defaultSortCoalesceFL
    , withAnyToMaybe
    , sortCoalesceFL2
    ) where

import Darcs.Prelude

import Data.Maybe ( fromMaybe )
import Data.Monoid ( Any(..) )

import Darcs.Patch.Commute ( Commute(..) )
import Darcs.Patch.Invert ( Invert(..) )
import Darcs.Patch.Prim.Class ( PrimCoalesce(..), isIdentity)
import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )
import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) )
import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..) )

-- | Either 'primCoalesce' or cancel inverses.
--
-- prop> primCoalesce (p :> q) == Just r => apply r = apply p >> apply q
coalesce :: PrimCoalesce prim => (prim :> prim) wX wY -> Maybe (Maybe2 prim wX wY)
coalesce :: forall (prim :: * -> * -> *) wX wY.
PrimCoalesce prim =>
(:>) prim prim wX wY -> Maybe (Maybe2 prim wX wY)
coalesce (prim wX wZ
p1 :> prim wZ wY
p2)
  | EqCheck wX wY
IsEq <- prim wX wZ -> prim wZ wX
forall wX wY. prim wX wY -> prim wY wX
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert prim wX wZ
p1 prim wZ wX -> prim wZ wY -> EqCheck wX wY
forall wA wB wC. prim wA wB -> prim wA wC -> EqCheck wB wC
forall (p :: * -> * -> *) wA wB wC.
Eq2 p =>
p wA wB -> p wA wC -> EqCheck wB wC
=\/= prim wZ wY
p2 = Maybe2 prim wX wY -> Maybe (Maybe2 prim wX wY)
forall a. a -> Maybe a
Just Maybe2 prim wX wX
Maybe2 prim wX wY
forall (p :: * -> * -> *) wX. Maybe2 p wX wX
Nothing2
  | Bool
otherwise = prim wX wY -> Maybe2 prim wX wY
forall (p :: * -> * -> *) wX wY. p wX wY -> Maybe2 p wX wY
Just2 (prim wX wY -> Maybe2 prim wX wY)
-> Maybe (prim wX wY) -> Maybe (Maybe2 prim wX wY)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> prim wX wZ -> prim wZ wY -> Maybe (prim wX wY)
forall wX wY wZ. prim wX wY -> prim wY wZ -> Maybe (prim wX wZ)
forall (prim :: * -> * -> *) wX wY wZ.
PrimCoalesce prim =>
prim wX wY -> prim wY wZ -> Maybe (prim wX wZ)
primCoalesce prim wX wZ
p1 prim wZ wY
p2

defaultTryToShrink :: PrimCoalesce prim => FL prim wX wY -> Maybe (FL prim wX wY)
defaultTryToShrink :: forall (prim :: * -> * -> *) wX wY.
PrimCoalesce prim =>
FL prim wX wY -> Maybe (FL prim wX wY)
defaultTryToShrink = (Any, FL prim wX wY) -> Maybe (FL prim wX wY)
forall a. (Any, a) -> Maybe a
withAnyToMaybe ((Any, FL prim wX wY) -> Maybe (FL prim wX wY))
-> (FL prim wX wY -> (Any, FL prim wX wY))
-> FL prim wX wY
-> Maybe (FL prim wX wY)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FL prim wX wY -> (Any, FL prim wX wY)
forall (prim :: * -> * -> *) wX wY.
PrimCoalesce prim =>
FL prim wX wY -> (Any, FL prim wX wY)
sortCoalesceFL2

defaultSortCoalesceFL :: PrimCoalesce prim => FL prim wX wY -> FL prim wX wY
defaultSortCoalesceFL :: forall (prim :: * -> * -> *) wX wY.
PrimCoalesce prim =>
FL prim wX wY -> FL prim wX wY
defaultSortCoalesceFL = (Any, FL prim wX wY) -> FL prim wX wY
forall a b. (a, b) -> b
snd ((Any, FL prim wX wY) -> FL prim wX wY)
-> (FL prim wX wY -> (Any, FL prim wX wY))
-> FL prim wX wY
-> FL prim wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FL prim wX wY -> (Any, FL prim wX wY)
forall (prim :: * -> * -> *) wX wY.
PrimCoalesce prim =>
FL prim wX wY -> (Any, FL prim wX wY)
sortCoalesceFL2

-- | Conversion between @('Any', a)@ and @'Maybe' a@.
withAnyToMaybe :: (Any, a) -> Maybe a
withAnyToMaybe :: forall a. (Any, a) -> Maybe a
withAnyToMaybe (Any Bool
True, a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
withAnyToMaybe (Any Bool
False, a
_) = Maybe a
forall a. Maybe a
Nothing

-- | The heart of 'sortCoalesceFL'.
sortCoalesceFL2 :: PrimCoalesce prim => FL prim wX wY -> (Any, FL prim wX wY)
sortCoalesceFL2 :: forall (prim :: * -> * -> *) wX wY.
PrimCoalesce prim =>
FL prim wX wY -> (Any, FL prim wX wY)
sortCoalesceFL2 FL prim wX wY
NilFL = (Bool -> Any
Any Bool
False, FL prim wX wX
FL prim wX wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
sortCoalesceFL2 (prim wX wY
x:>:FL prim wY wY
xs) = do
  FL prim wY wY
xs' <- FL prim wY wY -> (Any, FL prim wY wY)
forall (prim :: * -> * -> *) wX wY.
PrimCoalesce prim =>
FL prim wX wY -> (Any, FL prim wX wY)
sortCoalesceFL2 FL prim wY wY
xs
  case prim wX wY -> EqCheck wX wY
forall wX wY. prim wX wY -> EqCheck wX wY
forall (prim :: * -> * -> *) wX wY.
PrimCoalesce prim =>
prim wX wY -> EqCheck wX wY
isIdentity prim wX wY
x of
    EqCheck wX wY
IsEq -> (Bool -> Any
Any Bool
True, FL prim wX wY
FL prim wY wY
xs')
    EqCheck wX wY
NotEq -> prim wX wY -> FL prim wY wY -> (Any, FL prim wX wY)
forall (prim :: * -> * -> *) wX wY wZ.
PrimCoalesce prim =>
prim wX wY -> FL prim wY wZ -> (Any, FL prim wX wZ)
pushCoalescePatch prim wX wY
x FL prim wY wY
xs'

-- | Try to coalesce the patch with any of the elements in the sequence,
-- using commutation to push it down the list, until either
--
--  (1) @new@ is 'LT' the next member of the list (using 'comparePrim')
-- 
--  (2) commutation fails or
-- 
--  (3) coalescing succeeds.
--
-- In case (1) we push the patch further, trying to coalesce it with any of its
-- successors and disregarding any ordering. If this is successful, we recurse
-- with the result, otherwise we leave the patch where it was, so the sequence
-- remains sorted.
--
-- In case (3) we recursively continue with the result unless that is empty.
-- 
-- The result is returned in the @('Any',)@ monad to indicate whether it was
-- able to shrink the patch sequence. To make this clear, we do /not/ track
-- whether sorting has made progress, only shrinking.
--
-- The precondition is that the input sequence is already sorted.
pushCoalescePatch
  :: forall prim wX wY wZ
   . PrimCoalesce prim
  => prim wX wY
  -> FL prim wY wZ
  -> (Any, FL prim wX wZ)
pushCoalescePatch :: forall (prim :: * -> * -> *) wX wY wZ.
PrimCoalesce prim =>
prim wX wY -> FL prim wY wZ -> (Any, FL prim wX wZ)
pushCoalescePatch prim wX wY
new FL prim wY wZ
NilFL = (Bool -> Any
Any Bool
False, prim wX wY
newprim wX wY -> FL prim wY wZ -> FL prim wX wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:FL prim wY wY
FL prim wY wZ
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
pushCoalescePatch prim wX wY
new ps :: FL prim wY wZ
ps@(prim wY wY
p :>: FL prim wY wZ
ps') =
  case (:>) prim prim wX wY -> Maybe (Maybe2 prim wX wY)
forall (prim :: * -> * -> *) wX wY.
PrimCoalesce prim =>
(:>) prim prim wX wY -> Maybe (Maybe2 prim wX wY)
coalesce (prim wX wY
new prim wX wY -> prim wY wY -> (:>) prim prim wX wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> prim wY wY
p) of
    Just (Just2 prim wX wY
new') -> (Bool -> Any
Any Bool
True, (Any, FL prim wX wZ) -> FL prim wX wZ
forall a b. (a, b) -> b
snd ((Any, FL prim wX wZ) -> FL prim wX wZ)
-> (Any, FL prim wX wZ) -> FL prim wX wZ
forall a b. (a -> b) -> a -> b
$ prim wX wY -> FL prim wY wZ -> (Any, FL prim wX wZ)
forall (prim :: * -> * -> *) wX wY wZ.
PrimCoalesce prim =>
prim wX wY -> FL prim wY wZ -> (Any, FL prim wX wZ)
pushCoalescePatch prim wX wY
new' FL prim wY wZ
ps')
    Just Maybe2 prim wX wY
Nothing2 -> (Bool -> Any
Any Bool
True, FL prim wX wZ
FL prim wY wZ
ps')
    Maybe (Maybe2 prim wX wY)
Nothing ->
      case prim wX wY -> prim wY wY -> Ordering
forall wA wB wC wD. prim wA wB -> prim wC wD -> Ordering
forall (prim :: * -> * -> *) wA wB wC wD.
PrimCoalesce prim =>
prim wA wB -> prim wC wD -> Ordering
comparePrim prim wX wY
new prim wY wY
p of
        Ordering
LT ->
          case prim wX wY -> FL prim wY wZ -> Maybe (FL prim wX wZ)
forall wA wB wC.
prim wA wB -> FL prim wB wC -> Maybe (FL prim wA wC)
shrinkOne prim wX wY
new FL prim wY wZ
ps of
            Just FL prim wX wZ
ps'' ->
              -- we have to start over here because shrinkOne may have
              -- destroyed the order
              FL prim wX wZ -> (Any, FL prim wX wZ)
forall (prim :: * -> * -> *) wX wY.
PrimCoalesce prim =>
FL prim wX wY -> (Any, FL prim wX wY)
sortCoalesceFL2 FL prim wX wZ
ps''
            Maybe (FL prim wX wZ)
Nothing -> (Bool -> Any
Any Bool
False, prim wX wY
new prim wX wY -> FL prim wY wZ -> FL prim wX wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL prim wY wZ
ps)
        Ordering
_ ->
          case (:>) prim prim wX wY -> Maybe ((:>) prim prim wX wY)
forall wX wY. (:>) prim prim wX wY -> Maybe ((:>) prim prim wX wY)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (prim wX wY
new prim wX wY -> prim wY wY -> (:>) prim prim wX wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> prim wY wY
p) of
            Just (prim wX wZ
p' :> prim wZ wY
new') ->
              case prim wZ wY -> FL prim wY wZ -> (Any, FL prim wZ wZ)
forall (prim :: * -> * -> *) wX wY wZ.
PrimCoalesce prim =>
prim wX wY -> FL prim wY wZ -> (Any, FL prim wX wZ)
pushCoalescePatch prim wZ wY
new' FL prim wY wZ
ps' of
                (Any Bool
True, FL prim wZ wZ
r) -> (Bool -> Any
Any Bool
True, (Any, FL prim wX wZ) -> FL prim wX wZ
forall a b. (a, b) -> b
snd ((Any, FL prim wX wZ) -> FL prim wX wZ)
-> (Any, FL prim wX wZ) -> FL prim wX wZ
forall a b. (a -> b) -> a -> b
$ prim wX wZ -> FL prim wZ wZ -> (Any, FL prim wX wZ)
forall (prim :: * -> * -> *) wX wY wZ.
PrimCoalesce prim =>
prim wX wY -> FL prim wY wZ -> (Any, FL prim wX wZ)
pushCoalescePatch prim wX wZ
p' FL prim wZ wZ
r)
                (Any Bool
False, FL prim wZ wZ
r) -> (Bool -> Any
Any Bool
False, prim wX wZ
p' prim wX wZ -> FL prim wZ wZ -> FL prim wX wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL prim wZ wZ
r)
            Maybe ((:>) prim prim wX wY)
Nothing -> (Bool -> Any
Any Bool
False, prim wX wY
new prim wX wY -> FL prim wY wZ -> FL prim wX wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL prim wY wZ
ps)
  where
    -- Try to coalesce a patch with any element of an adjacent sequence,
    -- regardless of ordering. If successful, the result may not be
    -- sorted, even if the input was.
    shrinkOne :: prim wA wB -> FL prim wB wC -> Maybe (FL prim wA wC)
    shrinkOne :: forall wA wB wC.
prim wA wB -> FL prim wB wC -> Maybe (FL prim wA wC)
shrinkOne prim wA wB
_ FL prim wB wC
NilFL = Maybe (FL prim wA wC)
forall a. Maybe a
Nothing
    shrinkOne prim wA wB
a (prim wB wY
b :>: FL prim wY wC
bs) =
      case (:>) prim prim wA wY -> Maybe (Maybe2 prim wA wY)
forall (prim :: * -> * -> *) wX wY.
PrimCoalesce prim =>
(:>) prim prim wX wY -> Maybe (Maybe2 prim wX wY)
coalesce (prim wA wB
a prim wA wB -> prim wB wY -> (:>) prim prim wA wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> prim wB wY
b) of
        Just Maybe2 prim wA wY
Nothing2 -> FL prim wA wC -> Maybe (FL prim wA wC)
forall a. a -> Maybe a
Just FL prim wA wC
FL prim wY wC
bs
        Just (Just2 prim wA wY
ab) -> FL prim wA wC -> Maybe (FL prim wA wC)
forall a. a -> Maybe a
Just (FL prim wA wC -> Maybe (FL prim wA wC))
-> FL prim wA wC -> Maybe (FL prim wA wC)
forall a b. (a -> b) -> a -> b
$ FL prim wA wC -> Maybe (FL prim wA wC) -> FL prim wA wC
forall a. a -> Maybe a -> a
fromMaybe (prim wA wY
ab prim wA wY -> FL prim wY wC -> FL prim wA wC
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL prim wY wC
bs) (Maybe (FL prim wA wC) -> FL prim wA wC)
-> Maybe (FL prim wA wC) -> FL prim wA wC
forall a b. (a -> b) -> a -> b
$ prim wA wY -> FL prim wY wC -> Maybe (FL prim wA wC)
forall wA wB wC.
prim wA wB -> FL prim wB wC -> Maybe (FL prim wA wC)
shrinkOne prim wA wY
ab FL prim wY wC
bs
        Maybe (Maybe2 prim wA wY)
Nothing -> do
          prim wA wZ
b' :> prim wZ wY
a' <- (:>) prim prim wA wY -> Maybe ((:>) prim prim wA wY)
forall wX wY. (:>) prim prim wX wY -> Maybe ((:>) prim prim wX wY)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (prim wA wB
a prim wA wB -> prim wB wY -> (:>) prim prim wA wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> prim wB wY
b)
          (prim wA wZ
b' prim wA wZ -> FL prim wZ wC -> FL prim wA wC
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:) (FL prim wZ wC -> FL prim wA wC)
-> Maybe (FL prim wZ wC) -> Maybe (FL prim wA wC)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> prim wZ wY -> FL prim wY wC -> Maybe (FL prim wZ wC)
forall wA wB wC.
prim wA wB -> FL prim wB wC -> Maybe (FL prim wA wC)
shrinkOne prim wZ wY
a' FL prim wY wC
bs