-- | Generic wrapper for prim patches to give them an identity.
module Darcs.Patch.Prim.WithName
  ( PrimWithName(..)
  ) where

import Darcs.Prelude

import Darcs.Patch.Annotate ( Annotate(..) )
import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.Commute ( Commute(..) )
import Darcs.Patch.Format ( PatchListFormat(..) )
import Darcs.Patch.Ident
    ( Ident(..)
    , PatchId
    , SignedId(..)
    , StorableId(..)
    , IdEq2(..)
    )
import Darcs.Patch.Inspect ( PatchInspect(..) )
import Darcs.Patch.FileHunk ( IsHunk(..) )
import Darcs.Patch.Prim.Class ( PrimApply(..), PrimClassify(..), PrimDetails(..) )
import Darcs.Patch.Invert ( Invert(..) )
import Darcs.Patch.Merge ( CleanMerge(..) )
import Darcs.Patch.Read ( ReadPatch(..) )
import Darcs.Patch.Repair ( RepairToFL(..) )
import Darcs.Patch.Show
    ( ShowPatchBasic(..)
    , ShowPatch(..)
    , ShowContextPatch(..)
    )
import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims )
import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )
import Darcs.Patch.Witnesses.Ordered ( mapFL_FL, (:>)(..), (:\/:)(..), (:/\:)(..) )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
import Darcs.Patch.Witnesses.Show ( Show1, Show2, appPrec, showsPrec2 )

import Darcs.Util.Printer

-- |A 'PrimWithName' is a general way of associating an identity
-- with an underlying (presumably unnamed) primitive type. This is
-- required, for example, for V3 patches.
-- Normally the members of the 'name' type will be generated in
-- some way when a patch is initially created, to guarantee global
-- unqiueness across all repositories.
data PrimWithName name p wX wY =
  PrimWithName { forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> name
wnName :: !name, forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch :: !(p wX wY) }

type instance PatchId (PrimWithName name p) = name

instance SignedId name => Ident (PrimWithName name p) where
  ident :: forall wX wY.
PrimWithName name p wX wY -> PatchId (PrimWithName name p)
ident = forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> name
wnName

instance (SignedId name, Eq2 p) => IdEq2 (PrimWithName name p)

instance (Eq name, Eq2 p) => Eq2 (PrimWithName name p) where
  PrimWithName name
i p wA wB
p =\/= :: forall wA wB wC.
PrimWithName name p wA wB
-> PrimWithName name p wA wC -> EqCheck wB wC
=\/= PrimWithName name
j p wA wC
q
    | name
i forall a. Eq a => a -> a -> Bool
== name
j, EqCheck wB wC
IsEq <- p wA wB
p forall (p :: * -> * -> *) wA wB wC.
Eq2 p =>
p wA wB -> p wA wC -> EqCheck wB wC
=\/= p wA wC
q = forall wA. EqCheck wA wA
IsEq
    | Bool
otherwise = forall wA wB. EqCheck wA wB
NotEq

instance (Invert p, SignedId name) => Invert (PrimWithName name p) where
  invert :: forall wX wY.
PrimWithName name p wX wY -> PrimWithName name p wY wX
invert (PrimWithName name
i p wX wY
p) = forall name (p :: * -> * -> *) wX wY.
name -> p wX wY -> PrimWithName name p wX wY
PrimWithName (forall a. SignedId a => a -> a
invertId name
i) (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert p wX wY
p)

instance PatchInspect p => PatchInspect (PrimWithName name p) where
  listTouchedFiles :: forall wX wY. PrimWithName name p wX wY -> [AnchoredPath]
listTouchedFiles = forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch
  hunkMatches :: forall wX wY.
(ByteString -> Bool) -> PrimWithName name p wX wY -> Bool
hunkMatches ByteString -> Bool
m = forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
(ByteString -> Bool) -> p wX wY -> Bool
hunkMatches ByteString -> Bool
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch

instance (Show2 p, Show name) => Show (PrimWithName name p wX wY) where
  showsPrec :: Int -> PrimWithName name p wX wY -> ShowS
showsPrec Int
d (PrimWithName name
i p wX wY
p) =
    Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
appPrec)
      forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"PrimWithName "
      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) name
i
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
      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) p wX wY
p

instance (Show2 p, Show name) => Show1 (PrimWithName name p wX)

instance (Show2 p, Show name) => Show2 (PrimWithName name p)

