{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
-- Copyright (C) 2010, 2011 Petr Rockai
--
-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use, copy,
-- modify, merge, publish, distribute, sublicense, and/or sell copies
-- of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:
--
-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-- SOFTWARE.
module Darcs.Patch.ApplyMonad
  ( ApplyMonad(..), ApplyMonadTrans(..), ApplyMonadOperations
  , withFileNames
  , ApplyMonadTree(..)
  , evalApplyMonad
  ) where

import Darcs.Prelude

import qualified Data.ByteString      as B
import qualified Data.ByteString.Lazy as BL
import qualified Darcs.Util.Tree.Monad as TM
import Darcs.Patch.Object ( ObjectIdOf )
import Darcs.Util.StrictIdentity (StrictIdentity(..) )
import Darcs.Util.Tree ( Tree )
import Data.Maybe ( fromMaybe )
import Darcs.Util.Path ( AnchoredPath, movedirfilename, isPrefix )
import Control.Monad.Catch ( MonadThrow(..) )
import Control.Monad.State.Strict

import GHC.Exts ( Constraint )

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 MonadThrow 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 = TreeMonad m x -> Tree m -> m (x, Tree m)
ApplyMonadOver Tree m x -> Tree m -> m (x, Tree m)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> Tree m -> m (a, Tree m)
TM.virtualTreeMonad

evalApplyMonad
  :: ApplyMonadTrans state m => ApplyMonadOver state m a -> state m -> m a
evalApplyMonad :: forall (state :: (* -> *) -> *) (m :: * -> *) a.
ApplyMonadTrans state m =>
ApplyMonadOver state m a -> state m -> m a
evalApplyMonad ApplyMonadOver state m a
action state m
st = (a, state m) -> a
forall a b. (a, b) -> a
fst ((a, state m) -> a) -> m (a, state m) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ApplyMonadOver state m a -> state m -> m (a, state m)
forall x. ApplyMonadOver state m x -> state m -> m (x, state m)
forall (state :: (* -> *) -> *) (m :: * -> *) x.
ApplyMonadTrans state m =>
ApplyMonadOver state m x -> state m -> m (x, state m)
runApplyMonad ApplyMonadOver state m a
action state m
st

type family ApplyMonadOperations (state :: (* -> *) -> *) :: (* -> *) -> Constraint

class MonadThrow m => ApplyMonadTree m where
    -- a semantic, Tree-based interface for patch application
    mDoesDirectoryExist ::  AnchoredPath -> m Bool
    mDoesFileExist ::  AnchoredPath -> m Bool
    mReadFilePS ::  AnchoredPath -> m B.ByteString
    mCreateDirectory ::  AnchoredPath -> m ()
    mRemoveDirectory ::  AnchoredPath -> m ()
    mCreateFile ::  AnchoredPath -> m ()
    mRemoveFile ::  AnchoredPath -> m ()
    mRename ::  AnchoredPath -> AnchoredPath -> m ()
    mModifyFilePS ::  AnchoredPath -> (B.ByteString -> m B.ByteString) -> m ()
    mChangePref ::  String -> String -> String -> m ()
    mChangePref String
_ String
_ String
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

type instance ApplyMonadOperations Tree = ApplyMonadTree

class ( Monad m
      , ApplyMonadOperations state m
      )
      => ApplyMonad (state :: (* -> *) -> *) m | m -> state where

    readFilePS :: ObjectIdOf state -> m B.ByteString

instance MonadThrow m => ApplyMonad Tree (TM.TreeMonad m) where
    readFilePS :: ObjectIdOf Tree -> TreeMonad m ByteString
readFilePS ObjectIdOf Tree
path = AnchoredPath -> TreeMonad m ByteString
forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> m ByteString
mReadFilePS AnchoredPath
ObjectIdOf Tree
path

instance MonadThrow m => ApplyMonadTree (TM.TreeMonad m) where
    mDoesDirectoryExist :: AnchoredPath -> TreeMonad m Bool
mDoesDirectoryExist AnchoredPath
p = AnchoredPath -> TreeMonad m Bool
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
TM.directoryExists AnchoredPath
p
    mDoesFileExist :: AnchoredPath -> TreeMonad m Bool
mDoesFileExist AnchoredPath
p = AnchoredPath -> TreeMonad m Bool
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
TM.fileExists AnchoredPath
p
    mReadFilePS :: AnchoredPath -> TreeMonad m ByteString
mReadFilePS AnchoredPath
p = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> RWST (DumpItem m) () (TreeState m) m ByteString
-> TreeMonad m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredPath -> RWST (DumpItem m) () (TreeState m) m ByteString
forall (m :: * -> *).
MonadThrow 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 =
      AnchoredPath -> ByteString -> TreeMonad m ()
forall (m :: * -> *).
MonadThrow m =>
AnchoredPath -> ByteString -> TreeMonad m ()
TM.writeFile AnchoredPath
p (ByteString -> TreeMonad m ())
-> (ByteString -> ByteString) -> ByteString -> TreeMonad m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> TreeMonad m ())
-> TreeMonad m ByteString -> TreeMonad m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> TreeMonad m ByteString
j (ByteString -> TreeMonad m ByteString)
-> (ByteString -> ByteString)
-> ByteString
-> TreeMonad m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> TreeMonad m ByteString)
-> RWST (DumpItem m) () (TreeState m) m ByteString
-> TreeMonad m ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AnchoredPath -> RWST (DumpItem m) () (TreeState m) m ByteString
forall (m :: * -> *).
MonadThrow m =>
AnchoredPath -> TreeMonad m ByteString
TM.readFile AnchoredPath
p
    mCreateFile :: AnchoredPath -> TreeMonad m ()
