packages feed

sndfile-enumerators (empty) → 0.4.0

raw patch · 14 files changed

+1168/−0 lines, 14 filesdep +MonadCatchIO-transformersdep +basedep +binarysetup-changed

Dependencies added: MonadCatchIO-transformers, base, binary, bytestring, containers, extensible-exceptions, iteratee, mutable-iter, transformers, word24

Files

+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3++All code is copyrighted 2009 by John W. Lato. Usage of this code is governed by the following license.++* Copyright (c) 2009 John W. Lato+*+* All rights reserved.+*+* Redistribution and use in source and binary forms, with or without+* modification, are permitted provided that the following conditions are met:+*     * Redistributions of source code must retain the above copyright+*       notice, this list of conditions and the following disclaimer.+*     * Redistributions in binary form must reproduce the above copyright+*       notice, this list of conditions and the following disclaimer in the+*       documentation and/or other materials provided with the distribution.+*     * Neither the name of Tiresias Press nor the+*       names of its contributors may be used to endorse or promote products+*       derived from this software without specific prior written permission.+*+* THIS SOFTWARE IS PROVIDED BY John W. Lato ``AS IS'' AND ANY+* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+* DISCLAIMED. IN NO EVENT SHALL John W. Lato OR ANY CONTRIBUTORS BE LIABLE+* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+* CAUSED ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ examples/wave_reader.hs view
@@ -0,0 +1,57 @@+-- Read a wave file and return some information about it.++{-# LANGUAGE BangPatterns #-}+module Main where++import Prelude as P++import Sound.Iteratee.Codecs.Wave+import Data.MutableIter+import Data.MutableIter.IOBuffer (IOBuffer)+import qualified Data.MutableIter.IOBuffer as IB+import qualified Data.IntMap as IM+import qualified Data.Iteratee as I+import Data.Word (Word8)+import Control.Monad.CatchIO+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import System++main :: IO ()+main = do+  args <- getArgs+  case args of+    [] -> putStrLn "Usage: wave_reader FileName"+    fname:xs -> do+      putStrLn $ "Reading file: " ++ fname+      fileDriverRandom (2^14) (waveReader >>= test) fname+      return ()++-- Use the collection of [WAVEDE] returned from waveReader to+-- do further processing.  The IntMap has an entry for each type of chunk+-- in the wave file.  Read the first format chunk and disply the +-- format information, then use the dictProcessData function+-- to enumerate over the max_iter iteratee to find the maximum value+-- (peak amplitude) in the file.+test :: Maybe (IM.IntMap [WAVEDE])+  -> MIteratee (IOBuffer r Word8) IO ()+test Nothing = liftIO $ putStrLn "No dictionary"+test (Just dict) = do+  fmtm <- dictReadFirstFormat dict+  liftIO . putStrLn $ show fmtm+  maxm <- dictProcessData_ 0 dict max_iter+  liftIO . putStrLn $ show maxm+  return ()++max_iter2 :: MonadCatchIO m => MIteratee (IOBuffer r Double) m Double+max_iter2 = foldl' (flip (max . abs)) 0++-- |This version is faster, but lower-level+max_iter :: MIteratee (IOBuffer r Double) IO Double+max_iter = m' 0+  where+    m' !acc = liftI (step acc)+    step acc (I.Chunk buf) = guardNull buf (m' acc) $ do+      val <- lift $ IB.foldl' (flip (max . abs)) acc buf+      m' val+    step acc str = idone acc str
+ examples/wave_writer.hs view
@@ -0,0 +1,37 @@+-- Copy data from one file to another++{-# LANGUAGE BangPatterns #-}+module Main where++import Data.MutableIter+import qualified Data.MutableIter.IOBuffer as IB+import Sound.Iteratee.Codecs.Wave+import Sound.Iteratee+import qualified Data.IntMap as IM+import Data.Word (Word8)+import Control.Monad.Trans+import System++main :: IO ()+main = do+  args <- getArgs+  case args of+    fname:oname:xs -> do+      putStrLn $ "Reading file: " ++ fname+      fileDriverAudio (waveReader >>= writer oname) fname+      return ()+    _ -> putStrLn "Usage: wave_writer ReadFile WriteFile"++-- Use the collection of [WAVEDE] returned from waveReader to+-- do further processing.  In this case, write out a new file with the+-- same format.+writer :: FilePath -> Maybe (IM.IntMap [WAVEDE]) -> MIteratee (IB.IOBuffer r Word8) AudioMonad ()+writer _ Nothing = liftIO $ putStrLn "No dictionary"+writer fp (Just dict) = do+  fmtm <- dictReadFirstFormat dict+  liftIO $ putStrLn $ show fmtm+  maybe (error "No format")+        (\fmt -> dictProcessData 0 dict $ writeWave fp fmt)+        fmtm+  return ()+
+ examples/writer2.hs view
@@ -0,0 +1,63 @@+-- Copy data from two separate files to another.++{-# LANGUAGE BangPatterns, RankNTypes #-}+module Main where++import Data.MutableIter+import qualified Data.MutableIter.IOBuffer as IB+import Sound.Iteratee.Codecs.Wave+import Sound.Iteratee+import qualified Data.Iteratee as I+import qualified Data.IntMap as IM+import Data.Word (Word8)+import Foreign.Storable (Storable)+import Control.Monad.Trans+import System++import System.IO+import Control.Monad.CatchIO as CIO+import Control.Monad++file2Driver :: (MonadCatchIO m, Functor m) =>+  (forall r. Maybe (IM.IntMap [WAVEDE])+    -> MIteratee (IB.IOBuffer r Word8) m (MIteratee (IB.IOBuffer r Double) m a))+  -> FilePath+  -> FilePath+  -> m a+file2Driver i f1 f2 = CIO.bracket+  (liftIO $ (openBinaryFile f1 ReadMode >>= \h1 -> openBinaryFile f2 ReadMode >>= \h2 -> return (h1,h2)))+  (liftIO . (\(h1, h2) -> hClose h1 >> hClose h2))+  (\(h1,h2) -> (I.run . unwrap) =<< (I.run . unwrap) =<<+    ( enumHandleRandom defaultChunkLength h1 (waveReader >>= i) >>= \i2 -> enumHandleRandom defaultChunkLength h2 (waveReader >>= \mdict -> i2 >>= embedProc mdict)))++main :: IO ()+main = do+  args <- getArgs+  case args of+    fname1:fname2:oname:xs -> do+      putStrLn $ "Reading file1 " ++ fname1+      putStrLn $ "Reading file2 " ++ fname2+      runAudioMonad $ file2Driver (writer oname) fname1 fname2+      return ()+    _ -> putStrLn "Usage: wave_writer ReadFile1 ReadFile2 WriteFile"+++embedProc :: (MonadCatchIO m, Functor m) => Maybe (IM.IntMap [WAVEDE]) -> MIteratee (IB.IOBuffer r Double) m a -> MIteratee (IB.IOBuffer r Word8) m (MIteratee (IB.IOBuffer r Double) m a)+embedProc Nothing i = error "No dictionary"+embedProc (Just dict) i = dictProcessData 0 dict i++-- Use the collection of [WAVEDE] returned from waveReader to+-- do further processing.  The IntMap has an entry for each type of chunk+-- in the wave file.  Read the first format chunk and disply the +-- format information, then use the dictProcessData function+-- to enumerate over the max_iter iteratee to find the maximum value+-- (peak amplitude) in the file.+writer :: FilePath -> Maybe (IM.IntMap [WAVEDE]) -> MIteratee (IB.IOBuffer r Word8) AudioMonad (MIteratee (IB.IOBuffer r Double) AudioMonad ())+writer _ Nothing = error "No Dictionary"+writer fp (Just dict) = do+  fmtm <- dictReadFirstFormat dict+  liftIO $ putStrLn $ show fmtm+  maybe (error "No format")+        (\fmt -> dictProcessData 0 dict $ writeWave fp fmt)+        fmtm+
+ sndfile-enumerators.cabal view
@@ -0,0 +1,60 @@+Name:		sndfile-enumerators+Version:        0.4.0+Cabal-Version:  >= 1.2+Description:	encode and decode soundfiles using Iteratees.+                Audio files may be read or written, with classes and +                data structures to facilitate conversion between different+                formats.  Currently only wave format is supported.+License:	BSD3+License-file:	LICENSE+Author:		John W. Lato, jwlato@gmail.com+Maintainer:	John W. Lato, jwlato@gmail.com+homepage:       http://tanimoto.us/~jwlato/haskell/sndfile-enumerators+Stability:	experimental+synopsis:       Audio file reading/writing+category:       Codec, Sound+build-type:     Simple+cabal-version:  >= 1.2+tested-with:    GHC == 6.10.4, GHC == 6.12.1+extra-source-files:+  LICENSE+  examples/wave_reader.hs+  examples/wave_writer.hs+  examples/writer2.hs++flag splitBase+  description: Choose the new split-up base package.++Library+ hs-Source-Dirs:+   src+ ghc-options:+   -Wall+   -fexcess-precision+ if flag(splitBase)+   build-depends:+     base >= 3, base < 5+ else+   build-depends:+     base < 3+ build-depends:+   binary                    >= 0.5 && < 0.6,+   containers                >= 0.2 && < 0.5,+   transformers              >= 0.2 && < 0.3,+   iteratee                  >= 0.4 && < 0.6,+   bytestring                >= 0.9.1 && < 0.10,+   extensible-exceptions     >= 0.1 && < 0.2,+   word24                    >= 0.1 && < 0.2,+   mutable-iter              >= 0.1 && < 0.3,+   MonadCatchIO-transformers >= 0.2 && < 0.3+ exposed-modules:+   Sound.Iteratee+   Sound.Iteratee.Base+   Sound.Iteratee.Codecs+   Sound.Iteratee.Codecs.Wave+   Sound.Iteratee.Codecs.Raw+   Sound.Iteratee.Writer+ other-modules:+   Sound.Iteratee.Codecs.WaveWriter+   Sound.Iteratee.Codecs.Common+
+ src/Sound/Iteratee.hs view
@@ -0,0 +1,12 @@+module Sound.Iteratee (+  module Sound.Iteratee.Base,+  module Sound.Iteratee.Writer,+  module Sound.Iteratee.Codecs+)++where++import Sound.Iteratee.Base+import Sound.Iteratee.Codecs+import Sound.Iteratee.Writer+
+ src/Sound/Iteratee/Base.hs view
@@ -0,0 +1,64 @@+module Sound.Iteratee.Base (+  -- * Types+  -- ** Internal types+  AudioStreamState (..),+  WritableAudio (..),+  AudioMonad,+  -- *** Functions to work with AudioMonad+  module Control.Monad.Trans.State,+  defaultChunkLength,+  -- ** Audio Format types+  AudioFormat (..),+  SupportedBitDepths (..),+  NumChannels,+  SampleRate,+  BitDepth,+  FrameCount,+  -- ** File Format Types+  SupportedFileFormat (..)+)++where++import Prelude as P++import Control.Monad.Trans.State+import System.IO++-- |Information about the AudioStream+data AudioStreamState =+  WaveState !(Maybe Handle) !(Maybe AudioFormat) !Integer !Integer !Integer -- ^ Handle, format, Total bytes written, data bytes written, data chunklen offset+  | NoState+  deriving (Eq, Show)++-- | An enumeration of all file types supported for reading and writing.+data SupportedFileFormat = Raw+                           | Wave+                           deriving (Show, Enum, Bounded, Eq)++-- | Common functions for writing audio data+class WritableAudio a where+  emptyState :: a -> AudioStreamState+  initState ::  a -> Handle -> AudioStreamState+  supportedBitDepths :: a -> SupportedBitDepths+  fileType           :: a -> SupportedFileFormat++-- | Audio monad stack (for writing files)+type AudioMonad = StateT AudioStreamState IO++-- | Format of audio data+data AudioFormat = AudioFormat {+  numberOfChannels :: NumChannels, -- ^Number of channels in the audio data+  sampleRate :: SampleRate, -- ^Sample rate of the audio data+  bitDepth :: BitDepth -- ^Bit depth of the audio data+  } deriving (Show, Eq)++type NumChannels = Integer+type SampleRate  = Integer+type BitDepth    = Integer+type FrameCount  = Integer++data SupportedBitDepths = Any | Supported [BitDepth]++defaultChunkLength :: Int+defaultChunkLength = 8190
+ src/Sound/Iteratee/Codecs.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ExistentialQuantification #-}++module Sound.Iteratee.Codecs (+  module Sound.Iteratee.Codecs.Wave,+  getWriter,+  Codec (..),+  getCodec+)++where++import Sound.Iteratee.Base+import Sound.Iteratee.Codecs.Wave+import Sound.Iteratee.Codecs.Raw++import Data.MutableIter+import qualified Data.MutableIter.IOBuffer as IB++-- |Get a writer iteratee for a SupportedFileFormat+getWriter ::+  SupportedFileFormat+  -> FilePath+  -> AudioFormat+  -> MIteratee (IB.IOBuffer r Double) AudioMonad ()+getWriter Wave = writeWave+getWriter Raw  = error "No writer defined for Raw format"++-- |An existentially-wrapped codec.  This exists in order to get an arbitrary+-- codec (and associated information, such as bit depths)+-- from a SupportedFileFormat.+data Codec = forall a. WritableAudio a => Codec a++instance WritableAudio Codec where+  emptyState         (Codec a) = emptyState a+  initState          (Codec a) = initState a+  supportedBitDepths (Codec a) = supportedBitDepths a+  fileType           (Codec a) = fileType a++getCodec :: SupportedFileFormat -> Codec+getCodec Wave = Codec WaveCodec+getCodec Raw  = Codec RawCodec
+ src/Sound/Iteratee/Codecs/Common.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Sound.Iteratee.Codecs.Common (+  stringRead4+ ,joinMaybe+ ,convFunc+)+  +where++import Sound.Iteratee.Base+import qualified Data.Iteratee as I+import Data.MutableIter as Iter+import qualified Data.MutableIter.IOBuffer as IB+import Foreign+import Control.Monad (replicateM, liftM)+import Control.Monad.CatchIO+import Control.Monad.IO.Class+import Data.Char (chr)+import Data.Int.Int24+import Data.Word.Word24++-- =====================================================+-- useful type synonyms++type IOB m el = IOBuffer m el++-- determine host endian-ness+be :: IO Bool+be = fmap (==1) $ with (1 :: Word16) (\p -> peekByteOff p 1 :: IO Word8)++-- convenience function to read a 4-byte ASCII string+stringRead4 :: MonadCatchIO m => MIteratee (IOB r Word8) m String+stringRead4 = (liftM . map) (chr . fromIntegral) $ replicateM 4 Iter.head++unroll8 :: (MonadCatchIO m) => MIteratee (IOB r Word8) m (Maybe (IOB r Word8))+unroll8 = liftI step+  where+  step (I.Chunk buf) = guardNull buf (liftI step) $+                         idone (Just buf) (I.Chunk IB.empty)+  step stream        = idone Nothing stream++-- When unrolling to a Word8, use the specialized unroll8 function+-- because we actually don't need to do anything+{-# RULES "unroll8" forall n. unroller n = unroll8 #-}+unroller :: (Storable a, MonadCatchIO m) =>+  Int+  -> MIteratee (IOB r Word8) m (Maybe (IOB r a))+unroller wSize = liftI step+  where+  step (I.Chunk buf) = guardNull buf (liftI step) $ do+    len <- liftIO $ IB.length buf+    if len < wSize then liftIO (IB.copyBuffer buf) >>= liftI . step'+      else if len `rem` wSize == 0+              then do+                buf' <- liftIO $ convert_vec buf+                idone (Just buf') (I.Chunk IB.empty)+              else let newLen = (len `div` wSize) * wSize+                   in do+                      (h, t) <- liftIO $ IB.splitAt buf newLen+                      h' <- liftIO $ convert_vec h+                      idone (Just h') (I.Chunk t)+  step stream = idone Nothing stream+  step' i (I.Chunk buf) = guardNull buf (liftI (step' i)) $ do+    l <- liftIO $ IB.length buf+    iLen <- liftIO $ IB.length i+    newbuf <- liftIO $ IB.append i buf+    if l+iLen < wSize then liftI (step' newbuf)+       else do+         newLen <- liftIO $ IB.length newbuf+         let newLen' = (newLen `div` wSize) * wSize+         (h,t) <- liftIO $ IB.splitAt newbuf newLen'+         h' <- liftIO $ convert_vec h+         idone (Just h') (I.Chunk t)+  step' _i stream  = idone Nothing stream+  convert_vec vec  = IB.castBuffer vec >>= hostToLE++hostToLE :: (Monad m, Storable a) => IOB r a -> m (IOB r a)+hostToLE vec = let be' = unsafePerformIO be in if be'+    then error "wrong endian-ness.  Ask the maintainer to implement hostToLE"+{-+              (fp, off, len) = VB.toForeignPtr vec+              wSize = sizeOf $ Vec.head vec+            in+            loop wSize fp len off+-}+    else return vec+{-+    where+      loop _wSize _fp 0 _off = return vec+      loop wSize fp len off  = do+        FFP.withForeignPtr fp (swapBytes wSize . flip FP.plusPtr off)+        loop wSize fp (len - 1) (off + 1)+-}++{-+swapBytes :: Int -> ForeignPtr a -> IO ()+swapBytes wSize fp = withForeignPtr fp $ \p -> case wSize of+  1 -> return ()+  2 -> do+    (w1 :: Word8) <- peekByteOff p 0+    (w2 :: Word8) <- peekByteOff p 1+    pokeByteOff p 0 w2+    pokeByteOff p 1 w1+  3 -> do+    (w1 :: Word8) <- peekByteOff p 0+    (w3 :: Word8) <- peekByteOff p 2+    pokeByteOff p 0 w3+    pokeByteOff p 2 w1+  4 -> do+    (w1 :: Word8) <- peekByteOff p 0+    (w2 :: Word8) <- peekByteOff p 1+    (w3 :: Word8) <- peekByteOff p 2+    (w4 :: Word8) <- peekByteOff p 3+    pokeByteOff p 0 w4+    pokeByteOff p 1 w3+    pokeByteOff p 2 w2+    pokeByteOff p 3 w1+  _ -> error "swapBytes called with wordsize > 4"++w8 :: Word8+w8 = 0+-}+w16 :: Word16+w16 = 0+w24 :: Word24+w24 = 0+w32 :: Word32+w32 = 0++-- |Convert Word8s to Doubles+convFunc :: (MonadCatchIO m) =>+  AudioFormat+  -> ForeignPtr Int+  -> ForeignPtr Double+  -> MIteratee (IOBuffer r Word8) m (IOBuffer r Double)+convFunc (AudioFormat _nc _sr 8) offp bufp = do+  mbuf <- unroll8+  liftIO $ maybe (error "error in convFunc") (IB.mapBuffer+    (normalize 8 . (fromIntegral :: Word8 -> Int8)) offp bufp) mbuf+convFunc (AudioFormat _nc _sr 16) offp bufp = do+  mbuf <- unroller (sizeOf w16)+  liftIO $ maybe (error "error in convFunc") (IB.mapBuffer+    (normalize 16 . (fromIntegral :: Word16 -> Int16)) offp bufp) mbuf+convFunc (AudioFormat _nc _sr 24) offp bufp = do+  mbuf <- unroller (sizeOf w24)+  liftIO $ maybe (error "error in convFunc") (IB.mapBuffer+    (normalize 24 . (fromIntegral :: Word24 -> Int24)) offp bufp) mbuf+convFunc (AudioFormat _nc _sr 32) offp bufp = do+  mbuf <- unroller (sizeOf w32)+  liftIO $ maybe (error "error in convFunc") (IB.mapBuffer+    (normalize 32 . (fromIntegral :: Word32 -> Int32)) offp bufp) mbuf+convFunc _ _ _ = MIteratee $ I.throwErr (I.iterStrExc "Invalid wave bit depth")+++-- ---------------------+-- convenience functions++-- |Convert (Maybe []) to [].  Nothing maps to an empty list.+joinMaybe :: Maybe [a] -> [a]+joinMaybe Nothing = []+joinMaybe (Just a) = a++-- |Normalize a given value for the provided bit depth.+-- This uses wave-standard normalization.  I'll support more formats+-- if/when it becomes necessary.+normalize :: Integral a => BitDepth -> a -> Double+normalize 8 = \a -> let m = 1 / 128 in m * (fromIntegral a - 128)+normalize bd = \a -> if a > 0+                       then fromIntegral a * mPos+                       else fromIntegral a * mNeg+  where+    mPos = 1/ (fromIntegral (1 `shiftL` fromIntegral (bd - 1) :: Integer) - 1)+    mNeg = 1/ fromIntegral (1 `shiftL` fromIntegral (bd - 1) :: Integer)+
+ src/Sound/Iteratee/Codecs/Raw.hs view
@@ -0,0 +1,38 @@+module Sound.Iteratee.Codecs.Raw (+  RawCodec (..)+  ,readRaw+)++where++import Sound.Iteratee.Base+import Sound.Iteratee.Codecs.Common+import Data.MutableIter+import qualified Data.MutableIter.IOBuffer as IB++import Data.Word+import Control.Monad.CatchIO+import Control.Monad.IO.Class++import Foreign.ForeignPtr++type IOB = IB.IOBuffer++data RawCodec = RawCodec++instance WritableAudio RawCodec where+  emptyState         RawCodec   = error "emptyState not defined for Raw files"+  initState          RawCodec _ = error "initState not defined for Raw files"+  supportedBitDepths RawCodec   = Any+  fileType           RawCodec   = Raw++readRaw ::+ (MonadCatchIO m, Functor m) =>+  AudioFormat+  -> MIteratee (IOB r Double) m a+  -> MIteratee (IOB r Word8) m a+readRaw fmt iter_dub = do+  offp <- liftIO $ newFp 0+  bufp <- liftIO $ mallocForeignPtrArray defaultChunkLength+  joinIob . convStream (convFunc fmt offp bufp) $ iter_dub+
+ src/Sound/Iteratee/Codecs/Wave.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE RankNTypes, NoMonomorphismRestriction #-}+module Sound.Iteratee.Codecs.Wave (+  -- * Types+  -- ** Internal types+  WaveCodec (..),+  WAVEDE (..),+  WAVEDEENUM (..),+  -- ** WAVE CHUNK types+  WAVECHUNK (..),+  chunkToString,+  -- * Wave reading Iteratees+  -- ** Basic wave reading+  waveReader,+  readRiff,+  waveChunk,+  -- ** WAVE Dictionary reading/processing functions+  dictReadFormat,+  dictReadFirstFormat,+  dictReadLastFormat,+  dictProcessData,+  dictProcessData_,+  -- ** Information on WAVE chunks+  dictGetLengthBytes,+  dictGetLengthSamples,+  dictSoundInfo,+  -- * Wave writing files+  -- ** Writing iteratees+  writeWave,+  -- ** Primitive wave writing functions+  openWave,+  closeWave,+  runWaveAM,+  writeFormat,+  writeDataHeader,+  writeDataChunk+)+where++import Prelude as P++import Sound.Iteratee.Codecs.WaveWriter+import Sound.Iteratee.Base+import Sound.Iteratee.Codecs.Common++import qualified Data.MutableIter.IOBuffer as IB+import Data.MutableIter as MI+import Data.MutableIter.Binary++import qualified Data.Iteratee as Itr+import Data.Iteratee (throwErr, iterStrExc)++import qualified Data.IntMap as IM+import Data.Word+import Data.Char (ord)++import Control.Monad.CatchIO+import Control.Monad.IO.Class++import Foreign.ForeignPtr++-- =====================================================+-- WAVE libary code++type IOB = IB.IOBuffer++-- |A WAVE directory is a list associating WAVE chunks with+-- a record WAVEDE+type WAVEDict = IM.IntMap [WAVEDE]++data WAVEDE = WAVEDE{+  wavedeCount :: Int, -- ^length of chunk+  wavedeType :: WAVECHUNK, -- ^type of chunk+  wavedeEnum :: WAVEDEENUM -- ^enumerator to get values of chunk+  }++instance Show WAVEDE where+  show a = "Type: " ++ show (wavedeType a) ++ " :: Length: " +++            show (wavedeCount a)++type MEnumeratorM sfrom sto m a = MIteratee sto m a -> MIteratee sfrom m a+type MEnumeratorM2 sfrom sto m a = MIteratee sto m a+                                   -> MIteratee sfrom m (MIteratee sto m a)++data WAVEDEENUM =+  WENBYTE  (forall a m r. (MonadCatchIO m, Functor m) =>+              MEnumeratorM (IOB r Word8) (IOB r Word8) m a)+  | WENDUB (forall a m r. (MonadCatchIO m, Functor m) =>+              MEnumeratorM2 (IOB r Word8) (IOB r Double) m a)++-- |Standard WAVE Chunks+data WAVECHUNK = WAVEFMT -- ^Format+  | WAVEDATA              -- ^Data+  | WAVEOTHER String      -- ^Other+  deriving (Eq, Ord, Show)+instance Enum WAVECHUNK where+  fromEnum WAVEFMT = 1+  fromEnum WAVEDATA = 2+  fromEnum (WAVEOTHER _) = 3+  toEnum 1 = WAVEFMT+  toEnum 2 = WAVEDATA+  toEnum 3 = WAVEOTHER ""+  toEnum _ = error "Invalid enumeration value"++-- -----------------+-- wave chunk reading/writing functions++-- |Convert a string to WAVECHUNK type+waveChunk :: String -> Maybe WAVECHUNK+waveChunk str+  | str == "fmt " = Just WAVEFMT+  | str == "data" = Just WAVEDATA+  | P.length str == 4 = Just $ WAVEOTHER str+  | otherwise = Nothing++-- |Convert a WAVECHUNK to the representative string+chunkToString :: WAVECHUNK -> String+chunkToString WAVEFMT = "fmt "+chunkToString WAVEDATA = "data"+chunkToString (WAVEOTHER str) = str++-- -----------------++-- |The library function to read the WAVE dictionary+waveReader ::+ (MonadCatchIO m, Functor m) =>+   MIteratee (IOB r Word8) m (Maybe WAVEDict)+waveReader = do+  readRiff+  tot_size <- endianRead4 LSB+  readRiffWave+  chunks_m <- findChunks $ fromIntegral tot_size+  loadDict $ joinMaybe chunks_m++-- |Read the RIFF header of a file.+readRiff :: MonadCatchIO m => MIteratee (IOB r Word8) m ()+readRiff = do+  cnt <- heads $ fmap (fromIntegral . ord) "RIFF"+  case cnt of+    4 -> return ()+    _ -> MIteratee . throwErr . iterStrExc $ "Bad RIFF header: "++-- | Read the WAVE part of the RIFF header.+readRiffWave :: MonadCatchIO m => MIteratee (IOB r Word8) m ()+readRiffWave = do+  cnt <- heads $ fmap (fromIntegral . ord) "WAVE"+  case cnt of+    4 -> return ()+    _ -> MIteratee . throwErr . iterStrExc $ "Bad RIFF/WAVE header: "++-- | An internal function to find all the chunks.  It assumes that the+-- stream is positioned to read the first chunk.+findChunks ::+ MonadCatchIO m =>+  Int+  -> MIteratee (IOB r Word8) m (Maybe [(Int, WAVECHUNK, Int)])+findChunks n = findChunks' 12 []+  where+  findChunks' offset acc = do+    mpad <- MI.peek+    if (offset `rem` 2 == 1) && (mpad == Just 0)+      then MI.drop 1 >> findChunks'2 offset acc+      else findChunks'2 offset acc+  findChunks'2 offset acc = do+    typ <- stringRead4+    count <- endianRead4 LSB+    case waveChunk typ of+      Nothing -> (MIteratee . throwErr . iterStrExc $+        "Bad subchunk descriptor: " ++ show typ)+      Just chk -> let newpos = offset + 8 + count in+        if newpos >= fromIntegral n+          then return . Just . reverse $+               (fromIntegral offset, chk, fromIntegral count) : acc+          else do+            MIteratee . Itr.seek $ fromIntegral newpos+            findChunks' newpos $+             (fromIntegral offset, chk, fromIntegral count) : acc++loadDict ::+ (MonadCatchIO m, Functor m) =>+  [(Int, WAVECHUNK, Int)]+  -> MIteratee (IOB r Word8) m (Maybe WAVEDict)+loadDict = P.foldl read_entry (return (Just IM.empty))+  where+  read_entry dictM (offset, typ, count) = dictM >>=+    maybe (return Nothing) (\dict -> do+      enum_m <- readValue dict offset typ count+      case (enum_m, IM.lookup (fromEnum typ) dict) of+        (Just enum, Nothing) -> --last entry+          return . Just $ IM.insert (fromEnum typ)+                                    [WAVEDE (fromIntegral count) typ enum] dict+        (Just enum, Just _vals) -> --more entries to come+          return . Just $ IM.update+            (\ls -> Just $ ls ++ [WAVEDE (fromIntegral count) typ enum])+            (fromEnum typ) dict+        (Nothing, _) -> return (Just dict)+    )++readValue ::+ (MonadCatchIO m, Functor m) =>+  WAVEDict+  -> Int -- ^ Offset+  -> WAVECHUNK -- ^ Chunk type+  -> Int -- ^ Count+  -> MIteratee (IOB r Word8) m (Maybe WAVEDEENUM)+readValue _dict offset _ 0 = MIteratee . throwErr . iterStrExc $+  "Zero count in the entry of chunk at: " ++ show offset++readValue dict offset WAVEDATA count = do+  fmt_m <- dictReadLastFormat dict+  case fmt_m of+    Just fmt ->+      fmt `seq` (return . Just $ WENDUB (\iter_dub -> do+        MIteratee $ Itr.seek (8 + fromIntegral offset)+        offp <- liftIO $ newFp 0+        bufp <- liftIO $ mallocForeignPtrArray defaultChunkLength+        let iter = convStream (convFunc fmt offp bufp) iter_dub+        joinIob . takeUpTo count $ iter)+      )+    Nothing ->+      MIteratee . throwErr . iterStrExc $+        "No valid format for data chunk at: " ++ show offset++-- return the WaveFormat iteratee+readValue _dict offset WAVEFMT count =+  return . Just $ WENBYTE $ \iter -> do+    MIteratee $ Itr.seek (8 + fromIntegral offset)+    joinIob $ MI.takeUpTo count iter++-- for WAVEOTHER, return Word8s and maybe the user can parse them+readValue _dict offset (WAVEOTHER _str) count =+  return . Just $ WENBYTE $ \iter -> do+    MIteratee $ Itr.seek (8 + fromIntegral offset)+    joinIob $ MI.takeUpTo count iter++-- |An Iteratee to read a wave format chunk+sWaveFormat :: MonadCatchIO m =>+  MIteratee (IOB r Word8) m (Maybe AudioFormat)+sWaveFormat = do+  f' <- endianRead2 LSB+  nc <- endianRead2 LSB+  sr <- endianRead4 LSB+  MI.drop 6+  bd <- endianRead2 LSB+  if f' == 1+    then return . Just $ AudioFormat (fromIntegral nc)+                                     (fromIntegral sr)+                                     (fromIntegral bd)+    else return Nothing++-- ---------------------+-- functions to assist with reading from the dictionary++-- |Read the first format chunk in the WAVE dictionary.+dictReadFirstFormat ::+ (MonadCatchIO m, Functor m) =>+  WAVEDict+  -> MIteratee (IOB r Word8) m (Maybe AudioFormat)+dictReadFirstFormat dict = case IM.lookup (fromEnum WAVEFMT) dict of+  Just [] -> return Nothing+  Just (WAVEDE _ WAVEFMT (WENBYTE enum) : _xs) -> enum sWaveFormat+  _ -> return Nothing++-- |Read the last fromat chunk from the WAVE dictionary.  This is useful+-- when parsing all chunks in the dictionary.+dictReadLastFormat ::+ (MonadCatchIO m, Functor m) =>+  WAVEDict+  -> MIteratee (IOB r Word8) m (Maybe AudioFormat)+dictReadLastFormat dict = case IM.lookup (fromEnum WAVEFMT) dict of+  Just [] -> return Nothing+  Just xs -> let (WAVEDE _ WAVEFMT (WENBYTE enum)) = last xs+             in enum sWaveFormat+  _ -> return Nothing++-- |Read the specified format chunk from the WAVE dictionary+dictReadFormat ::+ (MonadCatchIO m, Functor m) =>+  Int -- ^ Index in the format chunk list to read+  -> WAVEDict -- ^ Dictionary+  -> MIteratee (IOB r Word8) m (Maybe AudioFormat)+dictReadFormat ix dict = case IM.lookup (fromEnum WAVEFMT) dict of+  Just xs -> let (WAVEDE _ WAVEFMT (WENBYTE enum)) = xs !! ix+             in enum sWaveFormat+  _ -> return Nothing++-- |Read the specified data chunk from the dictionary, applying the+-- data to the specified MIteratee.+dictProcessData ::+ (MonadCatchIO m, Functor m) =>+  Int -- ^ Index in the data chunk list to read+  -> WAVEDict -- ^ Dictionary+  -> MIteratee (IOB r Double) m a+  -> MIteratee (IOB r Word8) m (MIteratee (IOB r Double) m a)+dictProcessData ix dict iter = case IM.lookup (fromEnum WAVEDATA) dict of+  Just xs -> let (WAVEDE _ WAVEDATA (WENDUB enum)) = (!!) xs ix+             in (enum iter)+  _ -> error "didn't find requested enumerator in WAVEDict for dictProcessData"++dictProcessData_ ::+ (MonadCatchIO m, Functor m) =>+  Int -- ^ Index in the data chunk list to read+  -> WAVEDict -- ^ Dictionary+  -> MIteratee (IOB r Double) m a+  -> MIteratee (IOB r Word8) m (Maybe a)+dictProcessData_ ix dict iter = case IM.lookup (fromEnum WAVEDATA) dict of+  Just xs -> let (WAVEDE _ WAVEDATA (WENDUB enum)) = (!!) xs ix+             in fmap Just . joinIob . enum $ iter+  _ -> return Nothing++-- | Get the length of data in a dictionary chunk, in bytes.+dictGetLengthBytes :: WAVECHUNK -> -- type of chunk to read+                      Int ->        -- index in the chunk list to read+                      WAVEDict ->   -- dictionary+                      Maybe Integer -- length of chunk in bytes+dictGetLengthBytes wc ix dict = IM.lookup (fromEnum wc) dict >>= \xs ->+  let (WAVEDE off _ _) = (!!) xs ix in Just (fromIntegral off)++-- | Get the length of a data chunk, in samples.+dictGetLengthSamples :: AudioFormat ->+                        Int ->+                        WAVEDict ->+                        Maybe Integer+dictGetLengthSamples af ix dict = IM.lookup (fromEnum WAVEDATA) dict >>= \xs ->+  let (WAVEDE off _ _) = (!!) xs ix in Just (fromIntegral off `div` bd)+  where+  bd = bitDepth af `div` 8++-- ---------------------+-- combination/utility functions++-- |Get the AudioFormat and data length from a file+dictSoundInfo ::+ (MonadCatchIO m, Functor m) =>+  WAVEDict+  -> MIteratee (IOB r Word8) m+      (Maybe (AudioFormat, Integer))+dictSoundInfo dict = do+  fmtm <- dictReadFirstFormat dict+  return $ fmtm >>=+           (\fmt -> fmap (\l -> (fmt, l)) $ dictGetLengthSamples fmt 0 dict)+
+ src/Sound/Iteratee/Codecs/WaveWriter.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Sound.Iteratee.Codecs.WaveWriter (+  -- * Types+  WaveCodec (..),+  -- * Writing functions+  -- ** Writing iteratees+  writeWave,+  -- ** Low-level writing functions+  openWave,+  closeWave,+  runWaveAM,+  writeFormat,+  writeDataHeader,+  writeDataChunk+)+where++import Sound.Iteratee.Base+import Data.MutableIter+import qualified Data.MutableIter.IOBuffer as IB+import Data.MutableIter.IOBuffer (hPut, mapBuffer)+import qualified Data.Iteratee as I+import Data.Int.Int24+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Char8 as BC+import qualified Data.Binary.Put as P+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Foreign++import System.IO++import GHC.Float++-- =====================================================+-- WAVE libary code++-- |Data type to specify WAVE-formatted data+data WaveCodec = WaveCodec++instance WritableAudio WaveCodec where+  emptyState         WaveCodec   = WaveState Nothing Nothing 0 0 0+  initState          WaveCodec h = WaveState (Just h) Nothing 0 0 0+  supportedBitDepths WaveCodec   = Supported [8,16,24,32]+  fileType           WaveCodec   = Wave++-- ---------------------+-- Functions to support writing++-- |Create an iteratee to write data to a wave file.+writeWave ::+  FilePath+  -> AudioFormat+  -> MIteratee (IOBuffer r Double) AudioMonad ()+writeWave fp af = do+  lift $ openWave fp+  lift $ writeFormat af+  lift writeDataHeader+  loop+  lift closeWave+  lift $ put NoState+  where+    loop = liftI step+    step (I.Chunk buf) = guardNull buf loop $ lift (writeDataChunk buf) >> loop+    step stream        = idone () stream++-- |Open a wave file for writing+openWave :: FilePath -> AudioMonad ()+openWave file = do+  h <- liftIO $ openFile file WriteMode+  liftIO $ LB.hPut h . P.runPut $ writeTopHeaderRaw+  let (WaveState h' f i i' off) = initState WaveCodec h+  put $ WaveState h' f (i + 4) i' (off + 12)+  +-- |Write a data format block to the open wave file+writeFormat :: AudioFormat -> AudioMonad ()+writeFormat af = do+  as <- get+  case as of+    WaveState (Just h) Nothing  i i' off -> do+      liftIO $ LB.hPut h . P.runPut $ writeFormatRaw af+      put $ WaveState (Just h) (Just af) (i + 24) i' (off + 24)+    WaveState Nothing  _      _ _ _  -> error "Can't write: no file opened"+    WaveState _      (Just _) _ _ _  -> error "Format already written"+    _                                -> error "Can't write: not a WAVE file"++-- |Write the header for a Data chunk.+writeDataHeader :: AudioMonad ()+writeDataHeader = do+  as <- get+  case as of+    WaveState (Just h) (Just af) i i' off -> do+      liftIO $ LB.hPut h . P.runPut $ writeDataRaw+      put $ WaveState (Just h) (Just af) (i + 8) i' (off + 4)+    WaveState Nothing  _       _ _ _  -> error "Can't write: no file opened"+    WaveState _        Nothing _ _ _  -> error "No format specified"+    _                                 -> error "Can't write: not a WAVE file"++-- |Write a data chunk.+writeDataChunk :: IOBuffer r Double -> AudioMonad ()+writeDataChunk buf = do+  as <- get+  case as of+    WaveState (Just h) (Just af) i i' off -> do+      len <- liftIO . liftM fromIntegral $ getLength af+      liftIO $ putVec af h buf+      put $ WaveState (Just h) (Just af) (i + len) (i' + len) off+    WaveState Nothing  _       _ _ _  -> error "Can't write: no file opened"+    WaveState _        Nothing _ _ _  -> error "No format specified"+    _                                 -> error "Can't write: not a WAVE file"+  where+    putVec af h buf' = case bitDepth af of+      8  -> convertVector i8  af buf' >>= hPut h+      16 -> convertVector i16 af buf' >>= hPut h+      24 -> convertVector i24 af buf' >>= hPut h+      32 -> convertVector i32 af buf' >>= hPut h+      x  -> error $ "Cannot write wave file: unsupported bit depth " ++ show x+    getLength af = liftM (fromIntegral (bitDepth af `div` 8) *) (IB.length buf)++i8 :: Int8+i8 = 0+i16 :: Int16+i16 = 0+i24 :: Int24+i24 = 0+i32 :: Int32+i32 = 0++closeWave :: AudioMonad ()+closeWave = do+  s <- get+  case s of+    WaveState (Just h) _ i i' off -> do+      liftIO $ hSeek h AbsoluteSeek 4+      liftIO $ LB.hPut h $ P.runPut $ P.putWord32le $ fromIntegral i+      liftIO $ hSeek h AbsoluteSeek off+      liftIO $ LB.hPut h $ P.runPut $ P.putWord32le $ fromIntegral i'+      liftIO $ hClose h+    WaveState Nothing  _  _ _  _ -> error "Can't close file: no handle"+    x -> error $ "Can't close file: isn't a WAVE file: " ++ show x++runWaveAM :: AudioMonad a -> IO a+runWaveAM m = evalStateT (m >>= (\a -> closeWave >> return a))+                         (emptyState WaveCodec)+ +writeTopHeaderRaw :: P.Put+writeTopHeaderRaw = do+  P.putByteString $ BC.pack "RIFF"+  P.putWord32le 36+  P.putByteString $ BC.pack "WAVE"++writeFormatRaw :: AudioFormat -> P.Put+writeFormatRaw (AudioFormat nc sr bd) = do+  let nc' = fromIntegral nc -- Word32+      sr' = fromIntegral sr -- Word32+      bd' = fromIntegral bd -- Word32+  P.putByteString $ BC.pack "fmt "+  P.putWord32le 16+  P.putWord16le 1+  P.putWord16le $ fromIntegral nc+  P.putWord32le sr'+  P.putWord32le (sr' * nc' * (bd' `div` 8))+  P.putWord16le $ fromIntegral (nc' * (bd' `div` 8))+  P.putWord16le $ fromIntegral bd++writeDataRaw :: P.Put+writeDataRaw = do+  P.putByteString $ BC.pack "data"+  P.putWord32le maxBound++-- ------------------------------------------+-- Data normalization and conversion functions++convertVector ::+  (Integral a, Storable a, Bounded a) =>+  a+  -> AudioFormat+  -> IOBuffer r Double+  -> IO (IOBuffer r a)+convertVector _ (AudioFormat _nc _sr bd) buf = do+  offp <- newFp 0+  l <- IB.length buf+  obuf <- mallocForeignPtrBytes (l * sizeOf (0::Double))+  mapBuffer (unNormalize bd) offp obuf buf++-- 8 bits are handled separately because (at least in wave) they aren't 2's+-- complement negatives.+unNormalize :: forall a.(Integral a, Bounded a) => BitDepth -> Double -> a+unNormalize 8 a = fromIntegral $ double2Int (128 * (1 + a))+unNormalize _bd a = let+  posMult = fromIntegral (maxBound :: a)+  --input is already neg., so negMult needs to be positive to preserve sign+  negMult = abs $ fromIntegral (minBound :: a)+  in+  if a >= 0+    then fromIntegral . roundDoublePos . (* posMult) . clip $ a+    else fromIntegral . roundDoubleNeg . (* negMult) . clip $ a++clip :: Double -> Double+clip = max (-1) . min 1++roundDoublePos :: Double -> Int+roundDoublePos x = let b = double2Int x in if x - int2Double b >= 0.5+  then b+1+  else b++roundDoubleNeg :: Double -> Int+roundDoubleNeg x = let b = double2Int x in if x - int2Double b <= -0.5+  then b-1+  else b+
+ src/Sound/Iteratee/Writer.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE RankNTypes, FlexibleContexts #-}++{- | Generic functions and iteratees to support writing files.+-}++module Sound.Iteratee.Writer (+  -- * Audio writing functions+  fileDriverAudio,+  runAudioMonad+)++where++import Sound.Iteratee.Base+import Sound.Iteratee.Codecs++import Data.MutableIter++import Foreign.Storable (Storable)++runAudioMonad :: AudioMonad a -> IO a+runAudioMonad am = do+  (a, s) <- runStateT am NoState+  case s of+    NoState     -> return a+    WaveState{} -> runWaveAM (put s >> return a)++fileDriverAudio :: (Storable el) =>+  (forall r.  MIteratee (IOBuffer r el) AudioMonad a)+  -> FilePath+  -> IO a+fileDriverAudio i fp = runAM (fileDriverRandom defaultChunkLength i fp)+  where+    runAM = runAudioMonad