--  Copyright (C) 2002-2005 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

-- |
-- Module      : Darcs.Patch.Apply
-- Copyright   : 2002-2005 David Roundy
-- License     : GPL
-- Maintainer  : darcs-devel@darcs.net
-- Stability   : experimental
-- Portability : portable

module Darcs.Patch.Apply
    (
      Apply(..)
    , ObjectIdOfPatch
    , applyToPaths
    , applyToTree
    , applyToState
    , maybeApplyToTree
    , effectOnPaths
    ) where

import Darcs.Prelude

import Control.Exception ( IOException )
import Control.Monad.Catch ( MonadThrow, MonadCatch(catch) )

import Darcs.Util.Path ( AnchoredPath )
import Darcs.Util.Tree ( Tree )

import Darcs.Patch.ApplyMonad ( ApplyMonad(..), withFileNames, ApplyMonadTrans(..) )
import Darcs.Patch.Invert ( Invert(..) )
import Darcs.Patch.Object ( ObjectIdOf )
import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) )

class Apply p where
    type ApplyState p :: (* -> *) -> *
    apply :: ApplyMonad (ApplyState p) m => p wX wY -> m ()
    unapply :: ApplyMonad (ApplyState p) m => p wX wY -> m ()
    default unapply :: (ApplyMonad (ApplyState p) m, Invert p) => p wX wY -> m ()
    unapply = p wY wX -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply (p wY wX -> m ()) -> (p wX wY -> p wY wX) -> p wX wY -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p wX wY -> p wY wX
forall wX wY. p wX wY -> p wY wX
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert

instance Apply p => Apply (FL p) where
    type ApplyState (FL p) = ApplyState p
    apply :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (FL p)) m =>
FL p wX wY -> m ()
apply FL p wX wY
NilFL = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    apply (p wX wY
p:>:FL p wY wY
ps) = p wX wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wX wY
p m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FL p wY wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (FL p)) m =>
FL p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply FL p wY wY
ps
    unapply :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (FL p)) m =>
FL p wX wY -> m ()
unapply FL p wX wY
NilFL = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    unapply (p wX wY
p:>:FL p wY wY
ps) = FL p wY wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (FL p)) m =>
FL p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply FL p wY wY
ps m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> p wX wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply p wX wY
p

instance Apply p => Apply (RL p) where
    type ApplyState (RL p) = ApplyState p
    apply :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (RL p)) m =>
RL p wX wY -> m ()
apply RL p wX wY
NilRL = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    apply (RL p wX wY
ps:<:p wY wY
p) = RL p wX wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (RL p)) m =>
RL p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply RL p wX wY
ps m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> p wY wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wY wY
p
    unapply :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (RL p)) m =>
RL p wX wY -> m ()
unapply RL p wX wY
NilRL = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    unapply (RL p wX wY
ps:<:p wY wY
p) = p wY wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply p wY wY
p m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RL p wX wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (RL p)) m =>
RL p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply RL p wX wY
ps

type ObjectIdOfPatch p = ObjectIdOf (ApplyState p)

effectOnPaths :: (Apply p, ApplyState p ~ Tree)
              => p wX wY
              -> [AnchoredPath]
              -> [AnchoredPath]
effectOnPaths :: forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> [AnchoredPath] -> [AnchoredPath]
effectOnPaths p wX wY
p [AnchoredPath]
fps = [AnchoredPath]
fps' where
    ([AnchoredPath]
_, [AnchoredPath]
fps', [(AnchoredPath, AnchoredPath)]
_) = p wX wY
-> Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> ([AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY
-> Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> ([AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])
applyToPaths p wX wY
p Maybe [(AnchoredPath, AnchoredPath)]
forall a. Maybe a
Nothing [AnchoredPath]
fps

applyToPaths :: (Apply p, ApplyState p ~ Tree)
             => p wX wY
             -> Maybe [(AnchoredPath, AnchoredPath)]
             -> [AnchoredPath]
             -> ([AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])
applyToPaths :: forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY
-> Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> ([AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])
applyToPaths p wX wY
pa Maybe [(AnchoredPath, AnchoredPath)]
ofpos [AnchoredPath]
fs = Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> FilePathMonad ()
-> ([AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])
forall a.
Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> FilePathMonad a
-> ([AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])
withFileNames Maybe [(AnchoredPath, AnchoredPath)]
ofpos [AnchoredPath]
fs (p wX wY -> FilePathMonad ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wX wY
pa)

-- | Apply a patch to a 'Tree', yielding a new 'Tree'.
applyToTree :: (Apply p, MonadThrow m, ApplyState p ~ Tree)
            => p wX wY
            -> Tree m
            -> m (Tree m)
applyToTree :: forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, MonadThrow m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree = p wX wY -> Tree m -> m (Tree m)
p wX wY -> ApplyState p m -> m (ApplyState p m)
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonadTrans (ApplyState p) m) =>
p wX wY -> ApplyState p m -> m (ApplyState p m)
applyToState

applyToState :: forall p m wX wY. (Apply p, ApplyMonadTrans (ApplyState p) m)
             => p wX wY
             -> (ApplyState p) m
             -> m ((ApplyState p) m)
applyToState :: forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonadTrans (ApplyState p) m) =>
p wX wY -> ApplyState p m -> m (ApplyState p m)
applyToState p wX wY
patch ApplyState p m
t = ((), ApplyState p m) -> ApplyState p m
forall a b. (a, b) -> b
snd (((), ApplyState p m) -> ApplyState p m)
-> m ((), ApplyState p m) -> m (ApplyState p m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ApplyMonadOver (ApplyState p) m ()
-> ApplyState p m -> m ((), ApplyState p m)
forall x.
ApplyMonadOver (ApplyState p) m x
-> ApplyState p m -> m (x, ApplyState p m)
forall (state :: (* -> *) -> *) (m :: * -> *) x.
ApplyMonadTrans state m =>
ApplyMonadOver state m x -> state m -> m (x, state m)
runApplyMonad (p wX wY -> ApplyMonadOver (ApplyState p) m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wX wY
patch) ApplyState p m
t

-- | Attempts to apply a given patch to a Tree. If the apply fails, we return
-- Nothing, otherwise we return the updated Tree.
maybeApplyToTree
  :: (Apply p, ApplyState p ~ Tree, MonadCatch m)
  => p wX wY
  -> Tree m
  -> m (Maybe (Tree m))
maybeApplyToTree :: forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyState p ~ Tree, MonadCatch m) =>
p wX wY -> Tree m -> m (Maybe (Tree m))
maybeApplyToTree p wX wY
patch Tree m
tree =
  (Tree m -> Maybe (Tree m)
forall a. a -> Maybe a
Just (Tree m -> Maybe (Tree m)) -> m (Tree m) -> m (Maybe (Tree m))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` p wX wY -> Tree m -> m (Tree m)
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, MonadThrow m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree p wX wY
patch Tree m
tree) m (Maybe (Tree m))
-> (IOException -> m (Maybe (Tree m))) -> m (Maybe (Tree m))
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(IOException
_::IOException) -> Maybe (Tree m) -> m (Maybe (Tree m))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Tree m)
forall a. Maybe a
Nothing)