ApplyMonad.hs

{-# LANGUAGE TypeSynonymInstances #-}
-- 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(..), withFilePaths, withFiles ) where

import qualified Data.ByteString      as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map             as M
import qualified Storage.Hashed.Monad as HSM
import ByteStringUtils( linesPS, unlinesPS )
import Darcs.Patch.FileName( FileName, movedirfilename, fn2fp )
import Storage.Hashed.AnchoredPath( floatPath, AnchoredPath )
import Control.Monad.State.Strict
import Darcs.MonadProgress

fn2ap :: FileName -> AnchoredPath
fn2ap = floatPath . fn2fp

class (Functor m, Monad m) => ApplyMonad m where
    mDoesDirectoryExist :: FileName -> m Bool
    mReadFilePS :: FileName -> m B.ByteString
    mReadFilePSs :: FileName -> m [B.ByteString]
    mReadFilePSs f = linesPS `fmap` mReadFilePS f
    mCreateDirectory :: FileName -> m ()
    mRemoveDirectory :: FileName -> m ()
    mCreateFile :: FileName -> m ()
    mCreateFile f = mModifyFilePS f $ \_ -> return B.empty
    mRemoveFile :: FileName -> m ()
    mRename :: FileName -> FileName -> m ()
    mModifyFilePS :: FileName -> (B.ByteString -> m B.ByteString) -> m ()
    mModifyFilePSs :: FileName -> ([B.ByteString] -> m [B.ByteString]) -> m ()
    mModifyFilePSs f j = mModifyFilePS f (fmap unlinesPS . j . linesPS)
    mChangePref :: String -> String -> String -> m ()
    mChangePref _ _ _ = return ()

instance (Functor m, Monad m) => ApplyMonad (HSM.TreeMonad m) where
    mDoesDirectoryExist d = HSM.directoryExists (fn2ap d)
    mReadFilePS p = B.concat `fmap` BL.toChunks `fmap` HSM.readFile (fn2ap p)
    mModifyFilePS p j = do have <- HSM.fileExists (fn2ap p)
                           x <- if have then B.concat `fmap` BL.toChunks `fmap` HSM.readFile (fn2ap p)
                                        else return B.empty
                           HSM.writeFile (fn2ap p) . BL.fromChunks . (:[]) =<< j x
    mCreateDirectory p = HSM.createDirectory (fn2ap p)
    mRename from to = HSM.rename (fn2ap from) (fn2ap to)
    mRemoveDirectory = HSM.unlink . fn2ap
    mRemoveFile = HSM.unlink . fn2ap

type FilePathMonad = State [FileName]

withFilePaths :: [FileName] -> FilePathMonad a -> [FileName]
withFilePaths fps x = execState x fps

instance ApplyMonad FilePathMonad where
    -- We can't check it actually is a directory here
    mDoesDirectoryExist d = gets (d `elem`)
    mCreateDirectory _ = return ()
    mRemoveFile f = modify $ filter (/= f)
    mRemoveDirectory f = modify $ filter (/= f)
    mRename a b = modify $ map (movedirfilename a b)
    mModifyFilePS _ _ = return ()

instance MonadProgress FilePathMonad where
  runProgressActions = silentlyRunProgressActions

type RestrictedApply = State (M.Map FileName B.ByteString)

instance ApplyMonad RestrictedApply where
  mDoesDirectoryExist _ = return True
  mCreateDirectory _ = return ()
  mRemoveFile f = modify $ M.delete f
  mRemoveDirectory _ = return ()
  mRename a b = modify $ M.mapKeys (movedirfilename a b)
  mModifyFilePS f j = do look <- gets $ M.lookup f
                         case look of
                           Nothing -> return ()
                           Just bits -> do
                             new <- j bits
                             modify $ M.insert f new

instance MonadProgress RestrictedApply where
  runProgressActions = silentlyRunProgressActions

withFiles :: [(FileName, B.ByteString)] -> RestrictedApply a -> [(FileName, B.ByteString)]
withFiles p x = M.toList $ execState x $ M.fromList p