--  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.


{-# LANGUAGE MultiParamTypeClasses #-}


-- |
-- 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(..)
    , applyToFilePaths
    , applyToTree
    , applyToState
    , maybeApplyToTree
    , effectOnFilePaths
    ) where

import Prelude ()
import Darcs.Prelude

import Control.Exception ( catch, IOException )
import Control.Arrow ( (***) )

import Darcs.Util.Tree( Tree )

import Darcs.Patch.ApplyMonad ( ApplyMonad(..), withFileNames, ApplyMonadTrans(..) )
import Darcs.Util.Path( fn2fp, fp2fn )
import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) )

class Apply p where
    type ApplyState p :: (* -> *) -> *
    apply :: ApplyMonad (ApplyState p) m => p wX wY -> m ()

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

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


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


applyToFilePaths :: (Apply p, ApplyState p ~ Tree)
                 => p wX wY
                 -> Maybe [(FilePath, FilePath)]
                 -> [FilePath]
                 -> ([FilePath], [FilePath], [(FilePath, FilePath)])
applyToFilePaths :: p wX wY
-> Maybe [(FilePath, FilePath)]
-> [FilePath]
-> ([FilePath], [FilePath], [(FilePath, FilePath)])
applyToFilePaths pa :: p wX wY
pa ofpos :: Maybe [(FilePath, FilePath)]
ofpos fs :: [FilePath]
fs = ([FileName], [FileName], [(FileName, FileName)])
-> ([FilePath], [FilePath], [(FilePath, FilePath)])
toFPs (([FileName], [FileName], [(FileName, FileName)])
 -> ([FilePath], [FilePath], [(FilePath, FilePath)]))
-> ([FileName], [FileName], [(FileName, FileName)])
-> ([FilePath], [FilePath], [(FilePath, FilePath)])
forall a b. (a -> b) -> a -> b
$ Maybe [(FileName, FileName)]
-> [FileName]
-> FilePathMonad ()
-> ([FileName], [FileName], [(FileName, FileName)])
forall a.
Maybe [(FileName, FileName)]
-> [FileName]
-> FilePathMonad a
-> ([FileName], [FileName], [(FileName, FileName)])
withFileNames Maybe [(FileName, FileName)]
ofnos [FileName]
fns (p wX wY -> FilePathMonad ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wX wY
pa) where
        fns :: [FileName]
fns = (FilePath -> FileName) -> [FilePath] -> [FileName]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FileName
fp2fn [FilePath]
fs
        ofnos :: Maybe [(FileName, FileName)]
ofnos = ((FilePath, FilePath) -> (FileName, FileName))
-> [(FilePath, FilePath)] -> [(FileName, FileName)]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FileName
fp2fn (FilePath -> FileName)
-> (FilePath -> FileName)
-> (FilePath, FilePath)
-> (FileName, FileName)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** FilePath -> FileName
fp2fn) ([(FilePath, FilePath)] -> [(FileName, FileName)])
-> Maybe [(FilePath, FilePath)] -> Maybe [(FileName, FileName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [(FilePath, FilePath)]
ofpos
        toFPs :: ([FileName], [FileName], [(FileName, FileName)])
-> ([FilePath], [FilePath], [(FilePath, FilePath)])
toFPs (affected :: [FileName]
affected, new :: [FileName]
new, renames :: [(FileName, FileName)]
renames) =
            ((FileName -> FilePath) -> [FileName] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FileName -> FilePath
fn2fp [FileName]
affected, (FileName -> FilePath) -> [FileName] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FileName -> FilePath
fn2fp [FileName]
new, ((FileName, FileName) -> (FilePath, FilePath))
-> [(FileName, FileName)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (FileName -> FilePath
fn2fp (FileName -> FilePath)
-> (FileName -> FilePath)
-> (FileName, FileName)
-> (FilePath, FilePath)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** FileName -> FilePath
fn2fp) [(FileName, FileName)]
renames)


-- | Apply a patch to a 'Tree', yielding a new 'Tree'.
applyToTree :: (Apply p, Monad m, ApplyState p ~ Tree)
            => p wX wY
            -> Tree m
            -> m (Tree m)
applyToTree :: p wX wY -> Tree m -> m (Tree m)
applyToTree = p wX wY -> Tree m -> m (Tree 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 :: p wX wY -> ApplyState p m -> m (ApplyState p m)
applyToState patch :: p wX wY
patch t :: 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 (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 (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 replace patch to a Tree. If the apply fails (if
-- the file the patch applies to already contains the target token), we return
-- Nothing, otherwise we return the updated Tree.
maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Tree IO
                 -> IO (Maybe (Tree IO))
maybeApplyToTree :: p wX wY -> Tree IO -> IO (Maybe (Tree IO))
maybeApplyToTree patch :: p wX wY
patch tree :: Tree IO
tree =
    (Tree IO -> Maybe (Tree IO)
forall a. a -> Maybe a
Just (Tree IO -> Maybe (Tree IO))
-> IO (Tree IO) -> IO (Maybe (Tree IO))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` p wX wY -> Tree IO -> IO (Tree IO)
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, Monad m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree p wX wY
patch Tree IO
tree) IO (Maybe (Tree IO))
-> (IOException -> IO (Maybe (Tree IO))) -> IO (Maybe (Tree IO))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOException
_ :: IOException) -> Maybe (Tree IO) -> IO (Maybe (Tree IO))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Tree IO)
forall a. Maybe a
Nothing)