diff --git a/HCodecs.cabal b/HCodecs.cabal --- a/HCodecs.cabal +++ b/HCodecs.cabal @@ -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: diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2007-2008 George Giorgidze +Copyright (c) 2007-2010 George Giorgidze All rights reserved. diff --git a/src/Codec/Midi.hs b/src/Codec/Midi.hs --- a/src/Codec/Midi.hs +++ b/src/Codec/Midi.hs @@ -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) diff --git a/src/Codec/SoundFont.hs b/src/Codec/SoundFont.hs --- a/src/Codec/SoundFont.hs +++ b/src/Codec/SoundFont.hs @@ -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 diff --git a/src/Codec/Wav.hs b/src/Codec/Wav.hs --- a/src/Codec/Wav.hs +++ b/src/Codec/Wav.hs @@ -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 () diff --git a/src/Data/Arbitrary.hs b/src/Data/Arbitrary.hs --- a/src/Data/Arbitrary.hs +++ b/src/Data/Arbitrary.hs @@ -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) diff --git a/src/Data/Audio.hs b/src/Data/Audio.hs --- a/src/Data/Audio.hs +++ b/src/Data/Audio.hs @@ -3,7 +3,7 @@ -- Module : Data.Audio -- Copyright : George Giorgidze -- License : BSD3 --- +-- -- Maintainer : George Giorgidze -- 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 diff --git a/src/Data/ByteString/Builder.hs b/src/Data/ByteString/Builder.hs --- a/src/Data/ByteString/Builder.hs +++ b/src/Data/ByteString/Builder.hs @@ -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 + ------------------------------------------------------------------------ diff --git a/src/Data/ByteString/Parser.hs b/src/Data/ByteString/Parser.hs --- a/src/Data/ByteString/Parser.hs +++ b/src/Data/ByteString/Parser.hs @@ -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. -- ----------------------------------------------------------------------------- diff --git a/src/Tests/Main.hs b/src/Tests/Main.hs --- a/src/Tests/Main.hs +++ b/src/Tests/Main.hs @@ -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