HCodecs 0.1 → 0.2

raw patch · 10 files changed

+186/−205 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• HCodecs.cabal +5/−7
• LICENSE +1/−1
• src/Codec/Midi.hs +34/−34
• src/Codec/SoundFont.hs +39/−50
• src/Codec/Wav.hs +30/−28
• src/Data/Arbitrary.hs +10/−11
• src/Data/Audio.hs +39/−45
• src/Data/ByteString/Builder.hs +1/−2
• src/Data/ByteString/Parser.hs +1/−1
• src/Tests/Main.hs +26/−26

@@ -1,5 +1,5 @@ name: HCodecs-version: 0.1+version: 0.2 cabal-Version: >= 1.2 license: BSD3 license-file: LICENSE@@ -11,7 +11,7 @@ stability: experimental synopsis: A library to read, write and manipulate MIDI, WAVE, and SoundFont2 files. description:-  The library provides functions to read, write and manipulate MIDI, WAVE and SoundFont2 multimedia files. It is written entirely in Haskell (without any FFI). It uses efficient parsing and building combinators for binary data stored in ByteStrings (based on the one in 'binary' package).+  The library provides functions to read, write and manipulate MIDI, WAVE and SoundFont2 multimedia files. It is written entirely in Haskell (without any FFI). It uses efficient  parsing and building combinators for binary data stored in ByteStrings (based on the one in 'binary' package).   .   Correctness of significant parts of the library has been validated with QuickCheck and Haskell Program Coverage (HPC) tool-kits.   .@@ -20,16 +20,14 @@ extra-source-files: src/Tests/Main.hs  library-  hs-source-dirs:  src-  ghc-options : -O3 -Wall -fno-warn-name-shadowing-  build-Depends: base < 5, bytestring, QuickCheck < 2, random, array+  hs-source-dirs: src+  ghc-options : -O3 -Wall+  build-Depends: base < 5, bytestring, random, array, QuickCheck < 2   exposed-modules:     Codec.Midi     Codec.Wav     Codec.SoundFont-         Data.Audio-     Data.ByteString.Parser     Data.ByteString.Builder   other-modules:

@@ -1,4 +1,4 @@-Copyright (c) 2007-2008 George Giorgidze+Copyright (c) 2007-2010 George Giorgidze  All rights reserved. 