mCreateFile AnchoredPath
p = AnchoredPath -> ByteString -> TreeMonad m ()
forall (m :: * -> *).
MonadThrow m =>
AnchoredPath -> ByteString -> TreeMonad m ()
TM.writeFile AnchoredPath
p ByteString
BL.empty
    mCreateDirectory :: AnchoredPath -> TreeMonad m ()
mCreateDirectory AnchoredPath
p = AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.createDirectory AnchoredPath
p
    mRename :: AnchoredPath -> AnchoredPath -> TreeMonad m ()
mRename AnchoredPath
from AnchoredPath
to = AnchoredPath -> AnchoredPath -> TreeMonad m ()
forall (m :: * -> *).
MonadThrow m =>
AnchoredPath -> AnchoredPath -> TreeMonad m ()
TM.rename AnchoredPath
from AnchoredPath
to
    mRemoveDirectory :: AnchoredPath -> TreeMonad m ()
mRemoveDirectory = AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.unlink
    mRemoveFile :: AnchoredPath -> TreeMonad m ()
mRemoveFile = AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.unlink

-- Latest name, current original name.
type OrigFileNameOf = (AnchoredPath, AnchoredPath)
-- Touched files, new file list (after removes etc.) and rename details
type FilePathMonadState = ([AnchoredPath], [AnchoredPath], [OrigFileNameOf])
type FilePathMonad = StateT FilePathMonadState Pure

