{- | Formal inverses for patches that aren't really invertible. Note that
most the mixed {'Fwd','Rev'} cases for 'Commute' and 'Eq2' are just errors.
-}
module Darcs.Patch.Invertible
    ( Invertible
    , mkInvertible
    , fromPositiveInvertible
    , withInvertible
    ) where

import Darcs.Prelude

import Darcs.Patch.CommuteFn ( invertCommuter )
import Darcs.Patch.Ident
  ( Ident(..), PatchId, SignedId(..) )
import Darcs.Patch.Invert ( Invert(..) )
import Darcs.Patch.RepoPatch
    ( Apply(..)
    , Commute(..)
    , Eq2(..)
    , PrimPatchBase(..)
    , PatchInspect(..)
    , ShowContextPatch(..)
    , ShowPatch(..)
    , ShowPatchBasic(..)
    )
import Darcs.Patch.Show ( ShowPatchFor(..) )
import Darcs.Patch.Witnesses.Ordered ((:>)(..))

-- | Wrapper type to allow formal inversion of patches which aren't really
-- invertible.
data Invertible p wX wY where
   Fwd :: p wX wY -> Invertible p wX wY
   Rev :: p wX wY -> Invertible p wY wX

-- | Wrap a patch to make it (formally) 'Invertible'. The result is initially
-- positive i.e. 'Fwd'.
mkInvertible :: p wX wY -> Invertible p wX wY
mkInvertible :: p wX wY -> Invertible p wX wY
mkInvertible = p wX wY -> Invertible p wX wY
forall (p :: * -> * -> *) wX wY. p wX wY -> Invertible p wX wY
Fwd

-- | Get the underlying patch from an 'Invertible', assuming (as a precondition)
-- that it is positive i.e. 'Fwd'.
fromPositiveInvertible :: Invertible p wX wY -> p wX wY
fromPositiveInvertible :: Invertible p wX wY -> p wX wY
fromPositiveInvertible (Fwd p wX wY
p) = p wX wY
p
fromPositiveInvertible (Rev p wY wX
_) = [Char] -> p wX wY
forall a. HasCallStack => [Char] -> a
error [Char]
"precondition of fromPositiveInvertible"

-- | Run a function on the patch inside an 'Invertible'. The function has to be
-- parametric in the witnesses, so we can run it with both a 'Fwd' and a 'Rev'
-- patch.
withInvertible :: (forall wA wB. p wA wB -> r) -> Invertible p wX wY -> r
withInvertible :: (forall wA wB. p wA wB -> r) -> Invertible p wX wY -> r
withInvertible forall wA wB. p wA wB -> r
f (Fwd p wX wY
p) = p wX wY -> r
forall wA wB. p wA wB -> r
f p wX wY
p
withInvertible forall wA wB. p wA wB -> r
f (Rev p wY wX
p) = p wY wX -> r
forall wA wB. p wA wB -> r
f p wY wX
p

instance Invert (Invertible p) where
  invert :: Invertible p wX wY -> Invertible p wY wX
invert (Fwd p wX wY
p) = p wX wY -> Invertible p wY wX
forall (p :: * -> * -> *) wX wY. p wX wY -> Invertible p wY wX
Rev p wX wY
p
  invert (Rev p wY wX
p) = p wY wX -> Invertible p wY wX
forall (p :: * -> * -> *) wX wY. p wX wY -> Invertible p wX wY
Fwd p wY wX
p

instance Commute p => Commute (Invertible p) where
  commute :: (:>) (Invertible p) (Invertible p) wX wY
-> Maybe ((:>) (Invertible p) (Invertible p) wX wY)
commute (Fwd p wX wZ
p :> Fwd p wZ wY
q) = do
    p wX wZ
q' :> p wZ wY
p' <- (:>) p p wX wY -> Maybe ((:>) p p wX wY)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (p wX wZ
p p wX wZ -> p wZ wY -> (:>) p p wX wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> p wZ wY
q)
    (:>) (Invertible p) (Invertible p) wX wY
