diff --git a/Sound/File/Sndfile.hs b/Sound/File/Sndfile.hs --- a/Sound/File/Sndfile.hs +++ b/Sound/File/Sndfile.hs @@ -19,10 +19,12 @@ IOMode(..), openFile, getFileInfo, hFlush, hClose, SeekMode(..), hSeek, hSeekRead, hSeekWrite, -- *I\/O functions - MBuffer(..), interact, + MBuffer(..), + hReadSamples, hReadFrames, + interact, --IBuffer(..), -- *Exception handling - Exception, errorString, catch, + Exception(..), catch, -- *Header string field access StringType(..), getString, setString ) where @@ -31,6 +33,7 @@ import Sound.File.Sndfile.Buffer import Sound.File.Sndfile.Buffer.Storable () import Sound.File.Sndfile.Buffer.IOCArray () +import Sound.File.Sndfile.Exception import Sound.File.Sndfile.Interface -- EOF diff --git a/Sound/File/Sndfile/Buffer.hs b/Sound/File/Sndfile/Buffer.hs --- a/Sound/File/Sndfile/Buffer.hs +++ b/Sound/File/Sndfile/Buffer.hs @@ -1,33 +1,53 @@ +{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE MultiParamTypeClasses #-} module Sound.File.Sndfile.Buffer ( MBuffer(..), checkSampleBounds, checkFrameBounds, - interact + hReadSamples, hReadFrames, + interact, + IOFunc, + sf_read_double, sf_readf_double, + sf_write_double, sf_writef_double, + sf_read_float, sf_readf_float, + sf_write_float, sf_writef_float ) where -import C2HS import Control.Monad (liftM, when) import Data.Array.Base (unsafeRead, unsafeWrite) -import Data.Array.MArray (Ix, MArray, getBounds) ---import Data.Array.IArray (IArray) +import Data.Array.MArray (Ix, MArray, getBounds, newArray_) import Data.Ix (rangeSize) +import Foreign.Ptr (Ptr) +import Foreign.C.Types (CLLong) import Prelude hiding (interact) +import Sound.File.Sndfile.Exception (throw) import Sound.File.Sndfile.Interface checkSampleBounds :: (Monad m) => Count -> Int -> Count -> m () checkSampleBounds size channels count - | (count `mod` channels) /= 0 = throw (Exception ("invalid channel/count combination " ++ (show count))) - | (count < 0) || (count > size) = throw (Exception "index out of bounds") + | (count `mod` channels) /= 0 = throw 0 ("invalid channel/count combination " ++ (show count)) + | (count < 0) || (count > size) = throw 0 ("index out of bounds") | otherwise = return () checkFrameBounds :: (Monad m) => Count -> Int -> Count -> m () checkFrameBounds size channels count - | (size `mod` channels) /= 0 = throw (Exception "invalid buffer size") - | (count < 0) || (count > (size `quot` channels)) = throw (Exception "index out of bounds") + | (size `mod` channels) /= 0 = throw 0 ("invalid buffer size") + | (count < 0) || (count > (size `quot` channels)) = throw 0 ("index out of bounds") | otherwise = return () +type IOFunc a = HandlePtr -> Ptr a -> CLLong -> IO CLLong + +foreign import ccall unsafe "sf_read_double" sf_read_double :: IOFunc Double +foreign import ccall unsafe "sf_readf_double" sf_readf_double :: IOFunc Double +foreign import ccall unsafe "sf_write_double" sf_write_double :: IOFunc Double +foreign import ccall unsafe "sf_writef_double" sf_writef_double :: IOFunc Double + +foreign import ccall unsafe "sf_read_float" sf_read_float :: IOFunc Float +foreign import ccall unsafe "sf_readf_float" sf_readf_float :: IOFunc Float +foreign import ccall unsafe "sf_write_float" sf_write_float :: IOFunc Float +foreign import ccall unsafe "sf_writef_float" sf_writef_float :: IOFunc Float + -- |The class MBuffer is used for polymorphic I\/O on a 'Handle', and is -- parameterized on the mutable array type, the element type and the monad -- results are returned in. @@ -78,6 +98,40 @@ -- 'hPutFrames' returns the number of frames written (which should be the same -- as the 'count' parameter). hPutFrames :: Handle -> a Index e -> Count -> m Count + +-- TODO: Optimize unsafeWriteRange +unsafeWriteRange :: (MArray a e m) => a Int e -> (Int, Int) -> e -> m () +unsafeWriteRange _ (i0, i) _ | i0 > i = return () +unsafeWriteRange a (i0, i) e = unsafeWrite a i0 e >> unsafeWriteRange a (i0+1,i) e + +-- |Return an array with the requested number of items. The 'count' parameter +-- must be an integer product of the number of channels or an error will +-- occur. +hReadSamples :: (MBuffer a e m, Num e) => Handle -> Count -> m (Maybe (a Index e)) +hReadSamples h n = do + b <- newArray_ (0, n-1) + n' <- hGetSamples h b n + if n' == 0 + then return Nothing + else do + when (n' < n) (unsafeWriteRange b (n',n-1) 0) + return (Just b) + +-- |Return an array with the requested number of frames of data. +-- The resulting array size is equal to the product of the number of frames +-- `n' and the number of channels in the soundfile. +hReadFrames :: (MBuffer a e m, Num e) => Handle -> Count -> m (Maybe (a Index e)) +hReadFrames h n = do + b <- newArray_ (0, si) + n' <- hGetFrames h b n + if n' == 0 + then return Nothing + else do + when (n' < n) (unsafeWriteRange b (f2s n', si) 0) + return (Just b) + where + f2s = (* channels (hInfo h)) + si = (f2s n) - 1 modifyArray :: (MArray a e m, Ix i) => (e -> e) -> a i e -> Int -> Int -> m () modifyArray f a i n diff --git a/Sound/File/Sndfile/Buffer/IOCArray.hs b/Sound/File/Sndfile/Buffer/IOCArray.hs --- a/Sound/File/Sndfile/Buffer/IOCArray.hs +++ b/Sound/File/Sndfile/Buffer/IOCArray.hs @@ -1,16 +1,12 @@ -{-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_GHC -fglasgow-exts #-} module Sound.File.Sndfile.Buffer.IOCArray where import C2HS -import Control.Monad (liftM) import Data.Array.IOCArray import Sound.File.Sndfile.Buffer import Sound.File.Sndfile.Interface -type IOFunc a = HandlePtr -> Ptr a -> CLLong -> IO CLLong - {-# INLINE hIO #-} hIO :: (Storable a) => (Count -> Int -> Count -> IO ()) @@ -18,30 +14,25 @@ -> Handle -> (IOCArray Index a) -> Count -> IO Count hIO checkBounds ioFunc (Handle info handle) buffer count = do - size <- liftM rangeSize $ getBounds buffer + size <- rangeSize `fmap` getBounds buffer checkBounds size (channels info) count result <- withIOCArray buffer $ - \ptr -> liftM fromIntegral $ ioFunc handle ptr (cIntConv count) + \ptr -> fromIntegral `fmap` ioFunc handle ptr (fromIntegral count) + :: IO Count checkHandle handle touchIOCArray buffer - return $ cIntConv result - -foreign import ccall unsafe "sf_read_double" sf_read_double :: IOFunc Double -foreign import ccall unsafe "sf_write_double" sf_write_double :: IOFunc Double + return $ fromIntegral result instance MBuffer IOCArray Double IO where hGetSamples = hIO checkSampleBounds sf_read_double - hGetFrames = hIO checkFrameBounds sf_read_double + hGetFrames = hIO checkFrameBounds sf_readf_double hPutSamples = hIO checkSampleBounds sf_write_double - hPutFrames = hIO checkFrameBounds sf_write_double - -foreign import ccall unsafe "sf_read_float" sf_read_float :: IOFunc Float -foreign import ccall unsafe "sf_write_float" sf_write_float :: IOFunc Float + hPutFrames = hIO checkFrameBounds sf_writef_double instance MBuffer IOCArray Float IO where hGetSamples = hIO checkSampleBounds sf_read_float - hGetFrames = hIO checkFrameBounds sf_read_float + hGetFrames = hIO checkFrameBounds sf_readf_float hPutSamples = hIO checkSampleBounds sf_write_float - hPutFrames = hIO checkFrameBounds sf_write_float + hPutFrames = hIO checkFrameBounds sf_writef_float -- EOF diff --git a/Sound/File/Sndfile/Buffer/Storable.hs b/Sound/File/Sndfile/Buffer/Storable.hs --- a/Sound/File/Sndfile/Buffer/Storable.hs +++ b/Sound/File/Sndfile/Buffer/Storable.hs @@ -1,16 +1,12 @@ -{-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_GHC -fglasgow-exts #-} module Sound.File.Sndfile.Buffer.Storable where import C2HS -import Control.Monad (liftM) import Data.Array.Storable import Sound.File.Sndfile.Buffer import Sound.File.Sndfile.Interface -type IOFunc a = HandlePtr -> Ptr a -> CLLong -> IO CLLong - {-# INLINE hIO #-} hIO :: (Storable a) => (Count -> Int -> Count -> IO ()) @@ -18,30 +14,25 @@ -> Handle -> (StorableArray Index a) -> Count -> IO Count hIO checkBounds ioFunc (Handle info handle) buffer count = do - size <- liftM rangeSize $ getBounds buffer + size <- rangeSize `fmap` getBounds buffer checkBounds size (channels info) count result <- withStorableArray buffer $ - \ptr -> liftM fromIntegral $ ioFunc handle ptr (cIntConv count) + \ptr -> fromIntegral `fmap` ioFunc handle ptr (cIntConv count) + :: IO Count checkHandle handle touchStorableArray buffer return $ cIntConv result -foreign import ccall unsafe "sf_read_double" sf_read_double :: IOFunc Double -foreign import ccall unsafe "sf_write_double" sf_write_double :: IOFunc Double - instance MBuffer StorableArray Double IO where hGetSamples = hIO checkSampleBounds sf_read_double - hGetFrames = hIO checkFrameBounds sf_read_double + hGetFrames = hIO checkFrameBounds sf_readf_double hPutSamples = hIO checkSampleBounds sf_write_double - hPutFrames = hIO checkFrameBounds sf_write_double - -foreign import ccall unsafe "sf_read_float" sf_read_float :: IOFunc Float -foreign import ccall unsafe "sf_write_float" sf_write_float :: IOFunc Float + hPutFrames = hIO checkFrameBounds sf_writef_double instance MBuffer StorableArray Float IO where hGetSamples = hIO checkSampleBounds sf_read_float - hGetFrames = hIO checkFrameBounds sf_read_float + hGetFrames = hIO checkFrameBounds sf_readf_float hPutSamples = hIO checkSampleBounds sf_write_float - hPutFrames = hIO checkFrameBounds sf_write_float + hPutFrames = hIO checkFrameBounds sf_writef_float -- EOF diff --git a/Sound/File/Sndfile/Exception.hs b/Sound/File/Sndfile/Exception.hs new file mode 100644 --- /dev/null +++ b/Sound/File/Sndfile/Exception.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +module Sound.File.Sndfile.Exception ( + Exception(..), + catch, throw +) where + +import Control.Exception (catchDyn, throwDyn) +import Data.Typeable (Typeable) +import Prelude hiding (catch) + +-- |Values of type 'Exception' are thrown by the library when an error occurs. +-- +-- Use 'catch' to catch only exceptions of this type. +data Exception = + Exception { errorString :: String } + | UnrecognisedFormat { errorString :: String } + | SystemError { errorString :: String } + | MalformedFile { errorString :: String } + | UnsupportedEncoding { errorString :: String } + deriving (Typeable, Show) + +-- | Construct 'Exception' from error code and string. +fromErrorCode :: Int -> String -> Exception +fromErrorCode 1 = UnrecognisedFormat +fromErrorCode 2 = SystemError +fromErrorCode 3 = MalformedFile +fromErrorCode 4 = UnsupportedEncoding +fromErrorCode _ = Exception + +-- |Catch values of type 'Exception'. +catch :: IO a -> (Exception -> IO a) -> IO a +catch = catchDyn + +-- | Throw 'Exception' according to error code and string +throw :: Int -> String -> a +throw code str = throwDyn (fromErrorCode code str) diff --git a/Sound/File/Sndfile/Interface.chs b/Sound/File/Sndfile/Interface.chs --- a/Sound/File/Sndfile/Interface.chs +++ b/Sound/File/Sndfile/Interface.chs @@ -1,15 +1,11 @@ {-# LANGUAGE ForeignFunctionInterface #-} -{-# OPTIONS_GHC -fglasgow-exts #-} module Sound.File.Sndfile.Interface where import C2HS import Control.Monad (liftM, when) -import Control.Exception (catchDyn, throwDyn) import Data.Bits -import Data.Int (Int64) -import Data.Typeable (Typeable) -import Prelude hiding (catch) +import qualified Sound.File.Sndfile.Exception as E import System.IO.Unsafe (unsafePerformIO) #include @@ -216,29 +212,11 @@ -- ==================================================================== -- Exceptions --- |Values of type 'Exception' are thrown by the library when an error occurs. --- --- Use 'catch' to catch only exceptions of this type. -data Exception = Exception String deriving (Typeable, Show) - --- |Return the error string associated with the 'Exception'. -errorString :: Exception -> String -errorString (Exception s) = s - --- |Catch values of type 'Exception'. -catch :: IO a -> (Exception -> IO a) -> IO a -catch = catchDyn - -throw :: Exception -> a -throw = throwDyn - -raiseError :: Handle -> IO () -raiseError handle = liftM (throw . Exception) $ (peekCString $ {#call pure sf_strerror#} (hPtr handle)) - checkHandle :: HandlePtr -> IO HandlePtr checkHandle handle = do code <- liftM fromIntegral $ {#call unsafe sf_error#} handle - when (code /= 0) $ raiseError (Handle defaultInfo handle) + when (code /= 0) $ + peekCString ({#call pure sf_strerror#} handle) >>= E.throw code return handle -- ==================================================================== diff --git a/hsndfile.cabal b/hsndfile.cabal --- a/hsndfile.cabal +++ b/hsndfile.cabal @@ -1,6 +1,6 @@ Name: hsndfile -Version: 0.1.1 -Category: Sound +Version: 0.2.0 +Category: Sound License: GPL License-File: COPYING Copyright: Stefan Kersten, 2007-2008 @@ -14,14 +14,19 @@ Libsndfile is a comprehensive C library for reading and writing a large number of soundfile formats: . + . + Changelog and source tarballs can be found at + Tested-With: GHC -Build-Type: Simple -Build-Depends: array, base, carray, haskell98 +Build-Type: Simple +Build-Depends: array, base, carray >= 0.1.2, haskell98 +Build-Tools: c2hs >= 0.15 Exposed-Modules: Sound.File.Sndfile -Other-Modules: C2HS, - Sound.File.Sndfile.Buffer, - Sound.File.Sndfile.Buffer.IOCArray, - Sound.File.Sndfile.Buffer.Storable, - Sound.File.Sndfile.Interface -Ghc-Options: -Wall +Other-Modules: C2HS + Sound.File.Sndfile.Buffer + Sound.File.Sndfile.Buffer.IOCArray + Sound.File.Sndfile.Buffer.Storable + Sound.File.Sndfile.Exception + Sound.File.Sndfile.Interface +Ghc-Options: -Wall -fno-warn-name-shadowing Extra-Libraries: sndfile