{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances, UndecidableSuperClasses #-}
module Darcs.Patch.ApplyMonad
( ApplyMonad(..), ApplyMonadTrans(..), ApplyMonadState(..)
, withFileNames, withFiles, ToTree(..)
, ApplyMonadTree(..)
) where
import Darcs.Prelude
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import qualified Darcs.Util.Tree.Monad as TM
import Darcs.Util.Tree ( Tree )
import Data.Maybe ( fromMaybe )
import Darcs.Util.Path ( AnchoredPath, movedirfilename, isPrefix )
import Control.Monad.State.Strict
import Control.Monad.Identity( Identity )
import Darcs.Patch.MonadProgress
import GHC.Exts ( Constraint )
class ToTree s where
toTree :: s m -> Tree m
instance ToTree Tree where
toTree :: forall (m :: * -> *). Tree m -> Tree m
toTree = forall a. a -> a
id
class (Monad m, ApplyMonad state (ApplyMonadOver state m))
=> ApplyMonadTrans (state :: (* -> *) -> *) m where
type ApplyMonadOver state m :: * -> *
runApplyMonad :: (ApplyMonadOver state m) x -> state m -> m (x, state m)
instance Monad m => ApplyMonadTrans Tree m where
type ApplyMonadOver Tree m = TM.TreeMonad m
runApplyMonad :: forall x. ApplyMonadOver Tree m x -> Tree m -> m (x, Tree m)
runApplyMonad = forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> Tree m -> m (a, Tree m)
TM.virtualTreeMonad
class ApplyMonadState (state :: (* -> *) -> *) where
type ApplyMonadStateOperations state :: (* -> *) -> Constraint
class Monad m => ApplyMonadTree m where
mDoesDirectoryExist :: AnchoredPath -> m Bool
mDoesFileExist :: AnchoredPath -> m Bool
mReadFilePS :: AnchoredPath -> m B.ByteString
mCreateDirectory :: AnchoredPath -> m ()
mRemoveDirectory :: AnchoredPath -> m ()
mCreateFile :: AnchoredPath -> m ()
mCreateFile AnchoredPath
f = forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> (ByteString -> m ByteString) -> m ()
mModifyFilePS AnchoredPath
f forall a b. (a -> b) -> a -> b
$ \ByteString
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
mRemoveFile :: AnchoredPath -> m ()
mRename :: AnchoredPath -> AnchoredPath -> m ()
mModifyFilePS :: AnchoredPath -> (B.ByteString -> m B.ByteString) -> m ()
mChangePref :: String -> String -> String -> m ()
mChangePref String
_ String
_ String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
instance ApplyMonadState Tree where
type ApplyMonadStateOperations Tree = ApplyMonadTree
class ( Monad m, Monad (ApplyMonadBase m)
, ApplyMonadStateOperations state m, ToTree state
)
=> ApplyMonad (state :: (* -> *) -> *) m where
type ApplyMonadBase m :: * -> *
nestedApply :: m x -> state (ApplyMonadBase m) -> m (x, state (ApplyMonadBase m))
liftApply :: (state (ApplyMonadBase m) -> (ApplyMonadBase m) x) -> state (ApplyMonadBase m)
-> m (x, state (ApplyMonadBase m))
getApplyState :: m (state (ApplyMonadBase m))
instance Monad m => ApplyMonad Tree (TM.TreeMonad m) where
type ApplyMonadBase (TM.TreeMonad m) = m
getApplyState :: TreeMonad m (Tree (ApplyMonadBase (TreeMonad m)))
getApplyState = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall (m :: * -> *). TreeState m -> Tree m
TM.tree
nestedApply :: forall x.
TreeMonad m x
-> Tree (ApplyMonadBase (TreeMonad m))
-> TreeMonad m (x, Tree (ApplyMonadBase (TreeMonad m)))
nestedApply TreeMonad m x
a Tree (ApplyMonadBase (TreeMonad m))
start = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (state :: (* -> *) -> *) (m :: * -> *) x.
ApplyMonadTrans state m =>
ApplyMonadOver state m x -> state m -> m (x, state m)
runApplyMonad TreeMonad m x
a Tree (ApplyMonadBase (TreeMonad m))
start
liftApply :: forall x.
(Tree (ApplyMonadBase (TreeMonad m))
-> ApplyMonadBase (TreeMonad m) x)
-> Tree (ApplyMonadBase (TreeMonad m))
-> TreeMonad m (x, Tree (ApplyMonadBase (TreeMonad m)))
liftApply Tree (ApplyMonadBase (TreeMonad m))
-> ApplyMonadBase (TreeMonad m) x
a Tree (ApplyMonadBase (TreeMonad m))
start = do Tree m
x <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall (m :: * -> *). TreeState m -> Tree m
TM.tree
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (state :: (* -> *) -> *) (m :: * -> *) x.
ApplyMonadTrans state m =>
ApplyMonadOver state m x -> state m -> m (x, state m)
runApplyMonad (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Tree (ApplyMonadBase (TreeMonad m))
-> ApplyMonadBase (TreeMonad m) x
a Tree m
x) Tree (ApplyMonadBase (TreeMonad m))
start
instance Monad m => ApplyMonadTree (TM.TreeMonad m) where
mDoesDirectoryExist :: AnchoredPath -> TreeMonad m Bool
mDoesDirectoryExist AnchoredPath
p = forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
TM.directoryExists AnchoredPath
p
mDoesFileExist :: AnchoredPath -> TreeMonad m Bool
mDoesFileExist AnchoredPath
p = forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
TM.fileExists AnchoredPath
p
mReadFilePS :: AnchoredPath -> TreeMonad m ByteString
mReadFilePS AnchoredPath
p = [ByteString] -> ByteString
B.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ByteString -> [ByteString]
BL.toChunks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m ByteString
TM.readFile AnchoredPath
p
mModifyFilePS :: AnchoredPath
-> (ByteString -> TreeMonad m ByteString) -> TreeMonad m ()
mModifyFilePS AnchoredPath
p ByteString -> TreeMonad m ByteString
j = do Bool
have <- forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
TM.fileExists AnchoredPath
p
ByteString
x <- if Bool
have then [ByteString] -> ByteString
B.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ByteString -> [ByteString]
BL.toChunks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m ByteString
TM.readFile AnchoredPath
p
else forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
forall (m :: * -> *).
Monad m =>
AnchoredPath -> ByteString -> TreeMonad m ()
TM.writeFile AnchoredPath
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
BL.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> TreeMonad m ByteString
j ByteString
x
mCreateDirectory :: AnchoredPath -> TreeMonad m ()
mCreateDirectory AnchoredPath
p = forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.createDirectory AnchoredPath
p
mRename :: AnchoredPath -> AnchoredPath -> TreeMonad m ()
mRename AnchoredPath
from AnchoredPath
to = forall (m :: * -> *).
Monad m =>
AnchoredPath -> AnchoredPath -> TreeMonad m ()
TM.rename AnchoredPath
from AnchoredPath
to
mRemoveDirectory :: AnchoredPath -> TreeMonad m ()
mRemoveDirectory = forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.unlink
mRemoveFile :: AnchoredPath -> TreeMonad m ()
mRemoveFile = forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.unlink
type OrigFileNameOf = (AnchoredPath, AnchoredPath)
type FilePathMonadState = ([AnchoredPath], [AnchoredPath], [OrigFileNameOf])
type FilePathMonad = State FilePathMonadState
trackOrigRename :: AnchoredPath -> AnchoredPath -> OrigFileNameOf -> OrigFileNameOf
trackOrigRename :: AnchoredPath -> AnchoredPath -> OrigFileNameOf -> OrigFileNameOf
trackOrigRename AnchoredPath
old AnchoredPath
new pair :: OrigFileNameOf
pair@(AnchoredPath
latest, AnchoredPath
from)
| AnchoredPath
old AnchoredPath -> AnchoredPath -> Bool
`isPrefix` AnchoredPath
latest = (AnchoredPath
latest, AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath
movedirfilename AnchoredPath
old AnchoredPath
new AnchoredPath
latest)
| AnchoredPath
old AnchoredPath -> AnchoredPath -> Bool
`isPrefix` AnchoredPath
from = (AnchoredPath
latest, AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath
movedirfilename AnchoredPath
old AnchoredPath
new AnchoredPath
from)
| Bool
otherwise = OrigFileNameOf
pair
withFileNames :: Maybe [OrigFileNameOf] -> [AnchoredPath] -> FilePathMonad a
-> FilePathMonadState
withFileNames :: forall a.
Maybe [OrigFileNameOf]
-> [AnchoredPath] -> FilePathMonad a -> FilePathMonadState
withFileNames Maybe [OrigFileNameOf]
mbofnos [AnchoredPath]
fps FilePathMonad a
x = forall s a. State s a -> s -> s
execState FilePathMonad a
x ([], [AnchoredPath]
fps, [OrigFileNameOf]
ofnos) where
ofnos :: [OrigFileNameOf]
ofnos = forall a. a -> Maybe a -> a
fromMaybe (forall a b. (a -> b) -> [a] -> [b]
map (\AnchoredPath
y -> (AnchoredPath
y, AnchoredPath
y)) [AnchoredPath]
fps) Maybe [OrigFileNameOf]
mbofnos
instance ApplyMonad Tree FilePathMonad where
type ApplyMonadBase FilePathMonad = Identity
instance ApplyMonadTree FilePathMonad where
mDoesDirectoryExist :: AnchoredPath -> FilePathMonad Bool
mDoesDirectoryExist AnchoredPath
p = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ \([AnchoredPath]
_, [AnchoredPath]
fs, [OrigFileNameOf]
_) -> AnchoredPath
p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AnchoredPath]
fs
mCreateDirectory :: AnchoredPath -> FilePathMonad ()
mCreateDirectory = forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mCreateFile
mCreateFile :: AnchoredPath -> FilePathMonad ()
mCreateFile AnchoredPath
f = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \([AnchoredPath]
ms, [AnchoredPath]
fs, [OrigFileNameOf]
rns) -> (AnchoredPath
f forall a. a -> [a] -> [a]
: [AnchoredPath]
ms, [AnchoredPath]
fs, [OrigFileNameOf]
rns)
mRemoveFile :: AnchoredPath -> FilePathMonad ()
mRemoveFile AnchoredPath
f = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \([AnchoredPath]
ms, [AnchoredPath]
fs, [OrigFileNameOf]
rns) -> (AnchoredPath
f forall a. a -> [a] -> [a]
: [AnchoredPath]
ms, forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= AnchoredPath
f) [AnchoredPath]
fs, [OrigFileNameOf]
rns)
mRemoveDirectory :: AnchoredPath -> FilePathMonad ()
mRemoveDirectory = forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mRemoveFile
mRename :: AnchoredPath -> AnchoredPath -> FilePathMonad ()
mRename AnchoredPath
a AnchoredPath
b =
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \([AnchoredPath]
ms, [AnchoredPath]
fs, [OrigFileNameOf]
rns) -> ( AnchoredPath
a forall a. a -> [a] -> [a]
: AnchoredPath
b forall a. a -> [a] -> [a]
: [AnchoredPath]
ms
, forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath
movedirfilename AnchoredPath
a AnchoredPath
b) [AnchoredPath]
fs
, forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath -> AnchoredPath -> OrigFileNameOf -> OrigFileNameOf
trackOrigRename AnchoredPath
a AnchoredPath
b) [OrigFileNameOf]
rns)
mModifyFilePS :: AnchoredPath
-> (ByteString -> FilePathMonad ByteString) -> FilePathMonad ()
mModifyFilePS AnchoredPath
f ByteString -> FilePathMonad ByteString
_ = forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mCreateFile AnchoredPath
f
instance MonadProgress FilePathMonad where
runProgressActions :: String -> [ProgressAction FilePathMonad ()] -> FilePathMonad ()
runProgressActions = forall (m :: * -> *).
Monad m =>
String -> [ProgressAction m ()] -> m ()
silentlyRunProgressActions
type RestrictedApply = State (M.Map AnchoredPath B.ByteString)
instance ApplyMonad Tree RestrictedApply where
type ApplyMonadBase RestrictedApply = Identity
instance ApplyMonadTree RestrictedApply where
mDoesDirectoryExist :: AnchoredPath -> RestrictedApply Bool
mDoesDirectoryExist AnchoredPath
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
mCreateDirectory :: AnchoredPath -> RestrictedApply ()
mCreateDirectory AnchoredPath
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
mRemoveFile :: AnchoredPath -> RestrictedApply ()
mRemoveFile AnchoredPath
f = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
M.delete AnchoredPath
f
mRemoveDirectory :: AnchoredPath -> RestrictedApply ()
mRemoveDirectory AnchoredPath
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
mRename :: AnchoredPath -> AnchoredPath -> RestrictedApply ()
mRename AnchoredPath
a AnchoredPath
b = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath
movedirfilename AnchoredPath
a AnchoredPath
b)
mModifyFilePS :: AnchoredPath
-> (ByteString -> RestrictedApply ByteString) -> RestrictedApply ()
mModifyFilePS AnchoredPath
f ByteString -> RestrictedApply ByteString
j = do Maybe ByteString
look <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AnchoredPath
f
case Maybe ByteString
look of
Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
bits -> do
ByteString
new <- ByteString -> RestrictedApply ByteString
j ByteString
bits
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AnchoredPath
f ByteString
new
instance MonadProgress RestrictedApply where
runProgressActions :: String -> [ProgressAction RestrictedApply ()] -> RestrictedApply ()
runProgressActions = forall (m :: * -> *).
Monad m =>
String -> [ProgressAction m ()] -> m ()
silentlyRunProgressActions
withFiles :: [(AnchoredPath, B.ByteString)] -> RestrictedApply a -> [(AnchoredPath, B.ByteString)]
withFiles :: forall a.
[(AnchoredPath, ByteString)]
-> RestrictedApply a -> [(AnchoredPath, ByteString)]
withFiles [(AnchoredPath, ByteString)]
p RestrictedApply a
x = forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> s
execState RestrictedApply a
x forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(AnchoredPath, ByteString)]
p