instance Apply p => Apply (PrimWithName name p) where
  type ApplyState (PrimWithName name p) = ApplyState p
  apply :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (PrimWithName name p)) m =>
PrimWithName name p wX wY -> m ()
apply = forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch
  unapply :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (PrimWithName name p)) m =>
PrimWithName name p wX wY -> m ()
unapply = forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch

instance PatchListFormat (PrimWithName name p)

instance Apply p => RepairToFL (PrimWithName name p) where
  applyAndTryToFixFL :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (PrimWithName name p)) m =>
PrimWithName name p wX wY
-> m (Maybe (String, FL (PrimWithName name p) wX wY))
applyAndTryToFixFL PrimWithName name p wX wY
p = forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply PrimWithName name p wX wY
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

instance Annotate p => Annotate (PrimWithName name p) where
  annotate :: forall wX wY. PrimWithName name p wX wY -> AnnotatedM ()
annotate = forall (p :: * -> * -> *) wX wY.
Annotate p =>
p wX wY -> AnnotatedM ()
annotate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch

instance IsHunk p => IsHunk (PrimWithName name p) where
  isHunk :: forall wX wY. PrimWithName name p wX wY -> Maybe (FileHunk wX wY)
isHunk = forall (p :: * -> * -> *) wX wY.
IsHunk p =>
p wX wY -> Maybe (FileHunk wX wY)
isHunk forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch

instance PrimApply p => PrimApply (PrimWithName name p) where
  applyPrimFL :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (PrimWithName name p)) m =>
FL (PrimWithName name p) wX wY -> m ()
applyPrimFL = 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 (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

instance PrimClassify p => PrimClassify (PrimWithName name p) where
  primIsAddfile :: forall wX wY. PrimWithName name p wX wY -> Bool
primIsAddfile = forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsAddfile forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch
  primIsRmfile :: forall wX wY. PrimWithName name p wX wY -> Bool
primIsRmfile = forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsRmfile forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch
  primIsAdddir :: forall wX wY. PrimWithName name p wX wY -> Bool
primIsAdddir = forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsAdddir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch
  primIsRmdir :: forall wX wY. PrimWithName name p wX wY -> Bool
primIsRmdir = forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsRmdir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch
  primIsHunk :: forall wX wY. PrimWithName name p wX wY -> Bool
primIsHunk = forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsHunk forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch
  primIsMove :: forall wX wY. PrimWithName name p wX wY -> Bool
primIsMove = forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsMove forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch
  primIsBinary :: forall wX wY. PrimWithName name p wX wY -> Bool
primIsBinary = forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsBinary forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch
  primIsTokReplace :: forall wX wY. PrimWithName name p wX wY -> Bool
primIsTokReplace = forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsTokReplace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch
  primIsSetpref :: forall wX wY. PrimWithName name p wX wY -> Bool
primIsSetpref = forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsSetpref forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch
  is_filepatch :: forall wX wY. PrimWithName name p wX wY -> Maybe AnchoredPath
is_filepatch = forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Maybe AnchoredPath
is_filepatch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch

instance PrimDetails p => PrimDetails (PrimWithName name p) where
  summarizePrim :: forall wX wY. PrimWithName name p wX wY -> [SummDetail]
summarizePrim = forall (prim :: * -> * -> *) wX wY.
PrimDetails prim =>
prim wX wY -> [SummDetail]
summarizePrim forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch

-- this is the most important definition:
-- it ensures that a patch conflicts with itself
instance (SignedId name, Commute p) => Commute (PrimWithName name p) where
  commute :: forall wX wY.
(:>) (PrimWithName name p) (PrimWithName name p) wX wY
-> Maybe ((:>) (PrimWithName name p) (PrimWithName name p) wX wY)
commute (PrimWithName name
i1 p wX wZ
p1 :> PrimWithName name
i2 p wZ wY
p2)
    -- We should never get into a situation where we try
    -- to commute identical patches
    | name
i1 forall a. Eq a => a -> a -> Bool
== name
i2 = forall a. HasCallStack => String -> a
error String
"internal error: trying to commute identical patches"
    -- whereas this case is the equivalent of merging a patch
    -- with itself, so it is correct to just report that they don't commute
    | name
i1 forall a. Eq a => a -> a -> Bool
== forall a. SignedId a => a -> a
invertId name
i2 = forall a. Maybe a
Nothing
    | Bool
otherwise = do
        p wX wZ
p2' :> p wZ wY
p1' <- forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (p wX wZ
p1 forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> p wZ wY
p2)
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall name (p :: * -> * -> *) wX wY.
name -> p wX wY -> PrimWithName name p wX wY
PrimWithName name
i2 p wX wZ
p2' forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> forall name (p :: * -> * -> *) wX wY.
name -> p wX wY -> PrimWithName name p wX wY
PrimWithName name
i1 p wZ wY
p1')