newtype Pure a = Pure (StrictIdentity a)
  deriving ((forall a b. (a -> b) -> Pure a -> Pure b)
-> (forall a b. a -> Pure b -> Pure a) -> Functor Pure
forall a b. a -> Pure b -> Pure a
forall a b. (a -> b) -> Pure a -> Pure b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Pure a -> Pure b
fmap :: forall a b. (a -> b) -> Pure a -> Pure b
$c<$ :: forall a b. a -> Pure b -> Pure a
<$ :: forall a b. a -> Pure b -> Pure a
Functor, Functor Pure
Functor Pure =>
(forall a. a -> Pure a)
-> (forall a b. Pure (a -> b) -> Pure a -> Pure b)
-> (forall a b c. (a -> b -> c) -> Pure a -> Pure b -> Pure c)
-> (forall a b. Pure a -> Pure b -> Pure b)
-> (forall a b. Pure a -> Pure b -> Pure a)
-> Applicative Pure
forall a. a -> Pure a
forall a b. Pure a -> Pure b -> Pure a
forall a b. Pure a -> Pure b -> Pure b
forall a b. Pure (a -> b) -> Pure a -> Pure b
forall a b c. (a -> b -> c) -> Pure a -> Pure b -> Pure c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Pure a
pure :: forall a. a -> Pure a
$c<*> :: forall a b. Pure (a -> b) -> Pure a -> Pure b
<*> :: forall a b. Pure (a -> b) -> Pure a -> Pure b
$cliftA2 :: forall a b c. (a -> b -> c) -> Pure a -> Pure b -> Pure c
liftA2 :: forall a b c. (a -> b -> c) -> Pure a -> Pure b -> Pure c
$c*> :: forall a b. Pure a -> Pure b -> Pure b
*> :: forall a b. Pure a -> Pure b -> Pure b
$c<* :: forall a b. Pure a -> Pure b -> Pure a
<* :: forall a b. Pure a -> Pure b -> Pure a
Applicative, Applicative Pure
Applicative Pure =>
(forall a b. Pure a -> (a -> Pure b) -> Pure b)
-> (forall a b. Pure a -> Pure b -> Pure b)
-> (forall a. a -> Pure a)
-> Monad Pure
forall a. a -> Pure a
forall a b. Pure a -> Pure b -> Pure b
forall a b. Pure a -> (a -> Pure b) -> Pure b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Pure a -> (a -> Pure b) -> Pure b
>>= :: forall a b. Pure a -> (a -> Pure b) -> Pure b
$c>> :: forall a b. Pure a -> Pure b -> Pure b
>> :: forall a b. Pure a -> Pure b -> Pure b
$creturn :: forall a. a -> Pure a
return :: forall a. a -> Pure a
Monad)

runPure :: Pure a -> a
runPure :: forall a. Pure a -> a
runPure (Pure (StrictIdentity a
x)) = a
x

-- With "Data.Functor.Identity" this instance would not satisfy the law
-- @throwM e >> x = throwM e@, which is why we use 'StrictIdentity'.
instance MonadThrow Pure where
  throwM :: forall e a. (HasCallStack, Exception e) => e -> Pure a
throwM e
e = StrictIdentity a -> Pure a
forall a. StrictIdentity a -> Pure a
Pure (String -> StrictIdentity a
forall a. HasCallStack => String -> a
error (e -> String
forall a. Show a => a -> String
show e
e))

-- |trackOrigRename takes an old and new name and attempts to apply the mapping
-- to the OrigFileNameOf pair. If the old name is the most up-to-date name of
-- the file in question, the first element of the OFNO will match, otherwise if
-- the up-to-date name was originally old, the second element will match.
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 takes a maybe list of existing rename-pairs, a list of
-- filenames and an action, and returns the resulting triple of affected files,
-- updated filename list and new rename details. If the rename-pairs are not
-- present, a new list is generated from the filesnames.
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 = Pure FilePathMonadState -> FilePathMonadState
forall a. Pure a -> a
runPure (Pure FilePathMonadState -> FilePathMonadState)
-> Pure FilePathMonadState -> FilePathMonadState
forall a b. (a -> b) -> a -> b
$ FilePathMonad a -> FilePathMonadState -> Pure FilePathMonadState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT FilePathMonad a
x ([], [AnchoredPath]
fps, [OrigFileNameOf]
ofnos)
  where
    ofnos :: [OrigFileNameOf]
ofnos = [OrigFileNameOf] -> Maybe [OrigFileNameOf] -> [OrigFileNameOf]
forall a. a -> Maybe a -> a
fromMaybe ((AnchoredPath -> OrigFileNameOf)
-> [AnchoredPath] -> [OrigFileNameOf]
forall a b. (a -> b) -> [a] -> [b]
map (\AnchoredPath
y -> (AnchoredPath
y, AnchoredPath
y)) [AnchoredPath]
fps) Maybe [OrigFileNameOf]
mbofnos

instance ApplyMonad Tree FilePathMonad where
    readFilePS :: ObjectIdOf Tree -> FilePathMonad ByteString
readFilePS = String -> AnchoredPath -> FilePathMonad ByteString
forall a. HasCallStack => String -> a
error String
"readFilePS not defined for FilePathMonad"

instance ApplyMonadTree FilePathMonad where
    -- We can't check it actually is a directory here
    mDoesDirectoryExist :: AnchoredPath -> FilePathMonad Bool
