{-# LANGUAGE MultiParamTypeClasses #-}
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 NilFL = return ()
apply (p:>:ps) = apply p >> apply ps
instance Apply p => Apply (RL p) where
type ApplyState (RL p) = ApplyState p
apply NilRL = return ()
apply (p:<:ps) = apply ps >> apply p
effectOnFilePaths :: (Apply p, ApplyState p ~ Tree)
=> p wX wY
-> [FilePath]
-> [FilePath]
effectOnFilePaths p fps = fps' where
(_, fps', _) = applyToFilePaths p Nothing fps
applyToFilePaths :: (Apply p, ApplyState p ~ Tree)
=> p wX wY
-> Maybe [(FilePath, FilePath)]
-> [FilePath]
-> ([FilePath], [FilePath], [(FilePath, FilePath)])
applyToFilePaths pa ofpos fs = toFPs $ withFileNames ofnos fns (apply pa) where
fns = map fp2fn fs
ofnos = map (fp2fn *** fp2fn) <$> ofpos
toFPs (affected, new, renames) =
(map fn2fp affected, map fn2fp new, map (fn2fp *** fn2fp) renames)
applyToTree :: (Apply p, Monad m, ApplyState p ~ Tree)
=> p wX wY
-> Tree m
-> m (Tree m)
applyToTree = applyToState
applyToState :: forall p m wX wY. (Apply p, ApplyMonadTrans (ApplyState p) m)
=> p wX wY
-> (ApplyState p) m
-> m ((ApplyState p) m)
applyToState patch t = snd <$> runApplyMonad (apply patch) t
maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Tree IO
-> IO (Maybe (Tree IO))
maybeApplyToTree patch tree =
(Just `fmap` applyToTree patch tree) `catch` (\(_ :: IOException) -> return Nothing)