instance (SignedId name, CleanMerge p) => CleanMerge (PrimWithName name p) where
  cleanMerge :: forall wX wY.
(:\/:) (PrimWithName name p) (PrimWithName name p) wX wY
-> Maybe ((:/\:) (PrimWithName name p) (PrimWithName name p) wX wY)
cleanMerge (PrimWithName name
i1 p wZ wX
p1 :\/: PrimWithName name
i2 p wZ wY
p2)
    | name
i1 forall a. Eq a => a -> a -> Bool
== name
i2 = forall a. HasCallStack => String -> a
error String
"cannot cleanMerge identical patches"
    | Bool
otherwise = do
        p wX wZ
p2' :/\: p wY wZ
p1' <- forall (p :: * -> * -> *) wX wY.
CleanMerge p =>
(:\/:) p p wX wY -> Maybe ((:/\:) p p wX wY)
cleanMerge (p wZ wX
p1 forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wZ wX -> a2 wZ wY -> (:\/:) a1 a2 wX wY
:\/: p wZ wY
p2)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall name (p :: * -> * -> *) wX wY.
name -> p wX wY -> PrimWithName name p wX wY
PrimWithName name
i2 p wX wZ
p2' forall (a3 :: * -> * -> *) (a4 :: * -> * -> *) wX wY wZ.
a3 wX wZ -> a4 wY wZ -> (:/\:) a3 a4 wX wY
:/\: forall name (p :: * -> * -> *) wX wY.
name -> p wX wY -> PrimWithName name p wX wY
PrimWithName name
i1 p wY wZ
p1'

instance (StorableId name, ReadPatch p) => ReadPatch (PrimWithName name p) where
  readPatch' :: forall wX. Parser (Sealed (PrimWithName name p wX))
readPatch' = do
      name
name <- forall a. StorableId a => Parser a
readId
      Sealed p wX wX
p <- forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch'
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (forall name (p :: * -> * -> *) wX wY.
name -> p wX wY -> PrimWithName name p wX wY
PrimWithName name
name p wX wX
p))

instance (StorableId name, ShowPatchBasic p) => ShowPatchBasic (PrimWithName name p) where
  showPatch :: forall wX wY. ShowPatchFor -> PrimWithName name p wX wY -> Doc
showPatch ShowPatchFor
use (PrimWithName name
name p wX wY
p) = forall a. StorableId a => ShowPatchFor -> a -> Doc
showId ShowPatchFor
use name
name Doc -> Doc -> Doc
$$ forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
use p wX wY
p

instance (StorableId name, PrimDetails p, ShowPatchBasic p) => ShowPatch (PrimWithName name p) where
  summary :: forall wX wY. PrimWithName name p wX wY -> Doc
summary = forall (prim :: * -> * -> *) wX wY.
PrimDetails prim =>
prim wX wY -> Doc
plainSummaryPrim forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (p :: * -> * -> *) wX wY.
PrimWithName name p wX wY -> p wX wY
wnPatch
  summaryFL :: forall wX wY. FL (PrimWithName name p) wX wY -> Doc
summaryFL = forall (prim :: * -> * -> *) wX wY.
PrimDetails prim =>
Bool -> FL prim wX wY -> Doc
plainSummaryPrims Bool
False
  thing :: forall wX wY. PrimWithName name p wX wY -> String
thing PrimWithName name p wX wY
_ = String
"change"

instance (StorableId name, ShowContextPatch p) => ShowContextPatch (PrimWithName name p) where
  showContextPatch :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (PrimWithName name p)) m =>
ShowPatchFor -> PrimWithName name p wX wY -> m Doc
showContextPatch ShowPatchFor
use (PrimWithName name
name p wX wY
p) = do
    Doc
r <- forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(ShowContextPatch p, ApplyMonad (ApplyState p) m) =>
ShowPatchFor -> p wX wY -> m Doc
showContextPatch ShowPatchFor
use p wX wY
p
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. StorableId a => ShowPatchFor -> a -> Doc
showId ShowPatchFor
use name
name Doc -> Doc -> Doc
$$ Doc
r