diff --git a/HsSVN.cabal b/HsSVN.cabal --- a/HsSVN.cabal +++ b/HsSVN.cabal @@ -4,7 +4,7 @@ HsSVN is a (part of) Subversion binding for Haskell. Currently it can do most things related to the Subversion FS but others are left uncovered. -Version: 0.4.1 +Version: 0.4.2 License: PublicDomain License-File: COPYING Author: PHO @@ -30,7 +30,7 @@ Library Build-Depends: - base >= 4, bytestring, mtl, stm + base >= 4 && < 5, bytestring, mtl, stm Exposed-Modules: Subversion Subversion.Config diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,8 @@ +Changes from 0.4.1 to 0.4.2 +--------------------------- +* Fixed breakage on GHC 6.12.1. + + Changes from 0.4 to 0.4.1 ------------------------- * Fixed incorrect dependency declaration in HsSVN.cabal. No semantical diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,4 @@ #!/usr/bin/env runghc import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main = defaultMainWithHooks autoconfUserHooks diff --git a/Subversion/Error.hsc b/Subversion/Error.hsc --- a/Subversion/Error.hsc +++ b/Subversion/Error.hsc @@ -80,7 +80,7 @@ | errPtr == nullPtr = return Nothing | otherwise - = newForeignPtr _clear errPtr >>= return . Just . SvnError + = fmap (Just . SvnError) (newForeignPtr _clear errPtr) svnErr :: IO (Ptr SVN_ERROR_T) -> IO () diff --git a/Subversion/FileSystem.hsc b/Subversion/FileSystem.hsc --- a/Subversion/FileSystem.hsc +++ b/Subversion/FileSystem.hsc @@ -36,7 +36,6 @@ ) where -import Control.Monad import Foreign.C.String import Foreign.ForeignPtr import Foreign.Ptr @@ -100,17 +99,17 @@ -- |@'fsConfigFSType'@ is a config key to specify the filesystem -- back-end. fsConfigFSType :: String -fsConfigFSType = (#const_str SVN_FS_CONFIG_FS_TYPE) +fsConfigFSType = #const_str SVN_FS_CONFIG_FS_TYPE -- |@'fsTypeBDB'@ is a config value representing the Berkeley-DB -- back-end. fsTypeBDB :: String -fsTypeBDB = (#const_str SVN_FS_TYPE_BDB) +fsTypeBDB = #const_str SVN_FS_TYPE_BDB -- |@'fsTypeFSFS'@ is a config value representing the -- Native-filesystem back-end. fsTypeFSFS :: String -fsTypeFSFS = (#const_str SVN_FS_TYPE_FSFS) +fsTypeFSFS = #const_str SVN_FS_TYPE_FSFS -- |@'createFileSystem'@ creates a new, empty Subversion -- filesystem. Note that creating a raw filesystem is different from @@ -156,7 +155,7 @@ fs <- wrapFS (touchPool pool) =<< peek fsPtrPtr - -- config には fs が死ぬまでは生きてゐて慾しい。 + -- We want config to be alive until the fs dies. GF.addForeignPtrConcFinalizer (case fs of FileSystem x -> x) $ touchHash config @@ -182,7 +181,7 @@ fs <- wrapFS (touchPool pool) =<< peek fsPtrPtr - -- config には fs が死ぬまでは生きてゐて慾しい。 + -- We want config to be alive until the fs dies. GF.addForeignPtrConcFinalizer (case fs of FileSystem x -> x) $ touchHash config @@ -233,8 +232,7 @@ withCString path $ \ pathPtr -> withPoolPtr pool $ \ poolPtr -> do svnErr $ _type typePtrPtr pathPtr poolPtr - t <- peekCString =<< peek typePtrPtr - return t + peekCString =<< peek typePtrPtr -- |@'getFileSystemPath' fs@ returns the path to @fs@'s -- repository. Note that this is what was passed to 'createFileSystem' diff --git a/Subversion/FileSystem/Revision.hsc b/Subversion/FileSystem/Revision.hsc --- a/Subversion/FileSystem/Revision.hsc +++ b/Subversion/FileSystem/Revision.hsc @@ -102,7 +102,7 @@ withFSPtr fs $ \ fsPtr -> withPoolPtr pool $ \ poolPtr -> do svnErr $ _revision_root rootPtrPtr fsPtr (fromIntegral revNum) poolPtr - -- root は pool にも fs にも依存する。 + -- FS Root depends on both pool and fs. wrapFSRoot (touchPool pool >> touchFS fs) =<< peek rootPtrPtr @@ -117,8 +117,7 @@ getRevisionNumber = do root <- getRoot unsafeIOToFS $ withFSRootPtr root $ \ rootPtr -> - _revision_root_revision rootPtr - >>= return . fromIntegral + (fmap fromIntegral (_revision_root_revision rootPtr)) -- |@'getRevisionProp' propName@ returns the value of the property -- named @propName@ of the revision. @@ -140,8 +139,8 @@ withPoolPtr pool $ \ poolPtr -> do svnErr $ _revision_prop valPtrPtr fsPtr (fromIntegral revNum) namePtr poolPtr prop <- peekSvnString' =<< peek valPtrPtr - -- prop は pool の中から讀み取られるので、それが濟むま - -- で pool が死んでは困る。 + -- We read prop in the pool so we don't want pool to + -- be freed that time. touchPool pool return $ fmap B8.unpack prop @@ -163,9 +162,8 @@ do svnErr $ _revision_proplist hashPtrPtr fsPtr (fromIntegral revNum) poolPtr hash <- wrapHash (touchPool pool) =<< peek hashPtrPtr mapHash' (\ (n, v) - -> peekSvnString v - >>= - return . ((,) n) . B8.unpack) hash + -> fmap ((,) n . B8.unpack) (peekSvnString v)) + hash -- |Change, add or delete a property on a revision. Note that revision -- properties are non-historied: you can change them after the @@ -226,8 +224,8 @@ got <- peek histPtrPtr if got == nullPtr then - -- ヒストリの終端に達した。これ以後、Pool は解放され - -- ても構はない。 + -- We reached at the end of history. The pool may + -- be freed from now. touchPool pool >> return [] else do x <- getHistLocation got pool diff --git a/Subversion/FileSystem/Root.hsc b/Subversion/FileSystem/Root.hsc --- a/Subversion/FileSystem/Root.hsc +++ b/Subversion/FileSystem/Root.hsc @@ -147,7 +147,6 @@ getRootFS :: FileSystemRoot -> IO FileSystem getRootFS root = withFSRootPtr root $ \ rootPtr -> - -- 實際には root が生きてゐる限り fs は死なないのだが、念の爲。 wrapFS (touchFSRoot root) =<< _root_fs rootPtr -- |@'getFileLength' path@ returns the length of file @path@. @@ -178,7 +177,7 @@ do svnErr $ _file_md5_checksum bufPtr rootPtr pathPtr poolPtr return . map fromIntegral =<< peekArray md5Len bufPtr where - md5Len = (#const APR_MD5_DIGESTSIZE) + md5Len = #const APR_MD5_DIGESTSIZE -- |@'getFileContents' path@ returns the content of file @path@. @@ -215,7 +214,7 @@ withFSRootPtr root $ \ rootPtr -> withCString path $ \ pathPtr -> withPoolPtr pool $ \ poolPtr -> - (svnErr $ _file_contents ioPtrPtr rootPtr pathPtr poolPtr) + svnErr (_file_contents ioPtrPtr rootPtr pathPtr poolPtr) >> peek ioPtrPtr >>= wrapStream (touchPool pool) >>= (if isTxn then @@ -236,9 +235,8 @@ do svnErr $ _node_proplist hashPtrPtr rootPtr pathPtr poolPtr hash <- wrapHash (touchPool pool) =<< peek hashPtrPtr mapHash' (\ (n, v) - -> peekSvnString v - >>= - return . ((,) n) . B8.unpack) hash + -> fmap ((,) n . B8.unpack) (peekSvnString v)) + hash -- |@'getNodeProp' path propName@ returns the value of the property -- named @propName@ of @path@ in a revision or transaction. @@ -253,8 +251,8 @@ withPoolPtr pool $ \ poolPtr -> do svnErr $ _node_prop valPtrPtr rootPtr pathPtr namePtr poolPtr prop <- peekSvnString' =<< peek valPtrPtr - -- prop は pool の中から讀み取られるので、それが濟 - -- むまで pool が死んでは困る。 + -- We read prop in the pool so we don't want pool + -- to be freed that time. touchPool pool return $ fmap B8.unpack prop diff --git a/Subversion/FileSystem/Transaction.hsc b/Subversion/FileSystem/Transaction.hsc --- a/Subversion/FileSystem/Transaction.hsc +++ b/Subversion/FileSystem/Transaction.hsc @@ -41,7 +41,6 @@ where import Control.Monad.Reader -import Control.Monad import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) @@ -80,13 +79,13 @@ fail = Txn . fail instance MonadFS Txn where - getRoot = Txn (ask >>= return . ctxRoot) + getRoot = Txn (fmap ctxRoot ask) unsafeIOToFS a = Txn (liftIO a) isTransaction = Txn (return True) getTxn :: Txn Transaction -getTxn = Txn (ask >>= return . ctxTxn) +getTxn = Txn (fmap ctxTxn ask) {- functions and types ------------------------------------------------------- -} @@ -171,11 +170,11 @@ alloca $ \ rootPtrPtr -> withTxnPtr txn $ \ txnPtr -> withPoolPtr pool $ \ poolPtr -> - (svnErr $ _txn_root rootPtrPtr txnPtr poolPtr) + svnErr (_txn_root rootPtrPtr txnPtr poolPtr) >> peek rootPtrPtr - >>= (wrapFSRoot $ - -- root は pool にも txn にも依存する。 - touchPool pool >> touchTxn txn) + >>= wrapFSRoot + -- The root depends on both pool and txn. + (touchPool pool >> touchTxn txn) -- |@'getTxnProp' propName@ returns the value of the property named -- @propName@ on the transaction. @@ -189,8 +188,8 @@ withPoolPtr pool $ \ poolPtr -> do svnErr $ _txn_prop valPtrPtr txnPtr namePtr poolPtr prop <- peekSvnString' =<< peek valPtrPtr - -- prop は pool の中から讀み取られるので、それが濟 - -- むまでは pool が死んでは困る。 + -- We read prop in the pool so we don't want pool + -- to be freed that time. touchPool pool return $ fmap B8.unpack prop @@ -206,9 +205,8 @@ do svnErr $ _txn_proplist hashPtrPtr txnPtr poolPtr hash <- wrapHash (touchPool pool) =<< peek hashPtrPtr mapHash' (\ (n, v) - -> peekSvnString v - >>= - return . ((,) n) . B8.unpack) hash + -> fmap ((,) n . B8.unpack) (peekSvnString v)) + hash -- |@'setTxnProp' propName propValue@ changes, adds or deletes a -- property on the transaction. diff --git a/Subversion/Hash.hsc b/Subversion/Hash.hsc --- a/Subversion/Hash.hsc +++ b/Subversion/Hash.hsc @@ -62,7 +62,7 @@ instance HashValue String where marshal str - = mallocStringForeignPtr str >>= return . castForeignPtr + = fmap castForeignPtr $ mallocStringForeignPtr str unmarshal finalizer strPtr = do str <- peekCString (castPtr strPtr) @@ -128,10 +128,9 @@ withPoolPtr pool $ \ poolPtr -> _make poolPtr >>= wrapHash (touchPool pool) --- 一旦 Hash に入れた値は、Hash 自体が解放されるまでは解放されなくなる --- 事に注意。それがまずいのであれば、Hash 自体に Map (Ptr ()) --- (ForeignPtr ()) を持たせて、その Map を同時に管理しなければならない。 --- 面倒だ。 +-- Any values which have been put in the Hash will not be freed until +-- Hash gets freed. If this is a problem, we have to let Hash have Map +-- (Ptr ()) (ForeignPtr ()) and maintain it together. Annoying. update :: HashValue a => Hash a -> String -> a -> IO () update (Hash hash) key value = withForeignPtr hash $ \ hashPtr -> @@ -141,7 +140,7 @@ (castPtr $ unsafeForeignPtrToPtr keyFPtr) (#const APR_HASH_KEY_STRING) (unsafeForeignPtrToPtr valueFPtr) - -- hash よりも key 及び value が先に解放されては困る。 + -- key and value must not be freed before hash. GF.addForeignPtrConcFinalizer hash $ do touchForeignPtr keyFPtr touchForeignPtr valueFPtr @@ -162,10 +161,10 @@ if valuePtr == nullPtr then return Nothing else - -- valuePtr は hash の解放と同時に解放され得るのだが、 - -- unmarshal する前にそれが起きては困る。 - unmarshal (touchHash hash) valuePtr - >>= return . Just + -- valuePtr may be freed at the same time when hash gets + -- freed, but that must not happen before doing + -- unmarshal. + fmap Just $ unmarshal (touchHash hash) valuePtr getFirst :: Hash a -> IO (Maybe (HashIndex a)) @@ -231,7 +230,7 @@ where loop Nothing = return [] loop (Just idx) = do x <- f =<< getThis idx - xs <- unsafeInterleaveIO $ + xs <- unsafeInterleaveIO (getNext idx >>= loop) return (x:xs) @@ -241,6 +240,6 @@ where loop Nothing = return [] loop (Just idx) = do x <- f =<< getThis' idx - xs <- unsafeInterleaveIO $ + xs <- unsafeInterleaveIO (getNext idx >>= loop) return (x:xs) diff --git a/Subversion/Pool.hsc b/Subversion/Pool.hsc --- a/Subversion/Pool.hsc +++ b/Subversion/Pool.hsc @@ -22,9 +22,9 @@ newPool :: IO Pool -newPool = _create nullPtr - >>= newForeignPtr _destroy - >>= return . Pool +newPool = fmap Pool ( _create nullPtr + >>= newForeignPtr _destroy + ) withPoolPtr :: Pool -> (Ptr APR_POOL_T -> IO a) -> IO a diff --git a/Subversion/Repository.hsc b/Subversion/Repository.hsc --- a/Subversion/Repository.hsc +++ b/Subversion/Repository.hsc @@ -140,10 +140,10 @@ repos <- wrapRepos (touchPool pool) =<< peek reposPtrPtr - -- config と fsConfig には、repos が死ぬまでは生き - -- てゐて慾しい。 - GF.addForeignPtrConcFinalizer (case repos of Repository x -> x) - $ (touchHash config >> touchHash fsConfig) + -- We want config and fsConfig to be alive until the repos dies. + GF.addForeignPtrConcFinalizer + (case repos of Repository x -> x) + (touchHash config >> touchHash fsConfig) return repos @@ -161,7 +161,7 @@ getRepositoryFS :: Repository -> IO FileSystem getRepositoryFS repos = withReposPtr repos $ \ reposPtr -> - -- svn_fs_t* より先に svn_repos_t* が解放されては困る + -- svn_fs_t* depends on svn_repos_t*. _fs reposPtr >>= wrapFS (touchRepos repos) @@ -173,18 +173,17 @@ withCString author $ \ authorPtr -> withCString' logMsg $ \ logMsgPtr -> withPoolPtr pool $ \ poolPtr -> - (svnErr $ - _fs_begin_txn_for_commit - txnPtrPtr - reposPtr - (fromIntegral revNum) - authorPtr - logMsgPtr - poolPtr) + svnErr (_fs_begin_txn_for_commit + txnPtrPtr + reposPtr + (fromIntegral revNum) + authorPtr + logMsgPtr + poolPtr) >> peek txnPtrPtr - >>= (wrapTxn $ - -- txn は pool にも repos にも依存する。 - touchPool pool >> touchRepos repos) + >>= wrapTxn + -- txn depends on both pool and repos. + (touchPool pool >> touchRepos repos) where withCString' :: Maybe String -> (CString -> IO a) -> IO a withCString' Nothing f = f nullPtr @@ -199,12 +198,12 @@ alloca $ \ newRevPtr -> withTxnPtr txn $ \ txnPtr -> withPoolPtr pool $ \ poolPtr -> - do err <- wrapSvnError =<< (_fs_commit_txn - conflictPathPtrPtr - reposPtr - newRevPtr - txnPtr - poolPtr) + do err <- wrapSvnError =<< _fs_commit_txn + conflictPathPtrPtr + reposPtr + newRevPtr + txnPtr + poolPtr case err of Nothing -> liftM (Right . fromIntegral) (peek newRevPtr) @@ -289,20 +288,21 @@ dumpRepository repos startRev endRev incremental useDeltas = do pool <- newPool pipe <- newPipe - forkIO $ do withReposPtr repos $ \ reposPtr -> - withStreamPtr pipe $ \ pipePtr -> - withPoolPtr pool $ \ poolPtr -> - svnErr $ _dump_fs2 reposPtr - pipePtr - nullPtr - (fromMaybe invalidRevNum $ fmap fromIntegral startRev) - (fromMaybe invalidRevNum $ fmap fromIntegral endRev) - (marshalBool incremental) - (marshalBool useDeltas) - nullFunPtr - nullPtr - poolPtr - sClose pipe + _ <- forkIO $ + do withReposPtr repos $ \ reposPtr -> + withStreamPtr pipe $ \ pipePtr -> + withPoolPtr pool $ \ poolPtr -> + svnErr $ _dump_fs2 reposPtr + pipePtr + nullPtr + (fromMaybe invalidRevNum $ fmap fromIntegral startRev) + (fromMaybe invalidRevNum $ fmap fromIntegral endRev) + (marshalBool incremental) + (marshalBool useDeltas) + nullFunPtr + nullPtr + poolPtr + sClose pipe sReadLBS pipe where invalidRevNum :: SVN_REVNUM_T diff --git a/Subversion/Stream.hsc b/Subversion/Stream.hsc --- a/Subversion/Stream.hsc +++ b/Subversion/Stream.hsc @@ -144,7 +144,7 @@ mkReadFnPtr ra = mkReadCallback $ \ _ bufPtr lenPtr -> do requestedLen <- liftM fromIntegral (peek lenPtr) - resultStr <- ra requestedLen -- FIXME: 例外を catch すべき + resultStr <- ra requestedLen -- FIXME: should catch exceptions B8.useAsCStringLen resultStr $ \ (resultPtr, resultLen) -> do when (resultLen > requestedLen) $ fail "resultLen > requestedLen" -- FIXME @@ -157,14 +157,14 @@ = mkWriteCallback $ \ _ bufPtr lenPtr -> do requestedLen <- liftM fromIntegral (peek lenPtr) inputStr <- B8.packCStringLen (bufPtr, requestedLen) - writtenLen <- wa inputStr -- FIXME: 例外を catch すべき + writtenLen <- wa inputStr -- FIXME: should catch exceptions poke lenPtr (fromIntegral writtenLen) return nullPtr mkCloseFnPtr :: CloseAction -> IO (FunPtr CloseCallback) mkCloseFnPtr ca = mkCloseCallback $ \ _ -> - do ca -- FIXME: 例外を catch すべき + do ca -- FIXME: should catch exceptions return nullPtr @@ -205,7 +205,7 @@ sReadLBS :: Stream -> IO Lazy.ByteString -sReadLBS io = lazyRead >>= return . L8.fromChunks +sReadLBS io = fmap L8.fromChunks lazyRead where chunkSize = 32 * 1024 @@ -221,7 +221,7 @@ sStrictReadLBS :: Stream -> IO Lazy.ByteString -sStrictReadLBS io = strictRead >>= return . L8.fromChunks +sStrictReadLBS io = fmap L8.fromChunks strictRead where chunkSize = 32 * 1024 diff --git a/Subversion/Stream/Pipe.hs b/Subversion/Stream/Pipe.hs --- a/Subversion/Stream/Pipe.hs +++ b/Subversion/Stream/Pipe.hs @@ -8,7 +8,6 @@ import Control.Monad import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy -import Data.Int import Subversion.Stream @@ -46,8 +45,7 @@ mkReadAction pipe reqLen = loop where loop :: IO Strict.ByteString - loop = do nextAction <- tryToRead - nextAction + loop = join tryToRead tryToRead :: IO (IO Strict.ByteString) tryToRead @@ -80,8 +78,7 @@ mkWriteAction pipe input = loop input >> return (Strict.length input) where loop :: Strict.ByteString -> IO () - loop str = do nextAction <- tryToWrite str - nextAction + loop str = join (tryToWrite str) tryToWrite :: Strict.ByteString -> IO (IO ()) tryToWrite str @@ -101,7 +98,7 @@ retry else do writtenStr <- readTVar (pWrittenStr pipe) - writeTVar (pWrittenStr pipe) (writtenStr `Lazy.append` (Lazy.fromChunks [strToWrite])) + writeTVar (pWrittenStr pipe) (writtenStr `Lazy.append` Lazy.fromChunks [strToWrite]) writeTVar (pRequestLen pipe) (reqLen - Strict.length strToWrite) return (loop remaining) diff --git a/Subversion/String.hsc b/Subversion/String.hsc --- a/Subversion/String.hsc +++ b/Subversion/String.hsc @@ -22,16 +22,16 @@ pokeData :: Ptr SVN_STRING_T -> Ptr CChar -> IO () -pokeData = (#poke svn_string_t, data) +pokeData = #poke svn_string_t, data peekData :: Ptr SVN_STRING_T -> IO (Ptr CChar) -peekData = (#peek svn_string_t, data) +peekData = #peek svn_string_t, data pokeLen :: Ptr SVN_STRING_T -> APR_SIZE_T -> IO () -pokeLen = (#poke svn_string_t, len) +pokeLen = #poke svn_string_t, len peekLen :: Ptr SVN_STRING_T -> IO APR_SIZE_T -peekLen = (#peek svn_string_t, len) +peekLen = #peek svn_string_t, len withSvnString :: Strict.ByteString -> (Ptr SVN_STRING_T -> IO a) -> IO a @@ -63,4 +63,4 @@ | obj == nullPtr = return Nothing | otherwise - = peekSvnString obj >>= return . Just + = fmap Just (peekSvnString obj) diff --git a/Subversion/Types.hsc b/Subversion/Types.hsc --- a/Subversion/Types.hsc +++ b/Subversion/Types.hsc @@ -51,8 +51,8 @@ marshalBool :: Bool -> SVN_BOOLEAN_T -marshalBool True = (#const TRUE ) -marshalBool False = (#const FALSE) +marshalBool True = #const TRUE +marshalBool False = #const FALSE unmarshalBool :: SVN_BOOLEAN_T -> Bool unmarshalBool (#const TRUE ) = True @@ -96,13 +96,13 @@ peekVerMajor :: Ptr SVN_VERSION_T -> IO Int -peekVerMajor = (#peek svn_version_t, major) +peekVerMajor = #peek svn_version_t, major peekVerMinor :: Ptr SVN_VERSION_T -> IO Int -peekVerMinor = (#peek svn_version_t, minor) +peekVerMinor = #peek svn_version_t, minor peekVerPatch :: Ptr SVN_VERSION_T -> IO Int -peekVerPatch = (#peek svn_version_t, patch) +peekVerPatch = #peek svn_version_t, patch peekVerTag :: Ptr SVN_VERSION_T -> IO CString -peekVerTag = (#peek svn_version_t, tag) +peekVerTag = #peek svn_version_t, tag