mDoesDirectoryExist AnchoredPath
p = (FilePathMonadState -> Bool) -> FilePathMonad Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((FilePathMonadState -> Bool) -> FilePathMonad Bool)
-> (FilePathMonadState -> Bool) -> FilePathMonad Bool
forall a b. (a -> b) -> a -> b
$ \([AnchoredPath]
_, [AnchoredPath]
fs, [OrigFileNameOf]
_) -> AnchoredPath
p AnchoredPath -> [AnchoredPath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AnchoredPath]
fs
    mDoesFileExist :: AnchoredPath -> FilePathMonad Bool
mDoesFileExist = AnchoredPath -> FilePathMonad Bool
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m Bool
mDoesDirectoryExist
    mCreateDirectory :: AnchoredPath -> FilePathMonad ()
mCreateDirectory = AnchoredPath -> FilePathMonad ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mCreateFile
    mCreateFile :: AnchoredPath -> FilePathMonad ()
mCreateFile AnchoredPath
f = (FilePathMonadState -> FilePathMonadState) -> FilePathMonad ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FilePathMonadState -> FilePathMonadState) -> FilePathMonad ())
-> (FilePathMonadState -> FilePathMonadState) -> FilePathMonad ()
forall a b. (a -> b) -> a -> b
$ \([AnchoredPath]
ms, [AnchoredPath]
fs, [OrigFileNameOf]
rns) -> (AnchoredPath
f AnchoredPath -> [AnchoredPath] -> [AnchoredPath]
forall a. a -> [a] -> [a]
: [AnchoredPath]
ms, [AnchoredPath]
fs, [OrigFileNameOf]
rns)
    mRemoveFile :: AnchoredPath -> FilePathMonad ()
mRemoveFile AnchoredPath
f = (FilePathMonadState -> FilePathMonadState) -> FilePathMonad ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FilePathMonadState -> FilePathMonadState) -> FilePathMonad ())
-> (FilePathMonadState -> FilePathMonadState) -> FilePathMonad ()
forall a b. (a -> b) -> a -> b
$ \([AnchoredPath]
ms, [AnchoredPath]
fs, [OrigFileNameOf]
rns) -> (AnchoredPath
f AnchoredPath -> [AnchoredPath] -> [AnchoredPath]
forall a. a -> [a] -> [a]
: [AnchoredPath]
ms, (AnchoredPath -> Bool) -> [AnchoredPath] -> [AnchoredPath]
forall a. (a -> Bool) -> [a] -> [a]
filter (AnchoredPath -> AnchoredPath -> Bool
forall a. Eq a => a -> a -> Bool
/= AnchoredPath
f) [AnchoredPath]
fs, [OrigFileNameOf]
rns)
    mRemoveDirectory :: AnchoredPath -> FilePathMonad ()
mRemoveDirectory = AnchoredPath -> FilePathMonad ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mRemoveFile
    mRename :: AnchoredPath -> AnchoredPath -> FilePathMonad ()
mRename AnchoredPath
a AnchoredPath
b =
        (FilePathMonadState -> FilePathMonadState) -> FilePathMonad ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FilePathMonadState -> FilePathMonadState) -> FilePathMonad ())
-> (FilePathMonadState -> FilePathMonadState) -> FilePathMonad ()
forall a b. (a -> b) -> a -> b
$ \([AnchoredPath]
ms, [AnchoredPath]
fs, [OrigFileNameOf]
rns) -> ( AnchoredPath
a AnchoredPath -> [AnchoredPath] -> [AnchoredPath]
forall a. a -> [a] -> [a]
: AnchoredPath
b AnchoredPath -> [AnchoredPath] -> [AnchoredPath]
forall a. a -> [a] -> [a]
: [AnchoredPath]
ms
                                   , (AnchoredPath -> AnchoredPath) -> [AnchoredPath] -> [AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath
movedirfilename AnchoredPath
a AnchoredPath
b) [AnchoredPath]
fs
                                   , (OrigFileNameOf -> OrigFileNameOf)
-> [OrigFileNameOf] -> [OrigFileNameOf]
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
_ = AnchoredPath -> FilePathMonad ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mCreateFile AnchoredPath
f
    mReadFilePS :: AnchoredPath -> FilePathMonad ByteString
mReadFilePS = String -> AnchoredPath -> FilePathMonad ByteString
forall a. HasCallStack => String -> a
error String
"mReadFilePS not defined for FilePathMonad"