@@ -8,7 +8,7 @@ -- Stability   : Experimental -- Portability : Portable ----- Module for reading, writing and maniplating of standard MIDI files.+-- Reading, writing and maniplating of standard MIDI files -- ----------------------------------------------------------------------------- @@ -66,7 +66,7 @@ import Data.ByteString.Builder import Data.Arbitrary () -import Data.Word
+import Data.Word import qualified Data.ByteString.Lazy as L import Data.Bits import Data.Maybe@@ -281,10 +281,10 @@   where trk' = (concat $ map removeTrackEnds trks) ++ [(0,TrackEnd)]  merge :: (Num a, Ord a) => Track a -> Track a -> Track a-merge trk1 trk2 = (fromAbsTime $ f trk1' trk2') ++ [(0,TrackEnd)]+merge track1 track2 = (fromAbsTime $ f trk1' trk2') ++ [(0,TrackEnd)]   where-  trk1' = toAbsTime $ removeTrackEnds trk1-  trk2' = toAbsTime $ removeTrackEnds trk2+  trk1' = toAbsTime $ removeTrackEnds track1+  trk2' = toAbsTime $ removeTrackEnds track2   f trk [] = trk   f [] trk = trk   f ((dt1,m1) : trk1) ((dt2,m2) : trk2) = if dt1 <= dt2@@ -344,8 +344,8 @@  parseMidi :: Parser Midi parseMidi = do-  string "MThd"-  word32be 6+  _ <- string "MThd"+  _ <- word32be 6   formatType' <- getWord16be   trackNumber' <- getWord16be   timeDivision' <- getWord16be@@ -384,8 +384,8 @@    parseTrack :: Parser (Track Ticks) parseTrack = do-  string "MTrk"-  getWord32be -- trackSize +  _ <- string "MTrk"+  _ <- getWord32be -- trackSize    track' <- parseMessages Nothing   return track'  @@ -436,7 +436,7 @@ parseChannel mPreMsg isNeededMsg msgCode = p1 <|> p2   where   p1 = do-    lookAhead (satisfy ( < 0x80))+    _ <- lookAhead (satisfy ( < 0x80))     guard $ (isJust mPreMsg) && (isNeededMsg $ fromJust mPreMsg)     return $! channel (fromJust mPreMsg)   p2 = do@@ -513,7 +513,7 @@    parseMetaMessage :: Parser Message parseMetaMessage = do-  word8 0xFF+  _ <- word8 0xFF   choice [       parseSequenceNumber     , parseText@@ -583,114 +583,114 @@  parseSequenceNumber :: Parser Message parseSequenceNumber = do-  word8 0x00-  varLenBe 2+  _ <- word8 0x00+  _ <- varLenBe 2   n <- getWord16be   return $! SequenceNumber (fromIntegral n)  parseText :: Parser Message parseText = do-  word8 0x01+  _ <- word8 0x01   l <- getVarLenBe   s <- getString (fromIntegral l)   return $! Text s  parseCopyright :: Parser Message parseCopyright = do-  word8 0x02+  _ <- word8 0x02   l <- getVarLenBe   s <- getString (fromIntegral l)   return $! Copyright s  parseTrackName :: Parser Message parseTrackName = do-  word8 0x03+  _ <- word8 0x03   l <- getVarLenBe   s <- getString (fromIntegral l)   return $! TrackName s  parseInstrumentName :: Parser Message parseInstrumentName = do-  word8 0x04+  _ <- word8 0x04   l <- getVarLenBe   s <- getString (fromIntegral l)   return $! InstrumentName s  parseLyrics :: Parser Message parseLyrics = do-  word8 0x05+  _ <- word8 0x05   l <- getVarLenBe   s <- getString (fromIntegral l)   return $! Lyrics s  parseMarker :: Parser Message parseMarker = do-  word8 0x06+  _ <- word8 0x06   l <- getVarLenBe   s <- getString (fromIntegral l)   return $! Marker s  parseCuePoint :: Parser Message parseCuePoint = do-  word8 0x07+  _ <- word8 0x07   l <- getVarLenBe   s <- getString (fromIntegral l)   return $! CuePoint s  parseProgramName :: Parser Message parseProgramName = do-  word8 0x08+  _ <- word8 0x08   l <- getVarLenBe   s <- getString (fromIntegral l)   return $! ProgramName s  parseDeviceName :: Parser Message parseDeviceName = do-  word8 0x09+  _ <- word8 0x09   l <- getVarLenBe   s <- getString (fromIntegral l)   return $! DeviceName s  parseChannelPrefix :: Parser Message parseChannelPrefix = do-  word8 0x20-  varLenBe 1+  _ <- word8 0x20+  _ <- varLenBe 1   p <- getWord8   return $! ChannelPrefix (fromIntegral p)  parseTrackEnd :: Parser Message parseTrackEnd =  do-  word8 0x2F-  varLenBe 0+  _ <- word8 0x2F+  _ <- varLenBe 0   return $! TrackEnd  parseTempoChange :: Parser Message parseTempoChange = do-  word8 0x51-  varLenBe 3+  _ <- word8 0x51+  _ <- varLenBe 3   t <- getWord24be   return $! TempoChange (fromIntegral t)  parseSMPTEOffset :: Parser Message parseSMPTEOffset = do-  word8 0x54-  varLenBe 5+  _ <- word8 0x54+  _ <- varLenBe 5   bs <- getLazyByteString 5    let [n1,n2,n3,n4,n5] = map fromIntegral (L.unpack bs)   return $! SMPTEOffset n1 n2 n3 n4 n5  parseTimeSignature :: Parser Message parseTimeSignature = do-  word8 0x58-  varLenBe 4+  _ <- word8 0x58+  _ <- varLenBe 4   bs <- getLazyByteString 4   let [n1,n2,n3,n4] = map fromIntegral (L.unpack bs)   return $! TimeSignature n1 n2 n3 n4  parseKeySignature :: Parser Message parseKeySignature = do-  word8 0x59-  varLenBe 2+  _ <- word8 0x59+  _ <- varLenBe 2   n1 <- getInt8   n2 <- getWord8   return $! KeySignature (fromIntegral n1) (fromIntegral n2)

@@ -118,11 +118,11 @@ instance Arbitrary Sdta where   arbitrary = do     sn <- choose (1,1024)-    smpl <- arrayGen sn+    smpl1 <- arrayGen sn     oneof [-        return $! Sdta smpl Nothing-      , do sm24 <- arrayGen sn-           return $! Sdta smpl (Just sm24)+        return $! Sdta smpl1 Nothing+      , do sm24' <- arrayGen sn+           return $! Sdta smpl1 (Just sm24')       ]   coarbitrary = undefined @@ -456,9 +456,9 @@  parseSoundFont :: Parser SoundFont parseSoundFont = do-  string "RIFF"-  getWord32le -- chunkSize-  string "sfbk"+  _ <- string "RIFF"+  _ <- getWord32le -- chunkSize+  _ <- string "sfbk"   infos' <- parseInfos   sdta' <- parseSdta   pdta' <- parsePdta@@ -486,14 +486,14 @@  parseInfos :: Parser (Array Word Info) parseInfos = do-  string "LIST"-  getWord32le -- chunkSize-  string "INFO"+  _ <- string "LIST"+  _ <- getWord32le -- chunkSize+  _ <- string "INFO"   infos' <- many p   return $! listArray (0, genericLength infos' - 1) infos'   where   p = choice [-      do n <- getString 4; word32le 4; w1 <- getWord16le; w2 <- getWord16le;+      do n <- getString 4; _ <- word32le 4; w1 <- getWord16le; w2 <- getWord16le;          case n of            "ifil" -> return $! Version (fromIntegral w1) (fromIntegral w2)            "iver" -> return $! RomVersion (fromIntegral w1) (fromIntegral w2)@@ -559,10 +559,10 @@    parseSdta :: Parser Sdta parseSdta = do-  string "LIST"+  _ <- string "LIST"   sdtaSize <- getWord32le >>= return .fromIntegral-  string "sdta"-  string "smpl"+  _ <- string "sdta"+  _ <- string "smpl"   smplSize <- getWord32le  >>= return .fromIntegral   when (odd smplSize) $ fail "'smplSize' must not be odd number"   let sn = div smplSize 2@@ -570,45 +570,45 @@   choice [       do guard (smplSize == (sdtaSize - 12))          return $! Sdta {smpl = smpl', sm24 =  Nothing}-    , do string "sm24"+    , do _ <- string "sm24"          let sm24Size = if odd sn then sn + 1 else sn -         word32le (fromIntegral sm24Size)+         _ <- word32le (fromIntegral sm24Size)          sm24' <- Audio.parseSampleData sn getInt8          skip (fromIntegral $ sm24Size - sn)          return $! Sdta{ smpl = smpl', sm24 = Just sm24'}     ]  buildSdta :: Sdta -> Builder-buildSdta (Sdta smpl Nothing) = mconcat [+buildSdta (Sdta smpl1 Nothing) = mconcat [     putString "LIST"   , putWord32le $ fromIntegral $ sdtaSize   , putString "sdta"   , putString "smpl"   , putWord32le $ fromIntegral $ smplSize-  , Audio.buildSampleData putInt16le smpl]-  where smplSize = (Audio.sampleNumber smpl) * 2+  , Audio.buildSampleData putInt16le smpl1]+  where smplSize = (Audio.sampleNumber smpl1) * 2         sdtaSize = 4 + 4 + 4 + smplSize-buildSdta (Sdta smpl (Just sd8)) = mconcat [+buildSdta (Sdta smpl1 (Just sd8)) = mconcat [     putString "LIST"   , putWord32le $ fromIntegral $ sdtaSize   , putString "sdta"   , putString "smpl"   , putWord32le $ fromIntegral $ smplSize-  , Audio.buildSampleData putInt16le smpl+  , Audio.buildSampleData putInt16le smpl1   , putString "sm24"   , putWord32le $ fromIntegral $ sm24Size   , Audio.buildSampleData putInt8 sd8   , mconcat $ genericReplicate (sm24Size - sn) $ putWord8 0]-  where sn = Audio.sampleNumber smpl+  where sn = Audio.sampleNumber smpl1         smplSize = sn * 2         sm24Size = if odd sn then sn + 1 else sn         sdtaSize = 4 + 4 + 4 + smplSize + 4 + 4 + sm24Size  parsePdta :: Parser Pdta parsePdta = do-  string "LIST"-  getWord32le -- pdtaSize-  string "pdta"+  _ <- string "LIST"+  _ <- getWord32le -- pdtaSize+  _ <- string "pdta"   phdrs' <- parseSubchunk "phdr" 38 parsePhdr   pbags' <- parseSubchunk "pbag" 4 parseBag   pmods' <- parseSubchunk "pmod" 10 parseMod@@ -621,7 +621,7 @@   return $! Pdta phdrs' pbags' pmods' pgens' insts' ibags' imods' igens' shdrs'  buildPdta :: Pdta -> Builder-buildPdta pdta = mconcat [+buildPdta pdta1 = mconcat [     putString "LIST"   , putWord32le $ fromIntegral chunkSize   , fromLazyByteString bs]@@ -629,22 +629,22 @@   chunkSize = L.length bs   bs = toLazyByteString $ mconcat [       putString "pdta"-    , buildSubchunk "phdr" 38 buildPhdr (phdrs pdta)-    , buildSubchunk "pbag"  4 buildBag  (pbags pdta)-    , buildSubchunk "pmod" 10 buildMod  (pmods pdta)-    , buildSubchunk "pgen"  4 buildGen  (pgens pdta)-    , buildSubchunk "inst" 22 buildInst (insts pdta)-    , buildSubchunk "ibag"  4 buildBag  (ibags pdta)-    , buildSubchunk "imod" 10 buildMod  (imods pdta)-    , buildSubchunk "igen"  4 buildGen  (igens pdta)    -    , buildSubchunk "shdr" 46 buildShdr (shdrs pdta)    +    , buildSubchunk "phdr" 38 buildPhdr (phdrs pdta1)+    , buildSubchunk "pbag"  4 buildBag  (pbags pdta1)+    , buildSubchunk "pmod" 10 buildMod  (pmods pdta1)+    , buildSubchunk "pgen"  4 buildGen  (pgens pdta1)+    , buildSubchunk "inst" 22 buildInst (insts pdta1)+    , buildSubchunk "ibag"  4 buildBag  (ibags pdta1)+    , buildSubchunk "imod" 10 buildMod  (imods pdta1)+    , buildSubchunk "igen"  4 buildGen  (igens pdta1)    +    , buildSubchunk "shdr" 46 buildShdr (shdrs pdta1)         ]  -- For some subchunks minimal number of records is two -- but this check can be done later I am skiping it here parseSubchunk :: String -> Word -> (Parser a) -> Parser (Array Word a) parseSubchunk s size p = do-  string s+  _ <- string s   chunkSize <- expect (\w -> mod w size == 0) (getWord32le >>= return . fromIntegral)   let n = div chunkSize size   cs <- sequence (genericReplicate n p)@@ -773,9 +773,9 @@   , int16le 40 >> getInt16le  >>= return . KeyToVolEnvDecay . fromIntegral        , int16le 41 >> getWord16le >>= return . InstIndex . fromIntegral-  , do int16le 43; a <- getWord8 >>= return . fromIntegral;+  , do _ <- int16le 43; a <- getWord8 >>= return . fromIntegral;        b <- getWord8 >>= return . fromIntegral; return $ KeyRange a b;-  , do int16le 44; a <- getWord8 >>= return . fromIntegral;+  , do _ <- int16le 44; a <- getWord8 >>= return . fromIntegral;        b <- getWord8 >>= return . fromIntegral; return $ VelRange a b;        , int16le 45 >> getInt16le  >>= return . LoopStartAddressCoarseOffset . fromIntegral@@ -787,7 +787,7 @@   , int16le 51 >> getInt16le  >>= return . CoarseTune . fromIntegral   , int16le 52 >> getInt16le  >>= return . FineTune . fromIntegral   , int16le 53 >> getWord16le >>= return . SampleIndex . fromIntegral-  , do int16le  54;  a <- getInt16le;+  , do _ <- int16le  54;  a <- getInt16le;        case a of          1 -> return $ SampleMode Audio.ContLoop          3 -> return $ SampleMode Audio.PressLoop@@ -926,14 +926,3 @@     , putWord16le $ fromIntegral $ sampleLink shdr     , putWord16le $ fromIntegral $ sampleType shdr     ]---- data SampleType = ---  MonoSample |---   RightSample |---   LeftSample |---   LinkedSample |---   RomMonoSample |---   RomRightSample |---   RomLeftSample |---   RomLinkedSample---   deriving Show

@@ -30,8 +30,9 @@ import Data.Int import qualified Data.ByteString.Lazy as L import Data.Monoid-import Data.List-import Data.Array.Diff+import Data.Array.Unboxed+import Data.Array.IO+import Data.Bits   import Control.Monad@@ -65,37 +66,38 @@ parserSelector :: (Audible a, AudibleInWav a) => Int -> Parser a parserSelector 8  = (parseSample :: Parser Word8) >>= return . fromSample . toSample parserSelector 16 = (parseSample :: Parser Int16) >>= return . fromSample . toSample+parserSelector 24 = ((getWord24le >>= return . fromIntegral . (flip shiftL) 8) :: Parser Int32) >>= return . fromSample . toSample parserSelector 32 = (parseSample :: Parser Int32) >>= return . fromSample . toSample parserSelector 64 = (parseSample :: Parser Int64) >>= return . fromSample . toSample-parserSelector n = fail $ show n ++ " bitsPerSample is not supported"+parserSelector n  = fail $ show n ++ " bitsPerSample is not supported"  bytesPerSample :: (AudibleInWav a) => a -> Int bytesPerSample a = div (bitsPerSample a) 8  -importFile :: (IArray DiffUArray a, Audible a, AudibleInWav a) => FilePath -> IO (Either String (Audio a))+importFile :: (MArray IOUArray a IO, IArray UArray a, Audible a, AudibleInWav a) => FilePath -> IO (Either String (Audio a)) importFile n = do   bs <- L.readFile n   return $! runParser parseWav bs -exportFile :: (IArray DiffUArray a, Audible a, AudibleInWav a) => FilePath -> Audio a ->  IO ()+exportFile :: (IArray UArray a, Audible a, AudibleInWav a) => FilePath -> Audio a ->  IO () exportFile f w = L.writeFile f (toLazyByteString $ buildWav w)  -- All numerical values are stored in little endian format ---parseWav :: (IArray DiffUArray a, Audible a, AudibleInWav a) => Parser (Audio a)+parseWav :: (MArray IOUArray a IO, IArray UArray a, Audible a, AudibleInWav a) => Parser (Audio a) parseWav = do-  string "RIFF"+  _ <- string "RIFF" --  n <- remaining --  expect (\w -> fromIntegral w ==  n - 4) getWord32le-  getWord32le -- chunkSize-  string "WAVE"-  many parseUnknownChunk-  (sampleRate,channelNumber,bitsPerSample) <- parseFmt-  many parseUnknownChunk-  sampleData <- parseData channelNumber bitsPerSample-  return $! (Audio sampleRate channelNumber sampleData)+  _ <- getWord32le -- chunkSize+  _ <- string "WAVE"+  _ <- many parseUnknownChunk+  (sampleRate1,channelNumber1,bitsPerSample1) <- parseFmt+  _ <- many parseUnknownChunk+  sampleData1 <- parseData channelNumber1 bitsPerSample1+  return $! (Audio sampleRate1 channelNumber1 sampleData1) -buildWav :: (IArray DiffUArray a, Audible a, AudibleInWav a) => Audio a -> Builder+buildWav :: (IArray UArray a, Audible a, AudibleInWav a) => Audio a -> Builder buildWav a = mconcat [     putString "RIFF"   , putWord32le $ fromIntegral chunkSize@@ -113,22 +115,22 @@  parseFmt :: Parser (Int,Int,Int) parseFmt = do-  string "fmt "+  _ <- string "fmt "   chunkSize <- getWord32le >>= return . fromIntegral-  word16le 1 -- compression code-  channelNumber <- getWord16le >>= return . fromIntegral-  sampleRate <- getWord32le >>= return . fromIntegral+  _ <- word16le 1 -- compression code+  channelNumber1 <- getWord16le >>= return . fromIntegral+  sampleRate1 <- getWord32le >>= return . fromIntegral   avgBytesPerSec <- getWord32le >>= return . fromIntegral   bytesPerSampleSlice <- getWord16le >>= return . fromIntegral-  when (avgBytesPerSec /= sampleRate * bytesPerSampleSlice) $ +  when (avgBytesPerSec /= sampleRate1 * bytesPerSampleSlice) $      fail "avgBytesPerSec /= sampleRate * bytesPerSampleSlise"-  bitsPerSample <- expect (\w -> (mod w 8 == 0) && w <= 64) getWord16le >>= return . fromIntegral-  when (bytesPerSampleSlice /= (div bitsPerSample 8) * channelNumber) $ +  bitsPerSample1 <- expect (\w -> (mod w 8 == 0) && w <= 64) getWord16le >>= return . fromIntegral+  when (bytesPerSampleSlice /= (div bitsPerSample1 8) * channelNumber1) $      fail "bytesPerSampleSlice /= (div bitsPerSample 8) * channelNumber"   skip (chunkSize - 16) -- skip extra fromat bytes-  return $! (sampleRate,channelNumber,bitsPerSample)+  return $! (sampleRate1,channelNumber1,bitsPerSample1) -buildFmt :: (IArray DiffUArray a, Audible a, AudibleInWav a) => Audio a -> Builder+buildFmt :: (IArray UArray a, Audible a, AudibleInWav a) => Audio a -> Builder buildFmt a = mconcat [     putString   $ "fmt "   , putWord32le $ 16 -- chunk size@@ -146,10 +148,10 @@   bytesPerSampleSlice = bytesPS * channelNumber a   avgBytesPerSec = sampleRate a * bytesPerSampleSlice   -parseData :: (IArray DiffUArray a, Audible a, AudibleInWav a)+parseData :: (MArray IOUArray a IO, IArray UArray a, Audible a, AudibleInWav a)   => Int -> Int -> Parser (SampleData a) parseData cn bitsPS = do-  string "data"+  _ <- string "data"   let bytesPS = div bitsPS 8   chunkSize <- expect (\w -> mod (fromIntegral w) bytesPS == 0) getWord32le                >>= return . fromIntegral@@ -157,7 +159,7 @@   when (mod sn (fromIntegral cn) /= 0) $ fail "mod sampelNumber channelNumber /= 0)"   parseSampleData sn (parserSelector bitsPS)   -buildData :: (IArray DiffUArray a, Audible a, AudibleInWav a) => Audio a -> Builder+buildData :: (IArray UArray a, Audible a, AudibleInWav a) => Audio a -> Builder buildData a = mconcat [     putString "data"   , putWord32le $ fromIntegral $ chunkSize@@ -168,7 +170,7 @@  parseUnknownChunk :: Parser () parseUnknownChunk = do-  expect (\s -> s /= "data" && s /= "fmt ") (getString 4)+  _ <- expect (\s -> s /= "data" && s /= "fmt ") (getString 4)   chunkSize <- getWord32le   skip(fromIntegral chunkSize)   return ()

@@ -21,18 +21,22 @@   , stringNulGen   ) where + import Test.QuickCheck -import Data.Word-import Data.Int import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L-import Data.Array.IArray-import Data.List++import Data.Word+import Data.Int import Data.Char +import Data.List+import Data.Array.IArray+ import System.Random + instance Random Word8 where   randomR = integralRandomR   random = randomR (minBound,maxBound)@@ -70,9 +74,8 @@   random = randomR (minBound,maxBound)  integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)-integralRandomR  (a,b) g = case randomR (fromIntegral a :: Integer,-                                         fromIntegral b :: Integer) g of-                            (x,g) -> (fromIntegral x, g)+integralRandomR  (a,b) g = case randomR (fromIntegral a :: Integer,fromIntegral b :: Integer) g of+                             (x1,g1) -> (fromIntegral x1, g1)  instance Arbitrary Word8 where     arbitrary       = choose (minBound, maxBound)@@ -110,8 +113,6 @@     arbitrary       = choose (minBound, maxBound)     coarbitrary     = undefined ------------------------------------------------------------------------ instance Arbitrary Char where     arbitrary = choose (0, 255) >>= return . toEnum     coarbitrary = undefined@@ -124,8 +125,6 @@   arbitrary = B.pack `fmap` arbitrary   coarbitrary s = coarbitrary (B.unpack s)   ------------------------------------------------ instance (Arbitrary e, Num i, IArray Array e, Ix i) =>  Arbitrary (Array i e) where   arbitrary = do     n <- choose (1, 128)

@@ -3,7 +3,7 @@ -- Module      : Data.Audio -- Copyright   : George Giorgidze -- License     : BSD3--- +-- -- Maintainer  : George Giorgidze <http://cs.nott.ac.uk/~ggg/> -- Stability   : Experimental -- Portability : Portable@@ -12,7 +12,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts, UndecidableInstances  #-}+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Data.Audio (@@ -34,19 +34,26 @@ import Data.ByteString.Parser import Data.ByteString.Builder +import Test.QuickCheck+ import Data.Word import Data.Int-import Data.Array.Diff-import Data.List++import Data.Array.Unboxed+import Data.Array.IO+ import Data.Monoid-import Test.QuickCheck +import System.IO.Unsafe++ type Sample = Double+type SampleData a = UArray Int a  class Audible a where   toSample :: a -> Sample   fromSample :: Sample -> a-  + -- It is required that sampleNummer `mod` channelNumber == 0 data Audio a = Audio {     sampleRate :: Int@@ -54,67 +61,55 @@   , sampleData :: SampleData a   } -instance (Eq a, IArray DiffUArray a) => Eq (Audio a) where+instance (Eq a, IArray UArray a) => Eq (Audio a) where   a1 == a2 = and [       sampleRate a1 == sampleRate a2     , channelNumber a1 == channelNumber a2     , assocs (sampleData a1) == assocs (sampleData a2)] -instance (Eq e, Ix i, IArray (IOToDiffArray a) e) => Eq (IOToDiffArray a i e) where-  a1 == a2 = assocs a1 == assocs a2 -type SampleData a = DiffUArray Int a--instance (Show a, IArray DiffUArray a) => Show (Audio a) where+instance (Show a, IArray UArray a) => Show (Audio a) where   show a = "Sample Rate: " ++ (show $ sampleRate a) ++ "\n" ++            "Channel Number: " ++ (show $ channelNumber a) ++ "\n" ++            "Sample Data Array Bounds: " ++ (show $ bounds $ sampleData a)  -instance (Arbitrary a, IArray DiffUArray a)-  => Arbitrary (Audio a)-  where+instance (Arbitrary a, IArray UArray a) => Arbitrary (Audio a) where   arbitrary = do     sr <- choose (1, 44100 * 8)     cn <- choose (1, 64)     sn <- choose (1, 1024) >>= return . (fromIntegral cn *)     sd <- arrayGen sn-    return $! Audio sr cn sd+    return (Audio sr cn sd)   coarbitrary = undefined -sampleNumber :: (IArray DiffUArray a) => SampleData a -> Int-sampleNumber sd = (snd $ bounds sd) + 1+sampleNumber :: (IArray UArray a) => SampleData a -> Int+sampleNumber sd = (snd (bounds sd)) + 1 -sampleType :: (IArray DiffUArray a) => SampleData a -> a+sampleType :: (IArray UArray a) => SampleData a -> a sampleType sd = undefined `asTypeOf` (sd ! 0) -convert :: (Audible a, Audible b, IArray DiffUArray a, IArray DiffUArray b) => SampleData a -> SampleData b+convert :: (Audible a, Audible b, IArray UArray a, IArray UArray b) => SampleData a -> SampleData b convert sd = amap (fromSample . toSample) sd ---- It is very important to implement this parser efficiently--- It seems that DiffUArray leaks memmory.--- When I am profilling, profiler shows that function retains memmory which is--- a same size as an array created by parser.--- However when I am running compiled binary almoust twice as much memmory is--- consumed from the system, this behaviour seems very strange to me.--- Updating an array every time when sample is parsed--- results in a poor preformance that is why currently I am using--- list buffer and apdating array with 64 samples at once.-parseSampleData :: (IArray DiffUArray a) => Int -> Parser a -> Parser (SampleData a)-parseSampleData sn p = pAux 0 (array (0, sn - 1) []) []+parseSampleData :: (MArray IOUArray a IO, IArray UArray a) => Int -> Parser a -> Parser (SampleData a)+parseSampleData sn p = pAux 0 unsafeNewArray   where-  pAux i acc buf | (i == sn) = return $! acc // buf-  pAux i acc buf | mod i 64 == 0 = do-    s <- p-    let acc' = seq s $ acc // ((i,s) : buf) in seq acc' $ pAux (i + 1) acc' []-  pAux i acc buf = do+  pAux i acc | (i == sn) = seq i $ seq acc $ return acc+  pAux i acc | otherwise = seq i $ seq acc $ do     s <- p-    seq s $ pAux (i + 1) acc ((i,s) : buf)+    seq s (pAux (i + 1) (unsafeWriteArray acc i s)) -buildSampleData :: (IArray DiffUArray a) => (a -> Builder) -> SampleData a -> Builder-buildSampleData b sd = mconcat $ map b $ elems sd  +  unsafeFreezeAux :: (MArray IOUArray a IO, IArray UArray a) => IOUArray Int a -> IO (SampleData a)+  unsafeFreezeAux = unsafeFreeze +  unsafeNewArray         = unsafePerformIO (newArray_ (0, sn - 1) >>= unsafeFreezeAux )+  unsafeWriteArray a i e = unsafePerformIO (do a' <- unsafeThaw a; writeArray a' i e; unsafeFreezeAux a';)+++buildSampleData :: (IArray UArray a) => (a -> Builder) -> SampleData a -> Builder+buildSampleData b = mconcat . map b . elems+ instance Audible Int8 where   toSample a = (fromIntegral a) / (2 ** 7)   fromSample s = round $ s * (2 ** 7)@@ -141,16 +136,15 @@   fromSample s = round $ (s + 1.0) * (2 ** 63)  instance Audible Float where-  toSample = realToFrac +  toSample = realToFrac   fromSample = realToFrac  instance Audible Double where   toSample = id   fromSample = id-  -data SampleMode = NoLoop | ContLoop | PressLoop-  deriving (Eq, Show)-  ++data SampleMode = NoLoop | ContLoop | PressLoop deriving (Eq, Show)+ instance Arbitrary SampleMode where   arbitrary = oneof [return NoLoop, return ContLoop, return PressLoop]   coarbitrary = undefined

@@ -64,13 +64,12 @@  import Foreign import Data.Monoid-import Data.Word import qualified Data.ByteString      as S import qualified Data.ByteString.Lazy as L  import Data.ByteString.Internal (inlinePerformIO,c2w) import qualified Data.ByteString.Internal as S-import qualified Data.ByteString.Lazy.Internal as L+  ------------------------------------------------------------------------ 

@@ -8,7 +8,7 @@ -- Stability   : experimental -- Portability : Portable ----- The Parser monad. A monad for efficiently building structures from+-- A monad for efficiently building structures from -- encoded lazy ByteStrings. -- -----------------------------------------------------------------------------

@@ -37,10 +37,10 @@   -- test (prop_audible :: Word64 -> Bool)   test (prop_audible :: Int8 -> Bool)   test (prop_audible :: Int16 -> Bool)-  test (prop_audible :: Int32 -> Bool)  -  -- test (prop_audible :: Int64 -> Bool)  +  test (prop_audible :: Int32 -> Bool)+  -- test (prop_audible :: Int64 -> Bool) -  -- These to tests are commented, because they fail+  -- These two tests are commented, because they fail   -- Reason for that is the fact that Double is not abble to accomodate   -- 64 bit numbers in full precision   where@@ -51,18 +51,18 @@ testMidi :: IO () testMidi =  do   putStrLn "TESTING PARSING AND BUILDING of Midi"-  +   test $ roundTrip buildMessage (parseMessage Nothing)   test $ roundTrip buildMidi parseMidi   test $ \trk -> trk == fromAbsTime (toAbsTime trk :: Track Ticks)   test $ \trk td -> trk == fromRealTime td (toRealTime td trk)-  +   test $ \m -> (not $ null $ tracks m) ==>                let (Midi SingleTrack _ trks) = toSingleTrack m                in   length (concat $ tracks m) - length (concat trks) == length (tracks m) - 1    c <- readFile "mid.txt"-  let midiFiles = lines c +  let midiFiles = lines c   sequence_ $ map f midiFiles   return ()   where@@ -81,13 +81,13 @@ testWav :: IO () testWav =  do   putStrLn "TESTING PARSING AND BUILDING of Wav"- +   test $ roundTrip (Wav.buildWav :: Audio Word8 -> Builder) Wav.parseWav   test $ roundTrip (Wav.buildWav :: Audio Int16 -> Builder) Wav.parseWav   test $ roundTrip (Wav.buildWav :: Audio Int32 -> Builder) Wav.parseWav    c <- readFile "wav.txt"-  let wavFiles = lines c +  let wavFiles = lines c   sequence_ $ map f wavFiles   return ()   where@@ -100,21 +100,21 @@     putStrLn $ "OK"     putStr "Testing  ... "     when (not $ roundTrip Wav.buildWav Wav.parseWav a) $ fail "Failed\n"-    let sd = (convert $ sampleData a) :: SampleData Word8-    when (not $ roundTrip Wav.buildWav Wav.parseWav (a {sampleData = sd})) $ fail "Failed\n"-    let sd = (convert $ sampleData a) :: SampleData Int32-    when (not $ roundTrip Wav.buildWav Wav.parseWav (a {sampleData = sd})) $ fail "Failed\n"+    let sd1 = (convert $ sampleData a) :: SampleData Word8+    when (not $ roundTrip Wav.buildWav Wav.parseWav (a {sampleData = sd1})) $ fail "Failed\n"+    let sd2 = (convert $ sampleData a) :: SampleData Int32+    when (not $ roundTrip Wav.buildWav Wav.parseWav (a {sampleData = sd2})) $ fail "Failed\n"     putStrLn "OK"     Wav.exportFile ("./tmp/" ++ (takeBaseName n) ++ ".wav") a  testSoundFont :: IO () testSoundFont =  do   putStrLn "TESTING PARSING AND BUILDING of SoundFont"-  +   test $ roundTrip SF.buildSoundFont SF.parseSoundFont- +   c <- readFile "sf2.txt"-  let soundFontFiles = lines c +  let soundFontFiles = lines c   sequence_ $ map f soundFontFiles   return ()   where@@ -128,12 +128,12 @@     putStr "Testing  ... "     when (not $ roundTrip SF.buildSoundFont SF.parseSoundFont sf) $ fail "Failed\n"     putStrLn "OK"-    SF.exportFile ("./tmp/" ++ (takeBaseName n) ++ ".wav") sf+    SF.exportFile ("./tmp/" ++ (takeBaseName n) ++ ".sf2") sf  testParserBuilder :: IO () testParserBuilder = do   putStrLn "TESTING PARSING AND BUILDING OF NUMERICAL TYPES"-  +   test $ roundTrip putWord8 getWord8   test $ roundTrip putWord16be getWord16be   test $ roundTrip putWord16le getWord16le@@ -143,7 +143,7 @@   test $ roundTrip putWord32le getWord32le   test $ roundTrip putWord64be getWord64be   test $ roundTrip putWord64le getWord64le-  +   test $ roundTrip putInt8 getInt8   test $ roundTrip putInt16be getInt16be   test $ roundTrip putInt16le getInt16le@@ -151,27 +151,27 @@   test $ roundTrip putInt32le getInt32le   test $ roundTrip putInt64be getInt64be   test $ roundTrip putInt64le getInt64le-  +   test $ roundTrip putWordHost getWordHost   test $ roundTrip putWord16host getWord16host-  test $ roundTrip putWord32host getWord32host  +  test $ roundTrip putWord32host getWord32host   test $ roundTrip putWord64host getWord64host-  +   test $ roundTrip putVarLenBe getVarLenBe   test $ roundTrip putVarLenLe getVarLenLe-  +   putStrLn "TESTING PARSING AND BUILDING OF String and ByteString"-  +   test $ \s1 s2 -> roundTrip (\s -> putString s `mappend` putString s2) (getString $ length s1) s1   test $ \s1 s2 -> roundTrip (\s -> fromByteString s `mappend` fromByteString s2) (getByteString $ B.length s1) s1   test $ \s1 s2 -> roundTrip (\s -> fromLazyByteString s `mappend` fromLazyByteString s2) (getLazyByteString $  L.length s1) s1-  test $ \bs -> roundTrip fromLazyByteString getRemainingLazyByteString bs  -  +  test $ \bs -> roundTrip fromLazyByteString getRemainingLazyByteString bs + main :: IO () main = do   testAudio   testParserBuilder   testMidi   testWav-  testSoundFont  +  testSoundFont