-> Maybe ((:>) (Invertible p) (Invertible p) wX wY)
forall (m :: * -> *) a. Monad m => a -> m a
return (p wX wZ -> Invertible p wX wZ
forall (p :: * -> * -> *) wX wY. p wX wY -> Invertible p wX wY
Fwd p wX wZ
q' Invertible p wX wZ
-> Invertible p wZ wY -> (:>) (Invertible p) (Invertible p) wX wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> p wZ wY -> Invertible p wZ wY
forall (p :: * -> * -> *) wX wY. p wX wY -> Invertible p wX wY
Fwd p wZ wY
p')
  commute pair :: (:>) (Invertible p) (Invertible p) wX wY
pair@(Rev p wZ wX
_ :> Rev p wY wZ
_) = (forall wX wY.
 (:>) (Invertible p) (Invertible p) wX wY
 -> Maybe ((:>) (Invertible p) (Invertible p) wX wY))
-> (:>) (Invertible p) (Invertible p) wX wY
-> Maybe ((:>) (Invertible p) (Invertible p) wX wY)
forall (p :: * -> * -> *) (q :: * -> * -> *).
(Invert p, Invert q) =>
CommuteFn p q -> CommuteFn q p
invertCommuter forall wX wY.
(:>) (Invertible p) (Invertible p) wX wY
-> Maybe ((:>) (Invertible p) (Invertible p) wX wY)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (:>) (Invertible p) (Invertible p) wX wY
pair
  commute (:>) (Invertible p) (Invertible p) wX wY
_ = [Char] -> Maybe ((:>) (Invertible p) (Invertible p) wX wY)
forall a. HasCallStack => [Char] -> a
error [Char]
"cannote commute mixed Fwd/Rev"

instance Eq2 p => Eq2 (Invertible p) where
  Fwd p wA wB
p =\/= :: Invertible p wA wB -> Invertible p wA wC -> EqCheck wB wC
=\/= Fwd p wA wC
q = p wA wB
p p wA wB -> p wA wC -> EqCheck wB wC
forall (p :: * -> * -> *) wA wB wC.
Eq2 p =>
p wA wB -> p wA wC -> EqCheck wB wC
=\/= p wA wC
q
  Rev p wB wA
p =\/= Rev p wC wA
q = p wB wA
p p wB wA -> p wC wA -> EqCheck wB wC
forall (p :: * -> * -> *) wA wC wB.
Eq2 p =>
p wA wC -> p wB wC -> EqCheck wA wB
=/\= p wC wA
q
  Invertible p wA wB
_ =\/= Invertible p wA wC
_ = [Char] -> EqCheck wB wC
forall a. HasCallStack => [Char] -> a
error [Char]
"cannot compare mixed Fwd/Rev"

instance Apply p => Apply (Invertible p) where
  type ApplyState (Invertible p) = ApplyState p
  apply :: Invertible p wX wY -> m ()
apply (Fwd p wX wY
p) = p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wX wY
p
  apply (Rev p wY wX
p) = p wY wX -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply p wY wX
p
  unapply :: Invertible p wX wY -> m ()
unapply (Fwd p wX wY
p) = p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply p wX wY
p
  unapply (Rev p wY wX
p) = p wY wX -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wY wX
p

data InvertibleId ident = InvertibleId Bool ident
  deriving (InvertibleId ident -> InvertibleId ident -> Bool
(InvertibleId ident -> InvertibleId ident -> Bool)
-> (InvertibleId ident -> InvertibleId ident -> Bool)
-> Eq (InvertibleId ident)
forall ident.
Eq ident =>
InvertibleId ident -> InvertibleId ident -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InvertibleId ident -> InvertibleId ident -> Bool
$c/= :: forall ident.
Eq ident =>
InvertibleId ident -> InvertibleId ident -> Bool
== :: InvertibleId ident -> InvertibleId ident -> Bool
$c== :: forall ident.
Eq ident =>
InvertibleId ident -> InvertibleId ident -> Bool
Eq, Eq (InvertibleId ident)
Eq (InvertibleId ident)
-> (InvertibleId ident -> InvertibleId ident -> Ordering)
-> (InvertibleId ident -> InvertibleId ident -> Bool)
-> (InvertibleId ident -> InvertibleId ident -> Bool)
-> (InvertibleId ident -> InvertibleId ident -> Bool)
-> (InvertibleId ident -> InvertibleId ident -> Bool)
-> (InvertibleId ident -> InvertibleId ident -> InvertibleId ident)
-> (InvertibleId ident -> InvertibleId ident -> InvertibleId ident)
-> Ord (InvertibleId ident)
InvertibleId ident -> InvertibleId ident -> Bool
InvertibleId ident -> InvertibleId ident -> Ordering
InvertibleId ident -> InvertibleId ident -> InvertibleId ident
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall ident. Ord ident => Eq (InvertibleId ident)
forall ident.
Ord ident =>
InvertibleId ident -> InvertibleId ident -> Bool
forall ident.
Ord ident =>
InvertibleId ident -> InvertibleId ident -> Ordering
forall ident.
Ord ident =>
InvertibleId ident -> InvertibleId ident -> InvertibleId ident
min :: InvertibleId ident -> InvertibleId ident -> InvertibleId ident
$cmin :: forall ident.
Ord ident =>
InvertibleId ident -> InvertibleId ident -> InvertibleId ident
max :: InvertibleId ident -> InvertibleId ident -> InvertibleId ident
$cmax :: forall ident.
Ord ident =>
InvertibleId ident -> InvertibleId ident -> InvertibleId ident
>= :: InvertibleId ident -> InvertibleId ident -> Bool
$c>= :: forall ident.
Ord ident =>
InvertibleId ident -> InvertibleId ident -> Bool
> :: InvertibleId ident -> InvertibleId ident -> Bool
$c> :: forall ident.
Ord ident =>
InvertibleId ident -> InvertibleId ident -> Bool
<= :: InvertibleId ident -> InvertibleId ident -> Bool
$c<= :: forall ident.
Ord ident =>
InvertibleId ident -> InvertibleId ident -> Bool
< :: InvertibleId ident -> InvertibleId ident -> Bool
$c< :: forall ident.
Ord ident =>
InvertibleId ident -> InvertibleId ident -> Bool
compare :: InvertibleId ident -> InvertibleId ident -> Ordering
$ccompare :: forall ident.
Ord ident =>
InvertibleId ident -> InvertibleId ident -> Ordering
$cp1Ord :: forall ident. Ord ident => Eq (InvertibleId ident)
Ord)

instance Ord ident => SignedId (InvertibleId ident) where
  positiveId :: InvertibleId ident -> Bool
positiveId (InvertibleId Bool
inverted ident
_) = Bool
inverted
  invertId :: InvertibleId ident -> InvertibleId ident
invertId (InvertibleId Bool
inverted ident
theid) =
     Bool -> ident -> InvertibleId ident
forall ident. Bool -> ident -> InvertibleId ident
InvertibleId (Bool -> Bool
not Bool
inverted) ident
theid

type instance PatchId (Invertible p) = InvertibleId (PatchId p)

instance Ident p => Ident (Invertible p) where
  ident :: Invertible p wX wY -> PatchId (Invertible p)
ident (Fwd p wX wY
p) = Bool -> PatchId p -> InvertibleId (PatchId p)
forall ident. Bool -> ident -> InvertibleId ident
InvertibleId Bool
False (p wX wY -> PatchId p
forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident p wX wY
p)
  ident (Rev p wY wX
p) = Bool -> PatchId p -> InvertibleId (PatchId p)
forall ident. Bool -> ident -> InvertibleId ident
InvertibleId Bool
True  (p wY wX -> PatchId p
forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident p wY wX
p)

instance PatchInspect p => PatchInspect (Invertible p) where
  listTouchedFiles :: Invertible p wX wY -> [AnchoredPath]
listTouchedFiles (Fwd p wX wY
p) = p wX wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles p wX wY
p
  listTouchedFiles (Rev p wY wX
p) = p wY wX -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles p wY wX
p
  hunkMatches :: (ByteString -> Bool) -> Invertible p wX wY -> Bool
hunkMatches ByteString -> Bool
f (Fwd p wX wY
p) = (ByteString -> Bool) -> p wX wY -> Bool
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
(ByteString -> Bool) -> p wX wY -> Bool
hunkMatches ByteString -> Bool
f p wX wY
p
  hunkMatches ByteString -> Bool
f (Rev p wY wX
p) = (ByteString -> Bool) -> p wY wX -> Bool
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
(ByteString -> Bool) -> p wX wY -> Bool
hunkMatches ByteString -> Bool
f p wY wX
p

instance PrimPatchBase p => PrimPatchBase (Invertible p) where
  type PrimOf (Invertible p) = PrimOf p

instance ShowPatchBasic p => ShowPatchBasic (Invertible p) where
  showPatch :: ShowPatchFor -> Invertible p wX wY -> Doc
showPatch ShowPatchFor
ForStorage = [Char] -> Invertible p wX wY -> Doc
forall a. HasCallStack => [Char] -> a
error [Char]
"Invertible patches must not be stored"
  showPatch ShowPatchFor
ForDisplay = (forall wA wB. p wA wB -> Doc) -> Invertible p wX wY -> Doc
forall (p :: * -> * -> *) r wX wY.
(forall wA wB. p wA wB -> r) -> Invertible p wX wY -> r
withInvertible (ShowPatchFor -> p wA wB -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
ForDisplay)

instance ShowPatch p => ShowPatch (Invertible p) where
  -- note these are only used for display
  description :: Invertible p wX wY -> Doc
description = (forall wA wB. p wA wB -> Doc) -> Invertible p wX wY -> Doc
forall (p :: * -> * -> *) r wX wY.
(forall wA wB. p wA wB -> r) -> Invertible p wX wY -> r
withInvertible forall wA wB. p wA wB -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description
  summary :: Invertible p wX wY -> Doc
summary = (forall wA wB. p wA wB -> Doc) -> Invertible p wX wY -> Doc
forall (p :: * -> * -> *) r wX wY.
(forall wA wB. p wA wB -> r) -> Invertible p wX wY -> r
withInvertible forall wA wB. p wA wB -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
summary
  content :: Invertible p wX wY -> Doc
content = (forall wA wB. p wA wB -> Doc) -> Invertible p wX wY -> Doc
forall (p :: * -> * -> *) r wX wY.
(forall wA wB. p wA wB -> r) -> Invertible p wX wY -> r
withInvertible forall wA wB. p wA wB -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
content

instance ShowContextPatch p => ShowContextPatch (Invertible p) where
  showContextPatch :: ShowPatchFor -> Invertible p wX wY -> m Doc
showContextPatch ShowPatchFor
ForStorage = [Char] -> Invertible p wX wY -> m Doc
forall a. HasCallStack => [Char] -> a
error [Char]
"Invertible patches must not be stored"
  showContextPatch ShowPatchFor
ForDisplay = (forall wA wB. p wA wB -> m Doc) -> Invertible p wX wY -> m Doc
forall (p :: * -> * -> *) r wX wY.
(forall wA wB. p wA wB -> r) -> Invertible p wX wY -> r
withInvertible (ShowPatchFor -> p wA wB -> m Doc
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(ShowContextPatch p, ApplyMonad (ApplyState p) m) =>
ShowPatchFor -> p wX wY -> m Doc
showContextPatch ShowPatchFor
ForDisplay)