packages feed

HCodecs (empty) → 0.0.1

raw patch · 11 files changed

+3376/−0 lines, 11 filesdep +QuickCheckdep +arraydep +basesetup-changed

Dependencies added: QuickCheck, array, base, bytestring, random

Files

+ HCodecs.cabal view
@@ -0,0 +1,31 @@+name: HCodecs+version: 0.0.1+cabal-Version: >= 1.2+license: BSD3+license-file: LICENSE+author: George Giorgidze+maintainer: George Giorgidze (GGG at CS dot NOTT dot AC dot UK)+homepage: http://cs.nott.ac.uk/~ggg/+category: Codec+synopsis: The library to read, write and manipulate MIDI, WAV, and SoundFont2 files.+description: The library provides functions to read write and manipulate Midi, Wav and SoundFont2 multimedia file formats.+             It is written entirly 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).+build-type: Simple+extra-source-files: src/Tests/Main.hs++library+  hs-source-dirs:  src+  ghc-options : -Wall -fno-warn-name-shadowing+  build-Depends: base, bytestring, QuickCheck, random, array+  exposed-modules:+    Codec.Midi+    Codec.Wav+    Codec.SoundFont+    +    Data.Audio++    Data.ByteString.Parser+    Data.ByteString.Builder+  other-modules:+    Data.Arbitrary
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2007, George Giorgidze++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 the copyright holder 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 THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 THE COPYRIGHT OWNER OR+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 AND 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.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Codec/Midi.hs view
@@ -0,0 +1,753 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Codec.Midi+-- Copyright   : George Giorgidze+-- License     : BSD3+-- +-- Maintainer  : George Giorgidze <http://cs.nott.ac.uk/~ggg/>+-- Stability   : Experimental+-- Portability : Portable+--+-- Module for reading, writing and maniplating of standard MIDI files.+--+-----------------------------------------------------------------------------++module Codec.Midi +  (+    Midi (..)+  , FileType (..)+  , Track+  , TimeDiv (..)+  , Message (..)+  +  , Ticks+  , Time+  , Channel+  , Key+  , Velocity+  , Pressure+  , Preset+  , Bank+  , PitchWheel+  , Tempo +  +  , isNoteOff+  , isNoteOn+  , isKeyPressure+  , isControlChange+  , isProgramChange+  , isChannelPressure+  , isPitchWheel+  , isChannelMessage+  , isMetaMessage+  , isSysexMessage+  , isTrackEnd+  +  , removeTrackEnds+  , toSingleTrack+  , merge+  , fromAbsTime+  , toAbsTime+  , toRealTime+  , fromRealTime+  +  , importFile+  , exportFile+  , parseMidi+  , buildMidi+  , parseTrack+  , buildTrack+  , parseMessage+  , buildMessage+  )+   where++import Data.ByteString.Parser+import Data.ByteString.Builder+import Data.Arbitrary ()++import Data.Word
+import qualified Data.ByteString.Lazy as L+import Data.Bits+import Data.Maybe+import Data.List+import Data.Monoid+import Control.Applicative+import Control.Monad+import Test.QuickCheck+++data Midi = Midi {+    fileType :: FileType+  , timeDiv :: TimeDiv+  , tracks :: [Track Ticks]+  } deriving (Eq, Show)++instance Arbitrary Midi where+  arbitrary = do+    ft <- arbitrary+    td <- arbitrary+    if ft == SingleTrack+      then do+        trk <- arbitrary >>= return . fAux+        return $! Midi ft td [trk]+      else do+        trks <- arbitrary >>= return . map fAux+        return $! Midi ft td trks+    where+    fAux = (++ [(0,TrackEnd)]) . map (\(dt,m) -> (abs dt,m)) . removeTrackEnds +  coarbitrary = undefined++data FileType = SingleTrack | MultiTrack | MultiPattern+  deriving (Eq, Show)++instance Arbitrary FileType where+  arbitrary = oneof [return SingleTrack , return MultiTrack , return MultiPattern]+  coarbitrary = undefined+  +type Track a = [(a,Message)]++data TimeDiv =+  TicksPerBeat Int | -- 1 -- (2^15 - 1)+  TicksPerSecond Int Int -- 1 - 127+             --  FramesPerSecond TicksPerFrame+  deriving (Show,Eq)++instance Arbitrary TimeDiv where+  arbitrary = oneof [+      choose (1,2 ^ (15 :: Int) - 1) >>= return . TicksPerBeat+    , two (choose (1,127)) >>= \(w1,w2) -> return $! TicksPerSecond w1 w2]+  coarbitrary = undefined++type Ticks = Int -- 0 - (2^28 - 1)+type Time = Double++type Channel = Int -- 0 - 15+type Key = Int -- 0 - 127+type Velocity = Int	-- 0 - 127+type Pressure = Int -- 0 - 127+type Preset = Int	-- 0 - 127+type Bank = Int+type PitchWheel = Int	-- 0 - (2^14 - 1)+type Tempo = Int -- microseconds per beat  1 - (2^24 - 1) ++data Message =+-- Channel Messages+  NoteOff         { channel :: !Channel, key :: !Key,              velocity :: !Velocity } |+  NoteOn          { channel :: !Channel, key :: !Key,              velocity :: !Velocity } |+  KeyPressure     { channel :: !Channel, key :: !Key,              pressure :: !Pressure} |+  ControlChange   { channel :: !Channel, controllerNumber :: !Int, controllerValue :: !Int } |+  ProgramChange   { channel :: !Channel, preset :: !Preset } |+  ChannelPressure { channel :: !Channel, pressure :: !Pressure } |+  PitchWheel      { channel :: !Channel, pitchWheel :: !PitchWheel } |+-- Meta Messages+  SequenceNumber !Int | -- 0 - (2^16 - 1) +  Text !String |+  Copyright !String |+  TrackName !String |+  InstrumentName !String |+  Lyrics !String |+  Marker !String |+  CuePoint !String |+  ChannelPrefix !Channel |+  ProgramName !String |+  DeviceName !String |+  TrackEnd |+  TempoChange !Tempo |+  SMPTEOffset !Int !Int !Int !Int !Int | -- 0-23  0-59  0-59  0-30 0-99+  TimeSignature !Int !Int !Int !Int | -- 0-255  0-255   0-255   1-255+  KeySignature !Int !Int | -- -7 - 7  0 - 1+  Reserved !Int !L.ByteString |+  -- System Exclusive Messages+  Sysex !Int !L.ByteString -- 0xF0 or 0xF7+  deriving (Show,Eq)++instance Arbitrary Message where+  arbitrary = do+    -- Channel Messages+    c <- choose (0,15)+    oneof [+        two (choose (0,127))  >>= \(w2,w3) -> return $! NoteOff c w2 w3+      , two (choose (0,127))  >>= \(w2,w3) -> return $! NoteOn c w2 w3+      , two (choose (0,127))  >>= \(w2,w3) -> return $! KeyPressure c w2 w3+      , two (choose (0,127))  >>= \(w2,w3) -> return $! ControlChange c w2 w3+      , choose (0,127)        >>= \w2      -> return $! ProgramChange c w2+      , choose (0,127)        >>= \w2      -> return $! ChannelPressure c w2 +      , do p <- choose (0,2 ^ (14 :: Int) - 1)+           return $! PitchWheel c p+      -- Meta Messages+      , choose (0,2 ^ (16 :: Int) - 1) >>= return . SequenceNumber+      , arbitrary >>= return . Text+      , arbitrary >>= return . Copyright+      , arbitrary >>= return . TrackName+      , arbitrary >>= return . InstrumentName+      , arbitrary >>= return . Lyrics+      , arbitrary >>= return . Marker+      , arbitrary >>= return . CuePoint+      , return $! ChannelPrefix c+      , arbitrary >>= return . ProgramName+      , arbitrary >>= return . DeviceName+      , choose (0,2 ^ (14 :: Int) - 1) >>= return . TempoChange+      , do w1 <- choose (0,23)+           w2 <- choose (0,59)+           w3 <- choose (0,59)+           w4 <- choose (0,30)+           w5 <- choose (0,99)+           return $! SMPTEOffset w1 w2 w3 w4 w5+      , do w1 <- choose (0,255)+           w2 <- choose (0,255)+           w3 <- choose (0,255)+           w4 <- choose (1,255)+           return $! TimeSignature w1 w2 w3 w4+      , do w1 <- choose (-7,7)+           w2 <- choose (0,1)+           return $! KeySignature w1 w2+      , arbitrary >>= \bs -> return $! Reserved 0x60 bs+      -- System Exclusive Messages+      , do w <- oneof [return 0xF0, return 0xF7]+           bs <- arbitrary+           return $! Sysex w bs]+  coarbitrary = undefined++isNoteOff :: Message -> Bool+isNoteOff (NoteOff {}) = True+isNoteOff _ = False++isNoteOn :: Message -> Bool+isNoteOn (NoteOn {}) = True+isNoteOn _ = False++isKeyPressure :: Message -> Bool+isKeyPressure (KeyPressure {}) = True+isKeyPressure _ = False++isControlChange :: Message -> Bool+isControlChange (ControlChange {}) = True+isControlChange _ = False++isProgramChange :: Message -> Bool+isProgramChange (ProgramChange {}) = True+isProgramChange _ = False++isChannelPressure :: Message -> Bool+isChannelPressure (ChannelPressure {}) = True+isChannelPressure _ = False++isPitchWheel :: Message -> Bool+isPitchWheel (PitchWheel {}) = True+isPitchWheel _ = False++isChannelMessage :: Message -> Bool+isChannelMessage msg = (not $ isMetaMessage msg) && (not $ isSysexMessage msg)++isSysexMessage :: Message -> Bool+isSysexMessage (Sysex _ _) = True+isSysexMessage _ = False++isMetaMessage :: Message -> Bool+isMetaMessage msg = case msg of+  SequenceNumber _ -> True+  Text _ -> True+  Copyright _ -> True+  TrackName _ -> True+  InstrumentName _ -> True+  Lyrics _ -> True+  Marker _ -> True+  CuePoint _ -> True+  ChannelPrefix _ -> True+  ProgramName _ -> True+  DeviceName _ -> True+  TrackEnd -> True+  TempoChange _ -> True+  SMPTEOffset _ _ _ _ _ -> True+  TimeSignature _ _ _ _ -> True+  KeySignature _ _ -> True+  Reserved _ _ -> True+  _ -> False++isTrackEnd :: Message -> Bool+isTrackEnd TrackEnd = True+isTrackEnd _ = False++removeTrackEnds :: Track a -> Track a+removeTrackEnds [] = []+removeTrackEnds trk = filter (not. isTrackEnd . snd) trk++toSingleTrack :: Midi -> Midi+toSingleTrack m@(Midi SingleTrack _ _) = m+toSingleTrack (Midi MultiTrack td trks) = Midi SingleTrack td [trk']+  where trk' = foldl' merge [] trks+toSingleTrack (Midi MultiPattern td trks) = Midi SingleTrack td [trk']+  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)]+  where+  trk1' = toAbsTime $ removeTrackEnds trk1+  trk2' = toAbsTime $ removeTrackEnds trk2+  f trk [] = trk+  f [] trk = trk+  f ((dt1,m1) : trk1) ((dt2,m2) : trk2) = if dt1 <= dt2+      then (dt1,m1) : (f trk1 ((dt2,m2) : trk2))+      else (dt2,m2) : (f ((dt1,m1) : trk1) trk2)++toAbsTime :: (Num a) => Track a -> Track a+toAbsTime trk = zip ts' ms+  where+  (ts,ms) = unzip trk+  (_,ts') = mapAccumL (\acc t -> let t' = acc + t in (t',t')) 0 ts +  +fromAbsTime :: (Num a) => Track a -> Track a+fromAbsTime trk = zip ts' ms +  where+  (ts,ms) = unzip trk+  (_,ts') = mapAccumL (\acc t -> (t,t - acc)) 0 ts ++toRealTime :: TimeDiv -> Track Ticks -> Track Time+toRealTime (TicksPerBeat tpb) trk = trk'+  where+  (_,trk') = mapAccumL f (div 60000000 120) trk -- default tempo 120 beats per minute+  formula dt tempo = +    (fromIntegral dt / fromIntegral tpb) * (fromIntegral tempo) * (1.0E-6)+  f :: Tempo -> (Ticks,Message) -> (Tempo, (Time,Message))+  f _ (dt, TempoChange tempo) = (tempo, (formula dt tempo, TempoChange tempo))+  f tempo (dt,msg) = (tempo, (formula dt tempo,msg))+toRealTime (TicksPerSecond fps tpf) trk = map f trk+  where+  f (dt,msg) = (fromIntegral dt / (fromIntegral fps * fromIntegral tpf), msg)++fromRealTime :: TimeDiv -> Track Time -> Track Ticks+fromRealTime (TicksPerBeat tpb) trk = trk'+  where+  (_,trk') = mapAccumL f (div 60000000 120) trk -- default tempo 120 beats per minute+  formula dt tempo = round $ +    (dt * fromIntegral tpb) / (fromIntegral tempo * 1.0E-6)+  f :: Tempo -> (Time,Message) -> (Tempo, (Ticks,Message))+  f _ (dt, TempoChange tempo) = (tempo, (formula dt tempo, TempoChange tempo))+  f tempo (dt,msg) = (tempo, (formula dt tempo,msg))+fromRealTime (TicksPerSecond fps tpf) trk = map f trk+  where+  f (dt,msg) = (round $ dt * fromIntegral fps * fromIntegral tpf, msg)++-- MIDI import +importFile :: FilePath -> IO (Either String Midi)+importFile f = do+  bs <- L.readFile f+  return $! runParser parseMidi bs++exportFile :: FilePath -> Midi ->  IO ()+exportFile f m = do+  let bs = toLazyByteString $ buildMidi m+  L.writeFile f bs ++-- All numeric values are stored in big-endian format++parseMidi :: Parser Midi+parseMidi = do+  string "MThd"+  word32be 6+  formatType' <- getWord16be+  trackNumber' <- getWord16be+  timeDivision' <- getWord16be+  let timeDivision = if testBit timeDivision' 15+        then TicksPerSecond+               (fromIntegral $ (flip shiftR) 9  $ shiftL timeDivision' 1)+               (fromIntegral $ (flip shiftR) 8  $ shiftL timeDivision' 8)+        else TicksPerBeat (fromIntegral timeDivision')+  case (formatType',trackNumber') of+    (0,1) -> do+      track' <- parseTrack+      return $! Midi SingleTrack timeDivision [track']+    (1,n) -> do+      tracks' <- sequence $ replicate (fromIntegral n) parseTrack+      return $! Midi MultiTrack timeDivision tracks'+    (2,n) -> do+      tracks' <- sequence $ replicate (fromIntegral n) parseTrack+      return $! Midi MultiPattern timeDivision tracks'+    _ -> fail "Invalid Midi file format"++buildMidi :: Midi -> Builder+buildMidi m = mconcat [+    putString "MThd"+  , putWord32be 6+  , case fileType m of+      SingleTrack -> putWord16be 0 +      MultiTrack -> putWord16be 1+      MultiPattern -> putWord16be 2+  , putWord16be (fromIntegral $ length $ tracks m)+  , case timeDiv m of+      TicksPerBeat i -> putWord16be (fromIntegral i)+      TicksPerSecond i1 i2 -> mconcat [+          putWord8 (setBit (fromIntegral i1) 7)+        , putWord8 (fromIntegral i2)]+  , mconcat (map buildTrack $ tracks m)]+  +parseTrack :: Parser (Track Ticks)+parseTrack = do+  string "MTrk"+  getWord32be -- trackSize +  track' <- parseMessages Nothing+  return track'+ +buildTrack :: Track Ticks -> Builder+buildTrack trk = mconcat [+    putString "MTrk"+  , putWord32be $ fromIntegral $ L.length bs+  , fromLazyByteString bs]+  where+  f (dt,msg) = (putVarLenBe $ fromIntegral dt) `append` buildMessage msg +  bs = toLazyByteString $ mconcat (map f trk)++parseMessages :: Maybe Message -> Parser (Track Ticks)+parseMessages mPreMsg = do+  dt <- getVarLenBe >>= return . fromIntegral +  msg <- parseMessage mPreMsg+  if (isTrackEnd msg)+    then return [(dt,msg)]+    else do+      let mMsg = if isChannelMessage msg then (Just msg) else mPreMsg+      msgs <- parseMessages mMsg+      return $! (dt,msg) : msgs++parseMessage :: Maybe Message -> Parser Message+parseMessage mPreMsg = choice [+      parseChannelMessage mPreMsg+    , parseMetaMessage+    , parseSysexMessage]+  +buildMessage :: Message -> Builder+buildMessage msg | isChannelMessage msg = buildChannelMessage msg+buildMessage msg | isMetaMessage msg = buildMetaMessage msg+buildMessage msg | isSysexMessage msg = buildSysexMessage msg+buildMessage _ = mempty+  +parseChannelMessage :: Maybe Message -> Parser Message+parseChannelMessage mPreMsg = choice $ map (\f -> f mPreMsg) [+      parseNoteOff+    , parseNoteOn+    , parseKeyPressure+    , parseControlChange+    , parseProgramChange+    , parseChannelPressure+    , parsePitchWheel+  ]++parseChannel :: Maybe Message -> (Message -> Bool) -> Word8 -> Parser Channel+parseChannel mPreMsg isNeededMsg msgCode = p1 <|> p2+  where+  p1 = do+    lookAhead (satisfy ( < 0x80))+    guard $ (isJust mPreMsg) && (isNeededMsg $ fromJust mPreMsg)+    return $! channel (fromJust mPreMsg)+  p2 = do+    w8 <- getWord8+    guard (msgCode == shiftR w8 4)+    return $! fromIntegral $ w8 .&. (0x0F :: Word8)++parseNoteOff :: Maybe Message -> Parser Message+parseNoteOff mPreMsg = do+  ch <- parseChannel mPreMsg isNoteOff 0x08+  p1 <- getWord8+  p2 <- getWord8+  return $! NoteOff ch (fromIntegral p1) (fromIntegral p2)++parseNoteOn :: Maybe Message -> Parser Message+parseNoteOn mPreMsg = do+  ch <- parseChannel mPreMsg isNoteOn 0x09+  p1 <- getWord8+  p2 <- getWord8+  return $! NoteOn ch (fromIntegral p1) (fromIntegral p2)++parseKeyPressure :: Maybe Message -> Parser Message+parseKeyPressure mPreMsg = do+  ch <- parseChannel mPreMsg isKeyPressure 0x0A+  p1 <- getWord8+  p2 <- getWord8+  return $! KeyPressure ch (fromIntegral p1) (fromIntegral p2)++parseControlChange :: Maybe Message -> Parser Message+parseControlChange mPreMsg = do+  ch <- parseChannel mPreMsg isControlChange 0x0B+  p1 <- getWord8+  p2 <- getWord8+  return $! ControlChange ch (fromIntegral p1) (fromIntegral p2)++parseProgramChange :: Maybe Message -> Parser Message+parseProgramChange mPreMsg = do+  ch <- parseChannel mPreMsg isProgramChange 0x0C+  p1 <- getWord8+  return $! ProgramChange ch (fromIntegral p1)++parseChannelPressure :: Maybe Message -> Parser Message+parseChannelPressure mPreMsg = do+  ch <- parseChannel mPreMsg isChannelPressure 0x0D+  p1 <- getWord8+  return $! ChannelPressure ch (fromIntegral p1)+  +parsePitchWheel :: Maybe Message -> Parser Message+parsePitchWheel mPreMsg = do+  ch <- parseChannel mPreMsg isPitchWheel 0x0E+  p1 <- getWord8+  p2 <- getWord8+  return $! PitchWheel ch $ (shiftL (fromIntegral p2) 7) .|. (fromIntegral p1)++buildChannelMessage :: Message -> Builder+buildChannelMessage msg = case msg of+  NoteOff         _ p1 p2  -> mconcat+    [f 0x08, putWord8 $ fromIntegral $ p1, putWord8 $ fromIntegral $ p2]+  NoteOn          _ p1 p2  -> mconcat+    [f 0x09, putWord8 $ fromIntegral $ p1, putWord8 $ fromIntegral $ p2]+  KeyPressure     _ p1 p2  -> mconcat+    [f 0x0A, putWord8 $ fromIntegral $ p1, putWord8 $ fromIntegral $ p2]+  ControlChange   _ p1 p2  -> mconcat+    [f 0x0B, putWord8 $ fromIntegral $ p1, putWord8 $ fromIntegral $ p2]+  ProgramChange   _ p1     -> mconcat [f 0x0C, putWord8 $ fromIntegral $ p1]+  ChannelPressure _ p1     -> mconcat [f 0x0D, putWord8 $ fromIntegral $ p1]+  PitchWheel      _ p1     -> mconcat [ f 0x0E+                                      , putWord8 (fromIntegral $ p1 .&. 0x7F)+                                      , putWord8 (fromIntegral $ shiftR p1 7)]+  _ -> mempty+  where+  f :: Int -> Builder+  f w8 = putWord8 $ fromIntegral $ (shiftL w8 4) .|. (channel msg)+  +parseMetaMessage :: Parser Message+parseMetaMessage = do+  word8 0xFF+  choice [+      parseSequenceNumber+    , parseText+    , parseCopyright+    , parseTrackName+    , parseInstrumentName+    , parseLyrics+    , parseMarker+    , parseCuePoint+    , parseChannelPrefix+    , parseProgramName+    , parseDeviceName+    , parseTrackEnd+    , parseTempoChange+    , parseSMPTEOffset+    , parseTimeSignature+    , parseKeySignature+    , parseReserved+    ]++buildMetaMessage :: Message -> Builder+buildMetaMessage msg = putWord8 0xFF `mappend`+  case msg of+    SequenceNumber i -> mconcat+      [putWord8 0x00, putVarLenBe 2, putWord16be $ fromIntegral $ i]+    Text s -> mconcat +      [putWord8 0x01, putVarLenBe (fromIntegral $ length s), putString s]+    Copyright s -> mconcat+      [putWord8 0x02, putVarLenBe (fromIntegral $ length s), putString s]+    TrackName s -> mconcat+      [putWord8 0x03, putVarLenBe (fromIntegral $ length s), putString s]+    InstrumentName s -> mconcat+      [putWord8 0x04, putVarLenBe (fromIntegral $ length s), putString s]+    Lyrics s -> mconcat+      [putWord8 0x05, putVarLenBe (fromIntegral $ length s), putString s]+    Marker s -> mconcat+      [putWord8 0x06, putVarLenBe (fromIntegral $ length s), putString s]+    CuePoint s -> mconcat+      [putWord8 0x07, putVarLenBe (fromIntegral $ length s), putString s]+    ProgramName s -> mconcat+      [putWord8 0x08, putVarLenBe (fromIntegral $ length s), putString s]+    DeviceName s -> mconcat+      [putWord8 0x09, putVarLenBe (fromIntegral $ length s), putString s]+    ChannelPrefix i -> mconcat+      [putWord8 0x20, putVarLenBe 1, putWord8 $ fromIntegral $ i]+    TrackEnd -> putWord8 0x2F `mappend` putVarLenBe 0+    TempoChange i -> mconcat+      [putWord8 0x51, putVarLenBe 3, putWord24be $ fromIntegral $ i]+    SMPTEOffset i1 i2 i3 i4 i5 -> mconcat [+        putWord8 0x54+      , putVarLenBe 5+      , mconcat $ map (putWord8 . fromIntegral) [i1,i2,i3,i4,i5]]+    TimeSignature i1 i2 i3 i4 -> mconcat [+        putWord8 0x58+      , putVarLenBe 4+      , mconcat $ map (putWord8 . fromIntegral) [i1,i2,i3,i4]]+    KeySignature i1 i2 -> mconcat [+        putWord8 0x59+      , putVarLenBe 2+      , putInt8  $ fromIntegral $ i1+      , putWord8 $ fromIntegral $ i2]+    Reserved w bs -> mconcat [+        putWord8 (fromIntegral w)+      , putVarLenBe (fromIntegral $ L.length bs)+      , fromLazyByteString bs]+    _ -> mempty  ++parseSequenceNumber :: Parser Message+parseSequenceNumber = do+  word8 0x00+  varLenBe 2+  n <- getWord16be+  return $! SequenceNumber (fromIntegral n)++parseText :: Parser Message+parseText = do+  word8 0x01+  l <- getVarLenBe+  s <- getString (fromIntegral l)+  return $! Text s++parseCopyright :: Parser Message+parseCopyright = do+  word8 0x02+  l <- getVarLenBe+  s <- getString (fromIntegral l)+  return $! Copyright s++parseTrackName :: Parser Message+parseTrackName = do+  word8 0x03+  l <- getVarLenBe+  s <- getString (fromIntegral l)+  return $! TrackName s++parseInstrumentName :: Parser Message+parseInstrumentName = do+  word8 0x04+  l <- getVarLenBe+  s <- getString (fromIntegral l)+  return $! InstrumentName s++parseLyrics :: Parser Message+parseLyrics = do+  word8 0x05+  l <- getVarLenBe+  s <- getString (fromIntegral l)+  return $! Lyrics s++parseMarker :: Parser Message+parseMarker = do+  word8 0x06+  l <- getVarLenBe+  s <- getString (fromIntegral l)+  return $! Marker s++parseCuePoint :: Parser Message+parseCuePoint = do+  word8 0x07+  l <- getVarLenBe+  s <- getString (fromIntegral l)+  return $! CuePoint s++parseProgramName :: Parser Message+parseProgramName = do+  word8 0x08+  l <- getVarLenBe+  s <- getString (fromIntegral l)+  return $! ProgramName s++parseDeviceName :: Parser Message+parseDeviceName = do+  word8 0x09+  l <- getVarLenBe+  s <- getString (fromIntegral l)+  return $! DeviceName s++parseChannelPrefix :: Parser Message+parseChannelPrefix = do+  word8 0x20+  varLenBe 1+  p <- getWord8+  return $! ChannelPrefix (fromIntegral p)++parseTrackEnd :: Parser Message+parseTrackEnd =  do+  word8 0x2F+  varLenBe 0+  return $! TrackEnd++parseTempoChange :: Parser Message+parseTempoChange = do+  word8 0x51+  varLenBe 3+  t <- getWord24be+  return $! TempoChange (fromIntegral t)++parseSMPTEOffset :: Parser Message+parseSMPTEOffset = do+  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+  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+  n1 <- getInt8+  n2 <- getWord8+  return $! KeySignature (fromIntegral n1) (fromIntegral n2)++parseReserved :: Parser Message+parseReserved = do+  t <- getWord8+  l <- getVarLenBe+  bs <- getLazyByteString (fromIntegral l)+  return $! Reserved (fromIntegral t)  bs++parseSysexMessage :: Parser Message+parseSysexMessage = do+  w <- (word8 0xF0) <|> (word8 0xF7)+  l <- getVarLenBe+  d <- getLazyByteString (fromIntegral l)+  return $! Sysex (fromIntegral w) d++buildSysexMessage :: Message -> Builder+buildSysexMessage (Sysex i bs) =+  mconcat [ putWord8 $ fromIntegral $ i+          , putVarLenBe $ fromIntegral $ L.length bs+          , fromLazyByteString bs]+buildSysexMessage _ = mempty++--str2key :: String -> Key+--str2key s = case s of+--  "p" -> 64+--  "0" -> 63+--  "o" -> 62+--  "9" -> 61+--  "i" -> 60+--  "u" -> 59+--  "7" -> 58+--  "y" -> 57+--  "6" -> 56+--  "t" -> 55+--  "5" -> 54+--  "r" -> 53+--  "e" -> 52+--  "3" -> 51+--  "w" -> 50+--  "2" -> 49+--  "q" -> 48+--  +--  "m" -> 59 - 12+--  "j" -> 58 - 12+--  "n" -> 57 - 12+--  "h" -> 56 - 12+--  "b" -> 55 - 12+--  "g" -> 54 - 12+--  "v" -> 53 - 12+--  "c" -> 52 - 12+--  "d" -> 51 - 12+--  "x" -> 50 - 12+--  "s" -> 49 - 12+--  "z" -> 48 - 12+--  +--  +--  _   -> 0
+ src/Codec/SoundFont.hs view
@@ -0,0 +1,933 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Codec.SoundFont+-- Copyright   : George Giorgidze+-- License     : BSD3+-- +-- Maintainer  : George Giorgidze <http://cs.nott.ac.uk/~ggg/>+-- Stability   : Experimental+-- Portability : Portable+--+-- Module for reading and writting of SoundFont instrument description files.+--+-----------------------------------------------------------------------------++module Codec.SoundFont (+    SoundFont (..)+  , Info (..)+  , Sdta (..)+  , Pdta (..)+  , Phdr (..)+  , Bag (..)+  , Mod (..)+  , Generator (..)+  , Inst (..)+  , Shdr (..)+  , importFile+  , exportFile+  , parseSoundFont+  , buildSoundFont+  , parseInfos+  , buildInfos+  , parseSdta+  , buildSdta+  , parsePdta+  , buildPdta+  )  where++import Data.ByteString.Parser+import Data.ByteString.Builder+import Data.Arbitrary+import qualified Data.Audio as Audio++import Data.Word+import Data.Int+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Internal (w2c)+import Data.Array.IArray+import Data.List++import Test.QuickCheck+import Data.Monoid+import Control.Applicative+import Control.Monad++data SoundFont = SoundFont {+    infos :: Array Word Info -- Suplemental information+  , sdta  :: Sdta -- The Sample Binary Data+  , pdta :: Pdta +  -- articulation :: Articulation -- The Preset, Instrument, and Sample Header data+  } deriving (Eq, Show)++instance Arbitrary SoundFont where+  arbitrary = do+    f1 <- arbitrary; f2 <- arbitrary; f3 <- arbitrary;+    return $! SoundFont f1 f2 f3+  coarbitrary = undefined++-- instance Show SoundFont where+--   show sf = (show $ length $ elems $ sampleData sf) ++ "\n" ++ (show $ length $ show $ articulation sf) ++ "\n"++-- type SamplePointIndex = Word32+-- type SampleData = UArray SamplePointIndex Audio.Sample++data Info = +    Version Word Word -- Refers to file version of SounfFont RIFF file+  | TargetSoundEngine String -- Refers to target Sound Engine+  | BankName String -- Refers to SoundFont Bank Name+  | RomName String -- Refers to Sound ROM Name+  | RomVersion Word Word -- Refers to Sound ROM Version+  | CreationDate String -- Refers to Date of Creation of the Bank+  | Authors String -- Sound Designers and Engineers of the Bank+  | IntendedProduct String -- Product fot which the bank was intended+  | CopyrightMessage String -- Contains any copyright message+  | Comments String -- Contains any comemnts on the Bank+  | UsedTools String -- The SoundFont tools used to create and alter the bank+  | ReservedInfo String Word L.ByteString+  deriving (Eq,Show)++instance Arbitrary Info where+  arbitrary = oneof [+      do (w1,w2) <- two $ choose (minBound :: Word16, maxBound);+         return $ Version (fromIntegral w1) (fromIntegral w2);+    , do l <- choose (0,255); s <- genStringNul l; return  $ TargetSoundEngine s+    , do l <- choose (0,255); s <- genStringNul l; return  $ BankName s+    , do l <- choose (0,255); s <- genStringNul l; return  $ RomName s+    , do (w1,w2) <- two $ choose (minBound :: Word16, maxBound);+         return $ RomVersion (fromIntegral w1) (fromIntegral w2);+    , do l <- choose (0,255); s <- genStringNul l; return  $ CreationDate s+    , do l <- choose (0,255); s <- genStringNul l; return  $ Authors s+    , do l <- choose (0,255); s <- genStringNul l; return  $ IntendedProduct s+    , do l <- choose (0,255); s <- genStringNul l; return  $ CopyrightMessage s    +    , do l <- choose (0,255); s <- genStringNul l; return  $ Comments s+    , do l <- choose (0,255); s <- genStringNul l; return  $ UsedTools s+    , do l <- choose (0,255); s <- vector (fromIntegral l);+         return  $ ReservedInfo "RSRV" l (L.pack s)]+    where+    genStringNul :: Int -> Gen String +    genStringNul l = sequence $ replicate l $ fmap w2c $ choose (1,255)+  coarbitrary = undefined++data Sdta = Sdta {+    smpl :: Audio.SampleData Int16+  , sm24 :: Maybe (Audio.SampleData Int8)+  } deriving (Eq, Show)++instance Arbitrary Sdta where+  arbitrary = do+    sn <- choose (1,1024)+    smpl <- arrayGen sn+    oneof [+        return $! Sdta smpl Nothing+      , do sm24 <- arrayGen sn+           return $! Sdta smpl (Just sm24)+      ]+  coarbitrary = undefined++data Pdta = Pdta {+    phdrs :: Array Word Phdr+  , pbags :: Array Word Bag+  , pmods :: Array Word Mod+  , pgens :: Array Word Generator+  , insts :: Array Word Inst+  , ibags :: Array Word Bag+  , imods :: Array Word Mod+  , igens :: Array Word Generator+  , shdrs :: Array Word Shdr+  } deriving (Eq, Show)+  +instance Arbitrary Pdta where+  arbitrary = do+    f1 <- arbitrary; f2 <- arbitrary; f3 <- arbitrary; f4 <- arbitrary;+    f5 <- arbitrary; f6 <- arbitrary; f7 <- arbitrary; f8 <- arbitrary;+    f9 <- arbitrary;+    return $! Pdta f1 f2 f3 f4 f5 f6 f7 f8 f9+  coarbitrary = undefined++data Phdr = Phdr {+    presetName :: String+  , preset :: Word+  , bank :: Word+  , presetBagNdx :: Word+  , library :: Word+  , genre :: Word+  , morphology :: Word+  } deriving (Eq, Show)++instance Arbitrary Phdr where+  arbitrary = do+    n <- choose (0,20)+    presetName' <- stringNulGen n+    preset' <- choose (minBound :: Word16, maxBound)+    bank' <- choose (minBound :: Word16, maxBound)+    presetBagNdx' <- choose (minBound :: Word16, maxBound)+    library' <- choose (minBound :: Word32, maxBound)+    genre' <- choose (minBound :: Word32, maxBound)+    morphology' <- choose (minBound :: Word32, maxBound)+    return $ Phdr {+        presetName = presetName'+      , preset = fromIntegral $ preset'+      , bank = fromIntegral $ bank'+      , presetBagNdx = fromIntegral $ presetBagNdx'+      , library = fromIntegral $ library'+      , genre = fromIntegral $ genre'+      , morphology = fromIntegral $ morphology'+      }+  coarbitrary = undefined++data Bag = Bag {+    genNdx :: Word+  , modNdx :: Word+  } deriving (Eq, Show)+  +instance Arbitrary Bag where+  arbitrary = do+    genNdx' <- choose (minBound :: Word16, maxBound)+    modNdx' <- choose (minBound :: Word16, maxBound)    +    return $! Bag {+        genNdx = fromIntegral genNdx'+      , modNdx = fromIntegral modNdx'}+  coarbitrary = undefined++data Mod = Mod {+    srcOper :: Word+  , destOper :: Word+  , amount :: Int+  , amtSrcOper :: Word+  , transOper :: Word+  } deriving (Eq, Show)+  +instance Arbitrary Mod where+  arbitrary = do+    srcOper' <- choose (minBound :: Word16, maxBound)+    destOper' <- choose (minBound :: Word16, maxBound)    +    amount' <- choose (minBound :: Int16, maxBound)+    amtSrcOper' <- choose (minBound :: Word16, maxBound)    +    transOper' <- choose (minBound :: Word16, maxBound)                +    return $! Mod {+        srcOper = fromIntegral srcOper'+      , destOper = fromIntegral destOper'+      , amount = fromIntegral amount'+      , amtSrcOper = fromIntegral amtSrcOper'+      , transOper = fromIntegral transOper'+      }+  coarbitrary = undefined++data Generator =+  -- Oscillator+  StartAddressOffset Int | -- 0 sample start fine offset+  EndAddressOffset Int | -- 1 sample end fine offset+  LoopStartAddressOffset Int | -- 2 sample start loop fine offset+  LoopEndAddressOffset Int |  -- 3 sample end loop file offset+  StartAddressCoarseOffset Int | -- 4 sample start coarse offset+  ModLfoToPitch Int | -- 5 main fm: modLfo-> pitch+  VibLfoToPitch Int | -- 6 aux fm:  vibLfo-> pitch+  ModEnvToPitch Int | -- 7 pitch env: modEnv(aux)-> pitch++  -- Filter+  InitFc Int | -- 8 initial filter cutoff+  InitQ Int | -- 9 filter Q+  ModLfoToFc Int | -- 10 filter modulation: lfo1 -> filter cutoff+  ModEnvToFc Int | -- 11 filter env: modEnv(aux)-> filter cutoff++  -- Amplifier+  InstVol Int | -- 12 initial volume+  ModLfoToVol Int | -- 13 tremolo: lfo1-> volume+  -- 14 unused++  -- Effects+  Chorus Int | -- 15 chorus+  Reverb Int | -- 16 reverb+  Pan Int | -- 17 pan+  -- 18 unused+  -- 19 unused+  -- 20 unused++  -- Modulation LFO+  DelayModLfo Int | -- 21 delay +  FreqModLfo Int | -- 22 frequency++  -- Vibrato LFO+  DelayVibLfo Int | -- 23 delay +  FreqVibLfo Int | -- 24 frequency++  -- Modulation Envelope+  DelayModEnv Int | -- 25 delay +  AttackModEnv Int | -- 26 attack+  HoldModEnv Int | -- 27 hold+  DecayModEnv Int | -- 28 decay+  SustainModEnv Int | -- 29 sustain+  ReleaseModEnv Int | -- 30 release+  KeyToModEnvHold Int | -- 31 key scaling coefficient+  KeyToModEnvDecay Int | -- 32 key scaling coefficient++  -- Volume Envelope (ampl/vol)+  DelayVolEnv Int | -- 33 delay +  AttackVolEnv Int | -- 34 attack+  HoldVolEnv Int | -- 35 hold+  DecayVolEnv Int | -- 36 decay+  SustainVolEnv Int | -- 37 sustain+  ReleaseVolEnv Int | -- 38 release+  KeyToVolEnvHold Int | -- 39 key scaling coefficient+  KeyToVolEnvDecay Int | -- 40 key scaling coefficient++  -- Preset+  InstIndex Word | -- 41+  -- 42+  KeyRange Word Word | -- 43+  VelRange Word Word | -- 44+  LoopStartAddressCoarseOffset Int | -- 45 +  Key Word | -- 46+  Vel Word | -- 47+  InitAtten Int | -- 48+  -- 49 unused+  LoopEndAddressCoarseOffset Int | -- 50++  CoarseTune Int | -- 51+  FineTune Int | -- 52+  SampleIndex Word | -- 53+  SampleMode SampleMode | -- 54+  --  55 unused+  ScaleTuning Int | -- 56+  ExclusiveClass Int | -- 57+       +  RootKey Word | -- 58+  -- 59 unused+  ReservedGen Int Int -- 60 single constructor for all unused generators+  deriving (Eq, Show)++instance Arbitrary Generator where+  arbitrary = do+    i <- choose (minBound :: Int16, maxBound)  >>= return . fromIntegral+    w <- choose (minBound :: Word16, maxBound)  >>= return . fromIntegral+    i' <- choose (60 :: Int16, maxBound)  >>= return . fromIntegral+    r1 <- choose (0,127)+    r2 <- choose (0,127)+    smplMode' <- arbitrary+    oneof $ map return [+        StartAddressOffset i+      , EndAddressOffset i +      , LoopStartAddressOffset i+      , LoopEndAddressOffset i+      , StartAddressCoarseOffset i+      , ModLfoToPitch i+      , VibLfoToPitch i+      , ModEnvToPitch i+      +      , InitFc i+      , InitQ i+      , ModLfoToFc i+      , ModEnvToFc i+    +      , InstVol i+      , ModLfoToVol i+    +      , Chorus i+      , Reverb i+      , Pan i+      , DelayModLfo i+      , FreqModLfo i+    +      , DelayVibLfo i+      , FreqVibLfo i+    +      , DelayModEnv i+      , AttackModEnv i+      , HoldModEnv i+      , DecayModEnv i+      , SustainModEnv i+      , ReleaseModEnv i+      , KeyToModEnvHold i+      , KeyToModEnvDecay i+    +      , DelayVolEnv i+      , AttackVolEnv i+      , HoldVolEnv i+      , DecayVolEnv i+      , SustainVolEnv i+      , ReleaseVolEnv i+      , KeyToVolEnvHold i+      , KeyToVolEnvDecay i+    +      , InstIndex w+    +      , KeyRange r1 r2+      , VelRange r2 r2+      , LoopStartAddressCoarseOffset i+      , Key w+      , Vel w+      , InitAtten i+    +      , LoopEndAddressCoarseOffset i+    +      , CoarseTune i+      , FineTune i+      , SampleIndex w+      , SampleMode smplMode'+    +      , ScaleTuning i+      , ExclusiveClass i+         +      , RootKey w+    +      , ReservedGen i' i]+  coarbitrary = undefined+++data SampleMode = NoLoop | ContLoop | PressLoop+  deriving (Eq, Show)+  +instance Arbitrary SampleMode where+  arbitrary = oneof [return NoLoop, return ContLoop, return PressLoop]+  coarbitrary = undefined++data Inst = Inst {+    instName :: String+  , instBagNdx :: Word+  } deriving (Eq, Show)++instance Arbitrary Inst where+  arbitrary = do+    n <- choose (0,20)+    instName' <- stringNulGen n+    instBagNdx' <- choose (maxBound :: Word16, minBound)+    return $! Inst {+        instName = instName'+      , instBagNdx = fromIntegral $ instBagNdx'}+  coarbitrary = undefined++data Shdr = Shdr {+    sampleName :: String+  , start :: Word+  , end :: Word+  , startLoop :: Word+  , endLoop :: Word+  , sampleRate :: Word+  , originalPitch :: Word+  , pitchCorrection :: Int+  , sampleLink :: Word+  , sampleType :: Word+  } deriving (Eq, Show)++instance Arbitrary Shdr where+  arbitrary = do+    n <- choose (0,20)+    sampleName' <- stringNulGen n+    start' <- choose (minBound :: Word32, maxBound)+    end' <- choose (minBound :: Word32, maxBound)+    startLoop' <- choose (minBound :: Word32, maxBound)+    endLoop' <- choose (minBound :: Word32, maxBound)+    sampleRate' <- choose (minBound :: Word32, maxBound)+    originalPitch' <- choose (minBound :: Word8, maxBound)+    pitchCorrection' <- choose (minBound :: Int8, maxBound)+    sampleLink' <- choose (minBound :: Word16, maxBound)+    sampleType' <- choose (minBound :: Word16, maxBound)    +    return $ Shdr {+        sampleName = sampleName'+      , start = fromIntegral start'+      , end = fromIntegral end'+      , startLoop = fromIntegral startLoop'+      , endLoop = fromIntegral endLoop'+      , sampleRate = fromIntegral sampleRate'+      , originalPitch = fromIntegral originalPitch'+      , pitchCorrection = fromIntegral pitchCorrection'+      , sampleLink = fromIntegral sampleLink'+      , sampleType = fromIntegral sampleType'+      }+  coarbitrary = undefined++---- SoundFont import++importFile :: FilePath -> IO (Either String SoundFont)+importFile n = do+  bs <- L.readFile n+  return $! runParser parseSoundFont bs++exportFile :: FilePath -> SoundFont ->  IO ()+exportFile f sf = do+  let bs = toLazyByteString $ buildSoundFont sf+  L.writeFile f bs ++parseSoundFont :: Parser SoundFont+parseSoundFont = do+  string "RIFF"+  getWord32le -- chunkSize+  string "sfbk"+  infos' <- parseInfos+  sdta' <- parseSdta+  pdta' <- parsePdta+  return $! SoundFont {+      infos = infos'+    , sdta = sdta'+    , pdta = pdta'+    }++buildSoundFont :: SoundFont -> Builder+buildSoundFont sf = mconcat [+    putString "RIFF"+  , putWord32le $ fromIntegral chunkSize+  , fromLazyByteString bs]+  where+  chunkSize = L.length bs+  bs = toLazyByteString $ mconcat [+      putString "sfbk"+    , buildInfos (infos sf)+    , buildSdta (sdta sf)+    , buildPdta (pdta sf)]++--buildSoundFont :: SoundFont -> Builder+--buildSoundFont sf = mconcat [++parseInfos :: Parser (Array Word Info)+parseInfos = do+  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;+         case n of+           "ifil" -> return $! Version (fromIntegral w1) (fromIntegral w2)+           "iver" -> return $! RomVersion (fromIntegral w1) (fromIntegral w2)+           _ -> fail []+    , do n <- getString 4; l <- expect (<= 256) getWord32le; s <- getStringNul;  +         skip (fromIntegral l - genericLength s - 1);+         case n of+           "isng" -> return $! TargetSoundEngine s+           "INAM" -> return $! BankName s+           "irom" -> return $! RomName s+           "ICRD" -> return $! CreationDate s+           "IENG" -> return $! Authors s+           "IPRD" -> return $! IntendedProduct s+           "ICOP" -> return $! CopyrightMessage s+           "ICMT" -> return $! Comments s+           "ISFT" -> return $! UsedTools s+           _ -> fail []+    , do n <- expect ( /= "LIST") (getString 4)+         l <- getWord32le +         bs <- getLazyByteString (fromIntegral l)+         return $! ReservedInfo n (fromIntegral l) bs]++buildInfos :: (Array Word Info) -> Builder+buildInfos infos' = mconcat [+    putString "LIST"+  , putWord32le $ (fromIntegral $ L.length bs) + 4+  , putString "INFO"+  , fromLazyByteString bs]+  where+  bs = toLazyByteString $ mconcat $ map buildInfo $ elems infos'++{-+Specification says that 'ifil' 'isgn' and 'INAM' fields are mandatory+but I am not checking it during parsing+-}+++buildInfo :: Info -> Builder+buildInfo (Version w1 w2) = mconcat+  [putString "ifil", putWord32le 4,+   putWord16le (fromIntegral w1), putWord16le (fromIntegral w2)]+buildInfo (RomVersion w1 w2) = mconcat+  [putString "iver", putWord32le 4,+   putWord16le (fromIntegral w1), putWord16le (fromIntegral w2)]+buildInfo (TargetSoundEngine s) = mconcat [putString "isng", buildInfoString s]+buildInfo (BankName s) = mconcat [putString "INAM", buildInfoString s]+buildInfo (RomName s) = mconcat [putString "irom", buildInfoString s]+buildInfo (CreationDate s) = mconcat [putString "ICRD", buildInfoString s]+buildInfo (Authors s) = mconcat [putString "IENG", buildInfoString s]+buildInfo (IntendedProduct s) = mconcat [putString "IPRD", buildInfoString s]+buildInfo (CopyrightMessage s) = mconcat [putString "ICOP", buildInfoString s]+buildInfo (Comments s) = mconcat [putString "ICMT", buildInfoString s]+buildInfo (UsedTools s) = mconcat [putString "ISFT", buildInfoString s]+buildInfo (ReservedInfo n l bs) = mconcat+  [putString n, putWord32le (fromIntegral l), fromLazyByteString bs]+  +buildInfoString :: String -> Builder+buildInfoString s = if (mod l 2 == 0)+  then mconcat [putWord32le (l + 2), putString s, putWord8 0, putWord8 0]+  else mconcat [putWord32le (l + 1), putString s, putWord8 0]+  where+  l = fromIntegral $ length s+  +parseSdta :: Parser Sdta+parseSdta = do+  string "LIST"+  sdtaSize <- getWord32le >>= return .fromIntegral+  string "sdta"+  string "smpl"+  smplSize <- getWord32le  >>= return .fromIntegral+  when (odd smplSize) $ fail "'smplSize' must not be odd number"+  let sn = div smplSize 2+  smpl' <- Audio.parseSampleData sn getInt16le+  choice [+      do guard (smplSize == (sdtaSize - 12))+         return $! Sdta {smpl = smpl', sm24 =  Nothing}+    , do string "sm24"+         let sm24Size = if odd sn then sn + 1 else sn +         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 [+    putString "LIST"+  , putWord32le $ fromIntegral $ sdtaSize+  , putString "sdta"+  , putString "smpl"+  , putWord32le $ fromIntegral $ smplSize+  , Audio.buildSampleData putInt16le smpl]+  where smplSize = (Audio.sampleNumber smpl) * 2+        sdtaSize = 4 + 4 + 4 + smplSize+buildSdta (Sdta smpl (Just sd8)) = mconcat [+    putString "LIST"+  , putWord32le $ fromIntegral $ sdtaSize+  , putString "sdta"+  , putString "smpl"+  , putWord32le $ fromIntegral $ smplSize+  , Audio.buildSampleData putInt16le smpl+  , putString "sm24"+  , putWord32le $ fromIntegral $ sm24Size+  , Audio.buildSampleData putInt8 sd8+  , mconcat $ genericReplicate (sm24Size - sn) $ putWord8 0]+  where sn = Audio.sampleNumber smpl+        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"+  phdrs' <- parseSubchunk "phdr" 38 parsePhdr+  pbags' <- parseSubchunk "pbag" 4 parseBag+  pmods' <- parseSubchunk "pmod" 10 parseMod+  pgens' <- parseSubchunk "pgen" 4  parseGen+  insts' <- parseSubchunk "inst" 22  parseInst  +  ibags' <- parseSubchunk "ibag" 4 parseBag+  imods' <- parseSubchunk "imod" 10 parseMod+  igens' <- parseSubchunk "igen" 4  parseGen+  shdrs' <- parseSubchunk "shdr" 46 parseShdr+  return $! Pdta phdrs' pbags' pmods' pgens' insts' ibags' imods' igens' shdrs'++buildPdta :: Pdta -> Builder+buildPdta pdta = mconcat [+    putString "LIST"+  , putWord32le $ fromIntegral chunkSize+  , fromLazyByteString bs]+  where+  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)    +    ]++-- 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+  chunkSize <- expect (\w -> mod w size == 0) (getWord32le >>= return . fromIntegral)+  let n = div chunkSize size+  cs <- sequence (genericReplicate n p)+  return $! listArray (0, n - 1) cs++buildSubchunk :: String -> Word -> (a -> Builder) -> (Array Word a) ->  Builder+buildSubchunk s size b a = mconcat [+    putString s+  , putWord32le $ fromIntegral $ (1 + (snd $ bounds a)) * size+  , mconcat $ map b $ elems a]+  +parsePhdr :: Parser Phdr  +parsePhdr = do+  presetName' <- getLazyByteString 20+                 >>= return . map w2c . L.unpack . L.takeWhile ( /= 0)+  preset' <- getWord16le >>= return . fromIntegral+  bank' <- getWord16le >>= return . fromIntegral+  presetBagNdx' <- getWord16le >>= return . fromIntegral+  library' <- getWord32le >>= return . fromIntegral+  genre' <- getWord32le >>= return . fromIntegral+  morphology' <- getWord32le >>= return . fromIntegral+  return $ Phdr {+      presetName = presetName'+    , preset = preset'+    , bank = bank'+    , presetBagNdx = presetBagNdx'+    , library = library'+    , genre = genre'+    , morphology = morphology'+    }++buildPhdr :: Phdr -> Builder  +buildPhdr phdr = mconcat [+      putString $ presetName phdr+    , mconcat $ replicate (20 - length (presetName phdr)) (putWord8 0) +    , putWord16le $ fromIntegral $ preset phdr+    , putWord16le $ fromIntegral $ bank phdr+    , putWord16le $ fromIntegral $ presetBagNdx phdr+    , putWord32le $ fromIntegral $ library phdr+    , putWord32le $ fromIntegral $ genre phdr+    , putWord32le $ fromIntegral $ morphology phdr    +    ]++parseBag :: Parser Bag+parseBag = do+    genNdx' <- getWord16le+    modNdx' <- getWord16le+    return $! Bag {+        genNdx = fromIntegral genNdx'+      , modNdx = fromIntegral modNdx'}+    +buildBag :: Bag -> Builder  +buildBag bag = mconcat [+      putWord16le $ fromIntegral $ genNdx bag+    , putWord16le $ fromIntegral $ modNdx bag]++parseMod :: Parser Mod+parseMod = do+    srcOper' <- getWord16le+    destOper' <- getWord16le+    amount' <- getInt16le+    amtSrcOper' <- getWord16le+    transOper' <- getWord16le+    return $! Mod {+        srcOper = fromIntegral srcOper'+      , destOper = fromIntegral destOper'+      , amount = fromIntegral amount'+      , amtSrcOper = fromIntegral amtSrcOper'+      , transOper = fromIntegral transOper'+      }+    +buildMod :: Mod -> Builder+buildMod m = mconcat [+      putWord16le $ fromIntegral $ srcOper m+    , putWord16le $ fromIntegral $ destOper m+    , putWord16le $ fromIntegral $ amount m+    , putWord16le $ fromIntegral $ amtSrcOper m+    , putWord16le $ fromIntegral $ transOper m+    ]++parseGen :: Parser Generator+parseGen = choice [+    int16le  0 >> getInt16le >>= return . StartAddressOffset . fromIntegral+  , int16le  1 >> getInt16le >>= return . EndAddressOffset . fromIntegral+  , int16le  2 >> getInt16le >>= return . LoopStartAddressOffset . fromIntegral+  , int16le  3 >> getInt16le >>= return . LoopEndAddressOffset . fromIntegral+  , int16le  4 >> getInt16le  >>= return . StartAddressCoarseOffset . fromIntegral+  , int16le  5 >> getInt16le  >>= return . ModLfoToPitch . fromIntegral+  , int16le  6 >> getInt16le  >>= return . VibLfoToPitch . fromIntegral+  , int16le  7 >> getInt16le  >>= return . ModEnvToPitch . fromIntegral++  , int16le  8 >> getInt16le  >>= return . InitFc . fromIntegral+  , int16le  9 >> getInt16le  >>= return . InitQ . fromIntegral+  , int16le 10 >> getInt16le  >>= return . ModLfoToFc . fromIntegral+  , int16le 11 >> getInt16le  >>= return . ModEnvToFc . fromIntegral+    +  , int16le 12 >> getInt16le  >>= return . InstVol . fromIntegral+  , int16le 13 >> getInt16le  >>= return . ModLfoToVol . fromIntegral+    +  , int16le 15 >> getInt16le  >>= return . Chorus . fromIntegral+  , int16le 16 >> getInt16le  >>= return . Reverb . fromIntegral+  , int16le 17 >> getInt16le  >>= return . Pan . fromIntegral+    +  , int16le 21 >> getInt16le  >>= return . DelayModLfo . fromIntegral+  , int16le 22 >> getInt16le  >>= return . FreqModLfo . fromIntegral+    +  , int16le 23 >> getInt16le  >>= return . DelayVibLfo . fromIntegral+  , int16le 24 >> getInt16le  >>= return . FreqVibLfo . fromIntegral+    +  , int16le 25 >> getInt16le  >>= return . DelayModEnv . fromIntegral+  , int16le 26 >> getInt16le  >>= return . AttackModEnv . fromIntegral+  , int16le 27 >> getInt16le  >>= return . HoldModEnv . fromIntegral+  , int16le 28 >> getInt16le  >>= return . DecayModEnv . fromIntegral+  , int16le 29 >> getInt16le  >>= return . SustainModEnv . fromIntegral+  , int16le 30 >> getInt16le  >>= return . ReleaseModEnv . fromIntegral+  , int16le 31 >> getInt16le  >>= return . KeyToModEnvHold . fromIntegral+  , int16le 32 >> getInt16le  >>= return . KeyToModEnvDecay . fromIntegral+    +  , int16le 33 >> getInt16le  >>= return . DelayVolEnv . fromIntegral+  , int16le 34 >> getInt16le  >>= return . AttackVolEnv . fromIntegral+  , int16le 35 >> getInt16le  >>= return . HoldVolEnv . fromIntegral+  , int16le 36 >> getInt16le  >>= return . DecayVolEnv . fromIntegral+  , int16le 37 >> getInt16le  >>= return . SustainVolEnv . fromIntegral+  , int16le 38 >> getInt16le  >>= return . ReleaseVolEnv . fromIntegral+  , int16le 39 >> getInt16le  >>= return . KeyToVolEnvHold . fromIntegral+  , int16le 40 >> getInt16le  >>= return . KeyToVolEnvDecay . fromIntegral+    +  , int16le 41 >> getWord16le >>= return . InstIndex . fromIntegral+  , do int16le 43; a <- getWord8 >>= return . fromIntegral;+       b <- getWord8 >>= return . fromIntegral; return $ KeyRange a b;+  , do int16le 44; a <- getWord8 >>= return . fromIntegral;+       b <- getWord8 >>= return . fromIntegral; return $ VelRange a b;+    +  , int16le 45 >> getInt16le  >>= return . LoopStartAddressCoarseOffset . fromIntegral+  , int16le 46 >> getWord16le  >>= return . Key . fromIntegral+  , int16le 47 >> getWord16le  >>= return . Vel . fromIntegral+  , int16le 48 >> getInt16le  >>= return . InitAtten . fromIntegral+  , int16le 50 >> getInt16le  >>= return . LoopEndAddressCoarseOffset . fromIntegral+    +  , int16le 51 >> getInt16le  >>= return . CoarseTune . fromIntegral+  , int16le 52 >> getInt16le  >>= return . FineTune . fromIntegral+  , int16le 53 >> getWord16le >>= return . SampleIndex . fromIntegral+  , do int16le  54;  a <- getInt16le;+       case a of+         1 -> return $ SampleMode ContLoop+         3 -> return $ SampleMode PressLoop+         _ -> return $ SampleMode NoLoop+  , int16le 56 >> getInt16le  >>= return . ScaleTuning . fromIntegral+  , int16le 57 >> getInt16le  >>= return . ExclusiveClass . fromIntegral+    +  , int16le 58 >> getWord16le  >>= return . RootKey . fromIntegral+  , do p1 <- getInt16le; p2 <- getInt16le;+       return $ ReservedGen (fromIntegral p1) (fromIntegral p2)]+++buildGen :: Generator -> Builder+buildGen g = mconcat $ case g of+  StartAddressOffset i       -> [putInt16le 0, putInt16le $ fromIntegral i]+  EndAddressOffset i         -> [putInt16le 1, putInt16le $ fromIntegral i]+  LoopStartAddressOffset i   -> [putInt16le 2, putInt16le $ fromIntegral i]+  LoopEndAddressOffset i     -> [putInt16le 3, putInt16le $ fromIntegral i]+  StartAddressCoarseOffset i -> [putInt16le 4, putInt16le $ fromIntegral i]+  ModLfoToPitch i            -> [putInt16le 5, putInt16le $ fromIntegral i]+  VibLfoToPitch i            -> [putInt16le 6, putInt16le $ fromIntegral i]+  ModEnvToPitch i            -> [putInt16le 7, putInt16le $ fromIntegral i]++  InitFc i     -> [putInt16le 8, putInt16le $ fromIntegral i]+  InitQ i      -> [putInt16le 9, putInt16le $ fromIntegral i]+  ModLfoToFc i -> [putInt16le 10, putInt16le $ fromIntegral i]+  ModEnvToFc i -> [putInt16le 11, putInt16le $ fromIntegral i]+    +  InstVol i     -> [putInt16le 12, putInt16le $ fromIntegral i]+  ModLfoToVol i -> [putInt16le 13, putInt16le $ fromIntegral i]+   +  Chorus i -> [putInt16le 15, putInt16le $ fromIntegral i]+  Reverb i -> [putInt16le 16, putInt16le $ fromIntegral i]+  Pan i    -> [putInt16le 17, putInt16le $ fromIntegral i]+  +  DelayModLfo i -> [putInt16le 21, putInt16le $ fromIntegral i]+  FreqModLfo  i -> [putInt16le 22, putInt16le $ fromIntegral i]+    +  DelayVibLfo i -> [putInt16le 23, putInt16le $ fromIntegral i]+  FreqVibLfo i  -> [putInt16le 24, putInt16le $ fromIntegral i]+    +  DelayModEnv i      -> [putInt16le 25, putInt16le $ fromIntegral i]+  AttackModEnv i     -> [putInt16le 26, putInt16le $ fromIntegral i]+  HoldModEnv i       -> [putInt16le 27, putInt16le $ fromIntegral i]+  DecayModEnv i      -> [putInt16le 28, putInt16le $ fromIntegral i]+  SustainModEnv i    -> [putInt16le 29, putInt16le $ fromIntegral i]+  ReleaseModEnv i    -> [putInt16le 30, putInt16le $ fromIntegral i]+  KeyToModEnvHold i  -> [putInt16le 31, putInt16le $ fromIntegral i]+  KeyToModEnvDecay i -> [putInt16le 32, putInt16le $ fromIntegral i]+    +  DelayVolEnv i      -> [putInt16le 33, putInt16le $ fromIntegral i]+  AttackVolEnv i     -> [putInt16le 34, putInt16le $ fromIntegral i]+  HoldVolEnv i       -> [putInt16le 35, putInt16le $ fromIntegral i]+  DecayVolEnv i      -> [putInt16le 36, putInt16le $ fromIntegral i]+  SustainVolEnv i    -> [putInt16le 37, putInt16le $ fromIntegral i]+  ReleaseVolEnv i    -> [putInt16le 38, putInt16le $ fromIntegral i]+  KeyToVolEnvHold i  -> [putInt16le 39, putInt16le $ fromIntegral i]+  KeyToVolEnvDecay i -> [putInt16le 40, putInt16le $ fromIntegral i]+    +  InstIndex i  -> [putInt16le 41, putWord16le $ fromIntegral i]+  KeyRange a b -> [putInt16le 43, putWord8 $ fromIntegral a, putWord8 $ fromIntegral b]+  VelRange a b -> [putInt16le 44, putWord8 $ fromIntegral a, putWord8 $ fromIntegral b]++  LoopStartAddressCoarseOffset i  -> [putInt16le 45, putInt16le $ fromIntegral i]+  Key i                           -> [putWord16le 46, putInt16le $ fromIntegral i]+  Vel i                           -> [putWord16le 47, putInt16le $ fromIntegral i]+  InitAtten i                     -> [putInt16le 48, putInt16le $ fromIntegral i]+  LoopEndAddressCoarseOffset i    -> [putInt16le 50, putInt16le $ fromIntegral i]+    +  CoarseTune i  -> [putInt16le 51, putInt16le $ fromIntegral i]+  FineTune i    -> [putInt16le 52, putInt16le $ fromIntegral i]+  SampleIndex i -> [putInt16le 53, putWord16le $ fromIntegral i]+  +  SampleMode ContLoop  -> [putInt16le 54, putInt16le 1]+  SampleMode PressLoop -> [putInt16le 54, putInt16le 3]+  SampleMode NoLoop    -> [putInt16le 54, putInt16le 2]+  --56+  ScaleTuning i -> [putInt16le 56, putInt16le $ fromIntegral i]+  ExclusiveClass i -> [putInt16le 57, putInt16le $ fromIntegral i]+    +  RootKey i -> [putInt16le 58, putWord16le $ fromIntegral i]+  ReservedGen i1 i2 ->  [putInt16le $ fromIntegral i1, putInt16le $ fromIntegral i2]++parseInst :: Parser Inst  +parseInst = do+  instName' <- getLazyByteString 20+               >>= return . map w2c . L.unpack . L.takeWhile ( /= 0)+  instBagNdx' <- getWord16le >>= return . fromIntegral+  return $ Inst {+      instName = instName'+    , instBagNdx = instBagNdx'}++buildInst :: Inst -> Builder  +buildInst i = mconcat [+      putString $ instName i+    , mconcat $ replicate (20 - length (instName i)) (putWord8 0) +    , putWord16le $ fromIntegral $ instBagNdx i]++parseShdr :: Parser Shdr  +parseShdr = do+  sampleName' <- getLazyByteString 20+                 >>= return . map w2c . L.unpack . L.takeWhile ( /= 0)+  start' <- getWord32le+  end' <- getWord32le+  startLoop' <- getWord32le+  endLoop' <- getWord32le  +  sampleRate' <- getWord32le+  originalPitch' <- getWord8+  pitchCorrection' <- getInt8+  sampleLink' <- getWord16le+  sampleType' <- getWord16le+  return $ Shdr {+      sampleName = sampleName'+    , start = fromIntegral start'+    , end = fromIntegral end'+    , startLoop = fromIntegral startLoop'+    , endLoop = fromIntegral endLoop'+    , sampleRate = fromIntegral sampleRate'+    , originalPitch = fromIntegral originalPitch'+    , pitchCorrection = fromIntegral pitchCorrection'+    , sampleLink = fromIntegral sampleLink'+    , sampleType = fromIntegral sampleType'+    }++buildShdr :: Shdr -> Builder  +buildShdr shdr = mconcat [+      putString $ sampleName shdr+    , mconcat $ replicate (20 - length (sampleName shdr)) (putWord8 0) +    , putWord32le $ fromIntegral $ start shdr+    , putWord32le $ fromIntegral $ end shdr    +    , putWord32le $ fromIntegral $ startLoop shdr+    , putWord32le $ fromIntegral $ endLoop shdr+    , putWord32le $ fromIntegral $ sampleRate shdr+    , putWord8    $ fromIntegral $ originalPitch shdr+    , putInt8     $ fromIntegral $ pitchCorrection shdr    +    , putWord16le $ fromIntegral $ sampleLink shdr+    , putWord16le $ fromIntegral $ sampleType shdr+    ]++-- data SampleType = +--  MonoSample |+--   RightSample |+--   LeftSample |+--   LinkedSample |+--   RomMonoSample |+--   RomRightSample |+--   RomLeftSample |+--   RomLinkedSample+--   deriving Show
+ src/Codec/Wav.hs view
@@ -0,0 +1,177 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Codec.Wav+-- Copyright   : George Giorgidze+-- License     : BSD3+-- +-- Maintainer  : George Giorgidze <http://cs.nott.ac.uk/~ggg/>+-- Stability   : Experimental+-- Portability : Portable+--+-- Module for reading and writting of WAVE (.wav) audio files.+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts #-}++module Codec.Wav (+    importFile+  , exportFile+  , parseWav+  , buildWav+  , AudibleInWav(..)+  ) where++import Data.Audio+import Data.ByteString.Parser+import Data.ByteString.Builder++import Data.Word+import Data.Int+import qualified Data.ByteString.Lazy as L+import Data.Monoid+import Data.List+import Data.Array.Diff+++import Control.Monad+import Control.Applicative++type BitsPerSample = Int+type BytesPerSample = Int++class AudibleInWav a where+  parseSample :: Parser a+  buildSample :: a -> Builder+  bitsPerSample :: a -> Int++instance AudibleInWav Word8 where+  parseSample = getWord8+  buildSample = putWord8+  bitsPerSample _ = 8++instance AudibleInWav Int16 where+  parseSample = getInt16le+  buildSample = putInt16le+  bitsPerSample _ = 16++instance AudibleInWav Int32 where+  parseSample = getInt32le+  buildSample = putInt32le+  bitsPerSample _ = 32++instance AudibleInWav Int64 where+  parseSample = getInt64le+  buildSample = putInt64le+  bitsPerSample _ = 64++parserSelector :: (Audible a, AudibleInWav a) => BitsPerSample -> Parser a+parserSelector 8  = (parseSample :: Parser Word8) >>= return . fromSample . toSample+parserSelector 16 = (parseSample :: Parser Int16) >>= 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"++bytesPerSample :: (AudibleInWav a) => a -> BytesPerSample+bytesPerSample a = div (bitsPerSample a) 8 ++importFile :: (IArray DiffUArray 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 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 = do+  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)++buildWav :: (IArray DiffUArray a, Audible a, AudibleInWav a) => Audio a -> Builder+buildWav a = mconcat [+    putString "RIFF"+  , putWord32le $ fromIntegral chunkSize+  , putString "WAVE"+  , buildFmt a+  , buildData a]+  where+  sd = sampleData a+  chunkSize =+      4  -- "WAVE" +    + 24 -- fmt chunk+    + 8  -- data chunk header  +    + (fromIntegral $ sampleNumber sd) * (bytesPerSample $ sampleType sd)+       -- sample data++parseFmt :: Parser (SampleRate,ChannelNumber,BitsPerSample)+parseFmt = do+  string "fmt "+  chunkSize <- getWord32le >>= return . fromIntegral+  word16le 1 -- compression code+  channelNumber <- getWord16le >>= return . fromIntegral+  sampleRate <- getWord32le >>= return . fromIntegral+  avgBytesPerSec <- getWord32le >>= return . fromIntegral+  bytesPerSampleSlice <- getWord16le >>= return . fromIntegral+  when (avgBytesPerSec /= sampleRate * bytesPerSampleSlice) $ +    fail "avgBytesPerSec /= sampleRate * bytesPerSampleSlise"+  bitsPerSample <- expect (\w -> (mod w 8 == 0) && w <= 64) getWord16le >>= return . fromIntegral+  when (bytesPerSampleSlice /= (div bitsPerSample 8) * channelNumber) $ +    fail "bytesPerSampleSlice /= (div bitsPerSample 8) * channelNumber"+  skip (chunkSize - 16) -- skip extra fromat bytes+  return $! (sampleRate,channelNumber,bitsPerSample)++buildFmt :: (IArray DiffUArray a, Audible a, AudibleInWav a) => Audio a -> Builder+buildFmt a = mconcat [+    putString   $ "fmt "+  , putWord32le $ 16 -- chunk size+  , putWord16le $ 1  -- compression code+  , putWord16le $ fromIntegral $ channelNumber a+  , putWord32le $ fromIntegral $ sampleRate a+  , putWord32le $ fromIntegral $ avgBytesPerSec+  , putWord16le $ fromIntegral $ bytesPerSampleSlice+  , putWord16le $ fromIntegral $ bitsPS+  ]+  where+  sd = sampleData a+  bitsPS = bitsPerSample $ sampleType sd+  bytesPS = bytesPerSample $ sampleType sd+  bytesPerSampleSlice = bytesPS * channelNumber a+  avgBytesPerSec = sampleRate a * bytesPerSampleSlice+  +parseData :: (IArray DiffUArray a, Audible a, AudibleInWav a)+  => ChannelNumber -> BitsPerSample -> Parser (SampleData a)+parseData cn bitsPS = do+  string "data"+  let bytesPS = div bitsPS 8+  chunkSize <- expect (\w -> mod (fromIntegral w) bytesPS == 0) getWord32le+               >>= return . fromIntegral+  let sn = fromIntegral $ div chunkSize bytesPS+  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 a = mconcat [+    putString "data"+  , putWord32le $ fromIntegral $ chunkSize+  , buildSampleData buildSample sd]+  where+  sd = sampleData a+  chunkSize = (fromIntegral $ sampleNumber sd) * (bytesPerSample $ sampleType sd)++parseUnknownChunk :: Parser ()+parseUnknownChunk = do+  expect (\s -> s /= "data" && s /= "fmt ") (getString 4)+  chunkSize <- getWord32le+  skip(fromIntegral chunkSize)+  return ()
+ src/Data/Arbitrary.hs view
@@ -0,0 +1,143 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Data.Arbitrary+-- Copyright   : George Giorgidze+-- License     : BSD3+-- +-- Maintainer  : George Giorgidze <http://cs.nott.ac.uk/~ggg/>+-- Stability   : Experimental+-- Portability : Portable+--+-- Additional instances of the 'Arbitrary' type class defined in 'Test.QuickCheck'.+-- Some portions of code were copied from the test suite of 'binary' package.+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.Arbitrary (+    arrayGen+  , 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.Char++import System.Random++instance Random Word8 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Int8 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Word16 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Int16 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Word where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Word32 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Int32 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Word64 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Int64 where+  randomR = integralRandomR+  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)++instance Arbitrary Word8 where+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Word16 where+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Word32 where+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Word64 where+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Int8 where+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Int16 where+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Int32 where+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Int64 where+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Word where+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++----------------------------------------------------------------------++instance Arbitrary Char where+    arbitrary = choose (0, 255) >>= return . toEnum+    coarbitrary = undefined++instance Arbitrary L.ByteString where+    arbitrary     = arbitrary >>= return . L.fromChunks . filter (not. B.null)+    coarbitrary s = coarbitrary (L.unpack s)++instance Arbitrary B.ByteString where+  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)+    arrayGen n+  coarbitrary = undefined++arrayGen :: (Arbitrary e, Num i, IArray a e, Ix i) => Word -> Gen (a i e)  +arrayGen 0 = error "Array with 0 elements can not be defined"+arrayGen n = do +  es <- vector (fromIntegral n)+  return $! listArray (0 , fromIntegral $ n - 1) es+  +stringNulGen :: Word -> Gen String+stringNulGen n = do+  sequence $ genericReplicate n $ choose (1,255) >>= return . chr
+ src/Data/Audio.hs view
@@ -0,0 +1,155 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Data.Audio+-- Copyright   : George Giorgidze+-- License     : BSD3+-- +-- Maintainer  : George Giorgidze <http://cs.nott.ac.uk/~ggg/>+-- Stability   : Experimental+-- Portability : Portable+--+-- General purpose data type for representing an audio data.+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts, UndecidableInstances  #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.Audio (+   Sample+ , Audio (..)+ , SampleRate+ , ChannelNumber+ , SampleNumber+ , SampleData+ , sampleType+ , sampleNumber+ , convert+ , parseSampleData+ , buildSampleData+ , Audible+ , toSample+ , fromSample+ ) where++import Data.Arbitrary+import Data.ByteString.Parser+import Data.ByteString.Builder++import Data.Word+import Data.Int+import Data.Array.Diff+import Data.List+import Data.Monoid+import Test.QuickCheck++type Sample = Double++class Audible a where+  toSample :: a -> Sample+  fromSample :: Sample -> a+  +-- It is required that sampleNummer `mod` channelNumber == 0+data Audio a = Audio {+    sampleRate :: SampleRate+  , channelNumber :: ChannelNumber+  , sampleData :: SampleData a+  }++instance (Eq a, IArray DiffUArray 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 SampleRate = Int+type ChannelNumber = Int+type SampleNumber = Word64+type SampleData a = DiffUArray SampleNumber a --UArray SampleNumber a+++instance (Show a, IArray DiffUArray 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+  arbitrary = do+    sr <- choose (minBound, maxBound)+    cn <- choose (1, 64)+    sn <- choose (1, 1024) >>= return . (fromIntegral cn *)+    sd <- arrayGen sn+    return $! Audio sr cn sd+  coarbitrary = undefined++sampleNumber :: (IArray DiffUArray a) => SampleData a -> SampleNumber+sampleNumber sd = (snd $ bounds sd) + 1++sampleType :: (IArray DiffUArray 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 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) => SampleNumber -> Parser a -> Parser (SampleData a)+parseSampleData sn p = pAux 0 (array (0, sn - 1) []) []+  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+    s <- p+    seq s $ pAux (i + 1) acc ((i,s) : buf)++buildSampleData :: (IArray DiffUArray a) => (a -> Builder) -> SampleData a -> Builder+buildSampleData b sd = mconcat $ map b $ elems sd  ++instance Audible Int8 where+  toSample a = (fromIntegral a) / (2 ** 7)+  fromSample s = round $ s * (2 ** 7)+instance Audible Int16 where+  toSample a = (fromIntegral a) / (2 ** 15)+  fromSample s = round $ s * (2 ** 15)+instance Audible Int32 where+  toSample a = (fromIntegral a) / (2 ** 31)+  fromSample s = round $ s * (2 ** 31)+instance Audible Int64 where+  toSample a = (fromIntegral a) / (2 ** 63)+  fromSample s = round $ s * (2 ** 63)+instance Audible Word8 where+  toSample a = (fromIntegral a) / (2 ** 7) - 1.0+  fromSample s = round $ (s + 1.0) * (2 ** 7)+instance Audible Word16 where+  toSample a = (fromIntegral a) / (2 ** 15) - 1.0+  fromSample s = round $ (s + 1.0) * (2 ** 15)+instance Audible Word32 where+  toSample a = (fromIntegral a) / (2 ** 31) - 1.0+  fromSample s = round $ (s + 1.0) * (2 ** 31)+instance Audible Word64 where+  toSample a = (fromIntegral a) / (2 ** 63) - 1.0+  fromSample s = round $ (s + 1.0) * (2 ** 63)++instance Audible Float where+  toSample = realToFrac +  fromSample = realToFrac++instance Audible Double where+  toSample = id+  fromSample = id
+ src/Data/ByteString/Builder.hs view
@@ -0,0 +1,386 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Data.ByteString.Builder+-- Copyright   : Lennart Kolmodin, Ross Paterson, George Giorgidze+-- License     : BSD3+-- +-- Maintainer  : George Giorgidze <http://cs.nott.ac.uk/~ggg/>+-- Stability   : experimental+-- Portability : Portable+--+-- Efficient construction of lazy bytestrings.+--+-----------------------------------------------------------------------------+module Data.ByteString.Builder (++    -- * The Builder type+      Builder+    , toLazyByteString++    -- * Constructing Builders+    , empty+    , singleton+    , putWord8+    , putInt8+    , append+    , fromByteString        -- :: S.ByteString -> Builder+    , fromLazyByteString    -- :: L.ByteString -> Builder+    , putString++    -- * Flushing the buffer state+    , flush++    -- * Derived Builders+    -- ** Big-endian writes+    , putWord16be           -- :: Word16 -> Builder+    , putWord24be           -- :: Word32 -> Builder+    , putWord32be           -- :: Word32 -> Builder+    , putWord64be           -- :: Word64 -> Builder++    , putInt16be           -- :: Int16 -> Builder+    , putInt32be           -- :: Int32 -> Builder+    , putInt64be           -- :: Int64 -> Builder++    -- ** Little-endian writes+    , putWord16le           -- :: Word16 -> Builder+    , putWord24le           -- :: Word32 -> Builder+    , putWord32le           -- :: Word32 -> Builder+    , putWord64le           -- :: Word64 -> Builder++    , putInt16le           -- :: Int16 -> Builder+    , putInt32le           -- :: Int32 -> Builder+    , putInt64le           -- :: Int64 -> Builder++    -- ** Host-endian, unaligned writes+    , putWordHost           -- :: Word -> Builder+    , putWord16host         -- :: Word16 -> Builder+    , putWord32host         -- :: Word32 -> Builder+    , putWord64host         -- :: Word64 -> Builder+    -- Variable length numbers+    , putVarLenBe+    , putVarLenLe++  ) where++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++------------------------------------------------------------------------++-- | A 'Builder' is an efficient way to build lazy 'L.ByteString's.+-- There are several functions for constructing 'Builder's, but only one+-- to inspect them: to extract any data, you have to turn them into lazy+-- 'L.ByteString's using 'toLazyByteString'.+--+-- Internally, a 'Builder' constructs a lazy 'L.Bytestring' by filling byte+-- arrays piece by piece.  As each buffer is filled, it is \'popped\'+-- off, to become a new chunk of the resulting lazy 'L.ByteString'.+-- All this is hidden from the user of the 'Builder'.++newtype Builder = Builder {+        -- Invariant (from Data.ByteString.Lazy):+        --      The lists include no null ByteStrings.+        runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString]+    }++instance Monoid Builder where+    mempty  = empty+    mappend = append++------------------------------------------------------------------------++-- | /O(1)./ The empty Builder, satisfying+--+--  * @'toLazyByteString' 'empty' = 'L.empty'@+--+empty :: Builder+empty = Builder id++-- | /O(1)./ A Builder taking a single byte, satisfying+--+--  * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@+--+singleton :: Word8 -> Builder+singleton = writeN 1 . flip poke++putWord8 :: Word8 -> Builder+putWord8 = singleton+------------------------------------------------------------------------++-- | /O(1)./ The concatenation of two Builders, an associative operation+-- with identity 'empty', satisfying+--+--  * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@+--+append :: Builder -> Builder -> Builder+append (Builder f) (Builder g) = Builder (f . g)++-- | /O(1)./ A Builder taking a 'S.ByteString', satisfying+--+--  * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@+--+fromByteString :: S.ByteString -> Builder+fromByteString bs+  | S.null bs = empty+  | otherwise = flush `append` mapBuilder (bs :)++-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying+--+--  * @'toLazyByteString' ('fromLazyByteString' bs) = bs@+--+fromLazyByteString :: L.ByteString -> Builder+fromLazyByteString bss = flush `append` mapBuilder (L.toChunks bss ++)++putString :: String -> Builder+putString = fromLazyByteString . L.pack . map c2w++------------------------------------------------------------------------++-- Our internal buffer type+data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)+                     {-# UNPACK #-} !Int                -- offset+                     {-# UNPACK #-} !Int                -- used bytes+                     {-# UNPACK #-} !Int                -- length left++------------------------------------------------------------------------++-- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'.+-- The construction work takes place if and when the relevant part of+-- the lazy 'L.ByteString' is demanded.+--+toLazyByteString :: Builder -> L.ByteString+toLazyByteString m = L.fromChunks $ unsafePerformIO $ do+    buf <- newBuffer defaultSize+    return (runBuilder (m `append` flush) (const []) buf)++-- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any,+-- yielding a new chunk in the result lazy 'L.ByteString'.+flush :: Builder+flush = Builder $ \ k buf@(Buffer p o u l) ->+    if u == 0+      then k buf+      else S.PS p o u : k (Buffer p (o+u) 0 l)++------------------------------------------------------------------------++--+-- copied from Data.ByteString.Lazy+--+defaultSize :: Int+defaultSize = 32 * k - overhead+    where k = 1024+          overhead = 2 * sizeOf (undefined :: Int)++------------------------------------------------------------------------++-- | Sequence an IO operation on the buffer+unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder+unsafeLiftIO f =  Builder $ \ k buf -> inlinePerformIO $ do+    buf' <- f buf+    return (k buf')++-- | Get the size of the buffer+withSize :: (Int -> Builder) -> Builder+withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->+    runBuilder (f l) k buf++-- | Map the resulting list of bytestrings.+mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder+mapBuilder f = Builder (f .)++------------------------------------------------------------------------++-- | Ensure that there are at least @n@ many bytes available.+ensureFree :: Int -> Builder+ensureFree n = n `seq` withSize $ \ l ->+    if n <= l then empty else+        flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize)))++-- | Ensure that @n@ many bytes are available, and then use @f@ to write some+-- bytes into the memory.+writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder+writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f)++writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer+writeNBuffer n f (Buffer fp o u l) = do+    withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))+    return (Buffer fp o (u+n) (l-n))++newBuffer :: Int -> IO Buffer+newBuffer size = do+    fp <- S.mallocByteString size+    return $! Buffer fp 0 0 size++------------------------------------------------------------------------+-- Aligned, host order writes of storable values++-- | Ensure that @n@ many bytes are available, and then use @f@ to write some+-- storable values into the memory.+writeNbytes :: Storable a => Int -> (Ptr a -> IO ()) -> Builder+writeNbytes n f = ensureFree n `append` unsafeLiftIO (writeNBufferBytes n f)++writeNBufferBytes :: Storable a => Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer+writeNBufferBytes n f (Buffer fp o u l) = do+    withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))+    return (Buffer fp o (u+n) (l-n))++------------------------------------------------------------------------++--+-- We rely on the fromIntegral to do the right masking for us.+-- The inlining here is critical, and can be worth 4x performance+--++-- | Write a Word16 in big endian format+putWord16be :: Word16 -> Builder+putWord16be w = writeN 2 $ \p -> do+    poke p               (fromIntegral (shiftR w 8) :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (w)              :: Word8)++-- | Write a Word16 in little endian format+putWord16le :: Word16 -> Builder+putWord16le w = writeN 2 $ \p -> do+    poke p               (fromIntegral (w)              :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8)++-- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16)++-- | Write a 24 bit number in big endian format represented as Word32+putWord24be :: Word32 -> Builder+putWord24be w = writeN 3 $ \p -> do+    poke p               (fromIntegral (shiftR w 16) :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8)+    poke (p `plusPtr` 2) (fromIntegral (w) :: Word8)++-- | Write a 24 bit number in little endian format represented as Word32+putWord24le :: Word32 -> Builder+putWord24le w = writeN 3 $ \p -> do+    poke p               (fromIntegral (w)           :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (shiftR w  8) :: Word8)+    poke (p `plusPtr` 2) (fromIntegral (shiftR w 16) :: Word8)++-- | Write a Word32 in big endian format+putWord32be :: Word32 -> Builder+putWord32be w = writeN 4 $ \p -> do+    poke p               (fromIntegral (shiftR w 24) :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (shiftR w 16) :: Word8)+    poke (p `plusPtr` 2) (fromIntegral (shiftR w  8) :: Word8)+    poke (p `plusPtr` 3) (fromIntegral (w)           :: Word8)++--+-- a data type to tag Put/Check. writes construct these which are then+-- inlined and flattened. matching Checks will be more robust with rules.+--++-- | Write a Word32 in little endian format+putWord32le :: Word32 -> Builder+putWord32le w = writeN 4 $ \p -> do+    poke p               (fromIntegral (w)               :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (shiftR w  8) :: Word8)+    poke (p `plusPtr` 2) (fromIntegral (shiftR w 16) :: Word8)+    poke (p `plusPtr` 3) (fromIntegral (shiftR w 24) :: Word8)++-- on a little endian machine:+-- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32)++-- | Write a Word64 in big endian format+putWord64be :: Word64 -> Builder+putWord64be w = writeN 8 $ \p -> do+    poke p               (fromIntegral (shiftR w 56) :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (shiftR w 48) :: Word8)+    poke (p `plusPtr` 2) (fromIntegral (shiftR w 40) :: Word8)+    poke (p `plusPtr` 3) (fromIntegral (shiftR w 32) :: Word8)+    poke (p `plusPtr` 4) (fromIntegral (shiftR w 24) :: Word8)+    poke (p `plusPtr` 5) (fromIntegral (shiftR w 16) :: Word8)+    poke (p `plusPtr` 6) (fromIntegral (shiftR w  8) :: Word8)+    poke (p `plusPtr` 7) (fromIntegral (w)               :: Word8)++-- | Write a Word64 in little endian format+putWord64le :: Word64 -> Builder+putWord64le w = writeN 8 $ \p -> do+    poke p               (fromIntegral (w)               :: Word8)+    poke (p `plusPtr` 1) (fromIntegral (shiftR w  8) :: Word8)+    poke (p `plusPtr` 2) (fromIntegral (shiftR w 16) :: Word8)+    poke (p `plusPtr` 3) (fromIntegral (shiftR w 24) :: Word8)+    poke (p `plusPtr` 4) (fromIntegral (shiftR w 32) :: Word8)+    poke (p `plusPtr` 5) (fromIntegral (shiftR w 40) :: Word8)+    poke (p `plusPtr` 6) (fromIntegral (shiftR w 48) :: Word8)+    poke (p `plusPtr` 7) (fromIntegral (shiftR w 56) :: Word8)++-- on a little endian machine:+-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64)++-----------------------------------------------------------------------++putInt8 :: Int8 -> Builder+putInt8 = putWord8 . fromIntegral++putInt16le :: Int16 -> Builder+putInt16le = putWord16le . fromIntegral++putInt16be :: Int16 -> Builder+putInt16be = putWord16be . fromIntegral++putInt32le :: Int32 -> Builder+putInt32le = putWord32le . fromIntegral++putInt32be :: Int32 -> Builder+putInt32be = putWord32be . fromIntegral++putInt64le :: Int64 -> Builder+putInt64le = putWord64le . fromIntegral++putInt64be :: Int64 -> Builder+putInt64be = putWord64be . fromIntegral++------------------------------------------------------------------------+-- Unaligned, word size ops++-- | /O(1)./ A Builder taking a single native machine word. The word is+-- written in host order, host endian form, for the machine you're on.+-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,+-- 4 bytes. Values written this way are not portable to+-- different endian or word sized machines, without conversion.+--+putWordHost :: Word -> Builder+putWordHost w = writeNbytes (sizeOf (undefined :: Word)) (\p -> poke p w)++-- | Write a Word16 in native host order and host endianness.+-- 2 bytes will be written, unaligned.+putWord16host :: Word16 -> Builder+putWord16host w16 = writeNbytes (sizeOf (undefined :: Word16)) (\p -> poke p w16)++-- | Write a Word32 in native host order and host endianness.+-- 4 bytes will be written, unaligned.+putWord32host :: Word32 -> Builder+putWord32host w32 = writeNbytes (sizeOf (undefined :: Word32)) (\p -> poke p w32)++-- | Write a Word64 in native host order.+-- On a 32 bit machine we write two host order Word32s, in big endian form.+-- 8 bytes will be written, unaligned.+putWord64host :: Word64 -> Builder+putWord64host w = writeNbytes (sizeOf (undefined :: Word64)) (\p -> poke p w)++------------------------------------------------------------------------++putVarLenBe :: Word64 -> Builder+putVarLenBe w = varLenAux2 $ reverse $ varLenAux1 w+  +putVarLenLe :: Word64 -> Builder+putVarLenLe w = varLenAux2 $ varLenAux1 w+  +varLenAux1 :: Word64 -> [Word8]+varLenAux1 0 = []+varLenAux1 w = (fromIntegral $ w .&. 0x7F) : (varLenAux1 $ shiftR w 7)++varLenAux2 :: [Word8] -> Builder+varLenAux2  [] = putWord8 0+varLenAux2  [w] = putWord8 w+varLenAux2 (w : ws) = putWord8 (setBit w 7) `append` varLenAux2 ws
+ src/Data/ByteString/Parser.hs view
@@ -0,0 +1,591 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Data.ByteString.Parser+-- Copyright   : Lennart Kolmodin, George Giorgidze+-- License     : BSD3+-- +-- Maintainer  : George Giorgidze <http://cs.nott.ac.uk/~ggg/>+-- Stability   : experimental+-- Portability : Portable+--+-- The Parser monad. A monad for efficiently building structures from+-- encoded lazy ByteStrings.+--+-----------------------------------------------------------------------------++module Data.ByteString.Parser (++    -- * The Parser type+      Parser+    , runParser+    , runParserState++    -- * Parsing+    , choice+    , expect+    , skip+    , lookAhead+    , lookAheadM+    , lookAheadE++    -- * Utility+    , bytesRead+    , getBytes+    , remaining+    , isEmpty++    -- * Parsing particular types+    , satisfy+    , getString+    , getStringNul+    , string+    , getWord8+    , getInt8+    , word8+    , int8++    -- ** ByteStrings+    , getByteString+    , getLazyByteString+    , getLazyByteStringNul+    , getRemainingLazyByteString++    -- ** Big-endian reads+    , getWord16be+    , word16be+    , getWord24be+    , word24be    +    , getWord32be+    , word32be    +    , getWord64be+    , word64be++    , getInt16be+    , int16be+    , getInt32be+    , int32be    +    , getInt64be+    , int64be++    -- ** Little-endian reads+    , getWord16le+    , word16le+    , getWord24le+    , word24le+    , getWord32le+    , word32le+    , getWord64le+    , word64le++    , getInt16le+    , int16le+    , getInt32le+    , int32le    +    , getInt64le+    , int64le++    -- ** Host-endian, unaligned reads+    , getWordHost+    , wordHost+    , getWord16host+    , word16host+    , getWord32host+    , word32host+    , getWord64host+    , word64host++    -- Variable length reads+    , getVarLenBe+    , varLenBe+    , getVarLenLe+    , varLenLe+  ) where++import Control.Monad hiding (join)+import Control.Applicative+import Data.Maybe (isNothing)++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Lazy.Internal as L++import Foreign++-- used by splitAtST+import Control.Monad.ST+import Data.STRef+++-- | The parse state+data S = S {-# UNPACK #-} !B.ByteString  -- current chunk+           L.ByteString                  -- the rest of the input+           {-# UNPACK #-} !Int64         -- bytes read++-- | The Get monad is just a State monad carrying around the input ByteString+newtype Parser a = Parser { unParser :: S -> Either String (a, S) }++instance Functor Parser where+    fmap f m = Parser $ \s -> case unParser m s of+      Left e -> Left e+      Right (a, s') -> Right (f a, s')+    +instance Monad Parser where+    return a  = Parser (\s -> Right (a, s))+    m >>= k   = Parser $ \s -> case (unParser m) s of+      Left e -> Left e+      Right (a, s') -> (unParser (k a)) s'+    fail  err  = Parser $ \(S _ _ bytes) -> +        Left (err ++ ". Failed reading at byte position " ++ show bytes)+instance MonadPlus Parser where+  mzero = Parser $ \_ -> Left []+  mplus p1 p2 = Parser $ \s -> case (unParser p1 s) of+    Left e1 -> case (unParser p2 s) of+      Left e2 -> Left (e1 ++ "\n" ++ e2)+      ok -> ok+    ok -> ok++instance Applicative Parser where+  pure = return+  (<*>) = ap+  +instance Alternative Parser where+  empty = mzero+  (<|>) = mplus++------------------------------------------------------------------------++get :: Parser S+get   = Parser $ \s -> Right (s, s)++put :: S -> Parser ()+put s = Parser $ \_ -> Right ((), s)++------------------------------------------------------------------------++initState :: L.ByteString -> S+initState xs = mkState xs 0++mkState :: L.ByteString -> Int64 -> S+mkState l = case l of+    L.Empty      -> S B.empty L.empty+    L.Chunk x xs -> S x xs++-- | Run the Get monad applies a 'get'-based parser on the input ByteString+runParser :: Parser a -> L.ByteString -> Either String a+runParser m str = case unParser m (initState str) of+  Left e -> Left e+  Right (a, _) -> Right a++-- | Run the Get monad applies a 'get'-based parser on the input+-- ByteString. Additional to the result of get it returns the number of+-- consumed bytes and the rest of the input.+runParserState :: Parser a -> L.ByteString -> Int64 -> Either String (a, L.ByteString, Int64)+runParserState m str off =+    case unParser m (mkState str off) of+      Left e -> Left e+      Right (a, ~(S s ss newOff)) -> Right (a, s `join` ss, newOff)++------------------------------------------------------------------------++choice :: [Parser a] -> Parser a+choice = foldl (<|>) mzero++-- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available.+skip :: Word64 -> Parser ()+skip n = readN (fromIntegral n) (const ())++-- | Run @ga@, but return without consuming its input.+-- Fails if @ga@ fails.+lookAhead :: Parser a -> Parser a+lookAhead ga = do+    s <- get+    a <- ga+    put s+    return a++-- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'.+-- Fails if @gma@ fails.+lookAheadM :: Parser (Maybe a) -> Parser (Maybe a)+lookAheadM gma = do+    s <- get+    ma <- gma+    when (isNothing ma) $ put s+    return ma++-- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'.+-- Fails if @gea@ fails.+lookAheadE :: Parser (Either a b) -> Parser (Either a b)+lookAheadE gea = do+    s <- get+    ea <- gea+    case ea of+        Left _ -> put s+        _      -> return ()+    return ea++expect :: (Show a, Eq a) => (a -> Bool) -> Parser a -> Parser a+expect f p = do+  v <- p+  when (not $ f v) $ fail $ show v ++ " was not expected."   +  return v++getString :: Int -> Parser String+getString l = do+  bs <- getLazyByteString (fromIntegral l)+  return $! map B.w2c (L.unpack bs)++getStringNul :: Parser String+getStringNul = do+  bs <- getLazyByteStringNul+  return $! map B.w2c (L.unpack bs)++string :: String -> Parser String+string s = expect (s ==) (getString $ length s)++-- Utility++-- | Get the total number of bytes read to this point.+bytesRead :: Parser Int64+bytesRead = do+    S _ _ b <- get+    return b++-- | Get the number of remaining unparsed bytes.+-- Useful for checking whether all input has been consumed.+-- Note that this forces the rest of the input.+remaining :: Parser Int64+remaining = do+    S s ss _ <- get+    return $! (fromIntegral (B.length s) + L.length ss)++-- | Test whether all input has been consumed,+-- i.e. there are no remaining unparsed bytes.+isEmpty :: Parser Bool+isEmpty = do+    S s ss _ <- get+    return $! (B.null s && L.null ss)++------------------------------------------------------------------------+-- Utility with ByteStrings++-- | An efficient 'get' method for strict ByteStrings. Fails if fewer+-- than @n@ bytes are left in the input.+getByteString :: Int -> Parser B.ByteString+getByteString n = readN n id++-- | An efficient 'get' method for lazy ByteStrings. Does not fail if fewer than+-- @n@ bytes are left in the input.+getLazyByteString :: Int64 -> Parser L.ByteString+getLazyByteString n = do+    S s ss bytes <- get+    let big = s `join` ss+    case splitAtST n big of+      (consume, rest) -> do put $ mkState rest (bytes + n)+                            return consume++-- | Get a lazy ByteString that is terminated with a NUL byte. Fails+-- if it reaches the end of input without hitting a NUL.+getLazyByteStringNul :: Parser L.ByteString+getLazyByteStringNul = do+    S s ss bytes <- get+    let big = s `join` ss+        (consume, t) = L.break (== 0) big+        (h, rest) = L.splitAt 1 t+    when (L.null h) $ fail "too few bytes"+    put $ mkState rest (bytes + L.length consume + 1)+    return consume++-- | Get the remaining bytes as a lazy ByteString+getRemainingLazyByteString :: Parser L.ByteString+getRemainingLazyByteString = do+    S s ss _ <- get+    return $! (s `join` ss)++------------------------------------------------------------------------+-- Helpers++-- | Pull @n@ bytes from the input, as a strict ByteString.+getBytes :: Int -> Parser B.ByteString+getBytes n = do+    S s ss bytes <- get+    if n <= B.length s+        then do let (consume,rest) = B.splitAt n s+                put $! S rest ss (bytes + fromIntegral n)+                return $! consume+        else+              case L.splitAt (fromIntegral n) (s `join` ss) of+                (consuming, rest) ->+                    do let now = B.concat . L.toChunks $ consuming+                       put $! mkState rest (bytes + fromIntegral n)+                       -- forces the next chunk before this one is returned+                       when (B.length now < n) $ fail "too few bytes"+                       return now+++join :: B.ByteString -> L.ByteString -> L.ByteString+join bb lb+    | B.null bb = lb+    | otherwise = L.Chunk bb lb++-- | Split a ByteString. If the first result is consumed before the --+-- second, this runs in constant heap space.+--+-- You must force the returned tuple for that to work, e.g.+-- +-- > case splitAtST n xs of+-- >    (ys,zs) -> consume ys ... consume zs+--+splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString)+splitAtST i ps | i <= 0 = (L.empty, ps)+splitAtST i ps          = runST (+     do r  <- newSTRef undefined+        xs <- first r i ps+        ys <- unsafeInterleaveST (readSTRef r)+        return (xs, ys))++  where+        first r 0 xs@(L.Chunk _ _) = writeSTRef r xs    >> return L.Empty+        first r _ L.Empty          = writeSTRef r L.Empty >> return L.Empty++        first r n (L.Chunk x xs)+          | n < l     = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs)+                           return $! L.Chunk (B.take (fromIntegral n) x) L.Empty+          | otherwise = do writeSTRef r (L.drop (n - l) xs)+                           liftM (L.Chunk x) $ unsafeInterleaveST (first r (n - l) xs)++         where l = fromIntegral (B.length x)++-- Pull n bytes from the input, and apply a parser to those bytes,+-- yielding a value. If less than @n@ bytes are available, fail with an+-- error. This wraps @getBytes@.+readN :: Int -> (B.ByteString -> a) -> Parser a+readN n f = fmap f $ getBytes n+++------------------------------------------------------------------------+-- Primtives++-- helper, get a raw Ptr onto a strict ByteString copied out of the+-- underlying lazy byteString. So many indirections from the raw parser+-- state that my head hurts...++getPtr :: Storable a => Int -> Parser a+getPtr n = do+    (fp,o,_) <- readN n B.toForeignPtr+    return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)++------------------------------------------------------------------------++satisfy :: (Word8 -> Bool) -> Parser Word8+satisfy f = do+  w <- getWord8+  guard (f w)+  return w++-- | Read a Word8 from the monad state+getWord8 :: Parser Word8+getWord8 = getPtr (sizeOf (undefined :: Word8))++word8 :: Word8 -> Parser Word8+word8 w = expect (w ==) getWord8++-- | Read a Word16 in big endian format+getWord16be :: Parser Word16+getWord16be = do+    s <- readN 2 id+    return $! (fromIntegral (s `B.index` 0) `shiftL` 8) .|.+              (fromIntegral (s `B.index` 1))++word16be :: Word16 -> Parser Word16+word16be w = expect (w ==) getWord16be++-- | Read a Word16 in little endian format+getWord16le :: Parser Word16+getWord16le = do+    s <- readN 2 id+    return $! (fromIntegral (s `B.index` 1) `shiftL` 8) .|.+              (fromIntegral (s `B.index` 0) )++word16le :: Word16 -> Parser Word16+word16le w = expect (w ==) getWord16le++-- | Read a 24 bit word into Word32 in big endian format+getWord24be :: Parser Word32+getWord24be = do+    s <- readN 3 id+    return $! (fromIntegral (s `B.index` 0) `shiftL` 16) .|.+              (fromIntegral (s `B.index` 1) `shiftL`  8) .|.+              (fromIntegral (s `B.index` 2) )++word24be :: Word32 -> Parser Word32+word24be w = expect (w ==) getWord24be++getWord24le :: Parser Word32+getWord24le = do+    s <- readN 3 id+    return $! (fromIntegral (s `B.index` 2) `shiftL` 16) .|.+              (fromIntegral (s `B.index` 1) `shiftL`  8) .|.+              (fromIntegral (s `B.index` 0) )++word24le :: Word32 -> Parser Word32+word24le w = expect (w ==) getWord24le++-- | Read a Word32 in big endian format+getWord32be :: Parser Word32+getWord32be = do+    s <- readN 4 id+    return $! (fromIntegral (s `B.index` 0) `shiftL` 24) .|.+              (fromIntegral (s `B.index` 1) `shiftL` 16) .|.+              (fromIntegral (s `B.index` 2) `shiftL`  8) .|.+              (fromIntegral (s `B.index` 3) )++word32be :: Word32 -> Parser Word32+word32be w = expect (w ==) getWord32be++-- | Read a Word32 in little endian format+getWord32le :: Parser Word32+getWord32le = do+    s <- readN 4 id+    return $! (fromIntegral (s `B.index` 3) `shiftL` 24) .|.+              (fromIntegral (s `B.index` 2) `shiftL` 16) .|.+              (fromIntegral (s `B.index` 1) `shiftL`  8) .|.+              (fromIntegral (s `B.index` 0) )++word32le :: Word32 -> Parser Word32+word32le w = expect (w ==) getWord32le+++-- | Read a Word64 in big endian format+getWord64be :: Parser Word64+getWord64be = do+    s <- readN 8 id+    return $! (fromIntegral (s `B.index` 0) `shiftL` 56) .|.+              (fromIntegral (s `B.index` 1) `shiftL` 48) .|.+              (fromIntegral (s `B.index` 2) `shiftL` 40) .|.+              (fromIntegral (s `B.index` 3) `shiftL` 32) .|.+              (fromIntegral (s `B.index` 4) `shiftL` 24) .|.+              (fromIntegral (s `B.index` 5) `shiftL` 16) .|.+              (fromIntegral (s `B.index` 6) `shiftL`  8) .|.+              (fromIntegral (s `B.index` 7) )++word64be :: Word64 -> Parser Word64+word64be w = expect (w ==) getWord64be++-- | Read a Word64 in little endian format+getWord64le :: Parser Word64+getWord64le = do+    s <- readN 8 id+    return $! (fromIntegral (s `B.index` 7) `shiftL` 56) .|.+              (fromIntegral (s `B.index` 6) `shiftL` 48) .|.+              (fromIntegral (s `B.index` 5) `shiftL` 40) .|.+              (fromIntegral (s `B.index` 4) `shiftL` 32) .|.+              (fromIntegral (s `B.index` 3) `shiftL` 24) .|.+              (fromIntegral (s `B.index` 2) `shiftL` 16) .|.+              (fromIntegral (s `B.index` 1) `shiftL`  8) .|.+              (fromIntegral (s `B.index` 0) )++word64le :: Word64 -> Parser Word64+word64le w = expect (w ==) getWord64le+------------------------------------------------------------------------+getInt8 :: Parser Int8+getInt8 = getWord8 >>= return . fromIntegral++int8 :: Int8 -> Parser Int8+int8 i = expect (i ==) getInt8++getInt16le :: Parser Int16+getInt16le = getWord16le >>= return . fromIntegral++int16le :: Int16 -> Parser Int16+int16le i = expect (i ==) getInt16le++getInt16be :: Parser Int16+getInt16be = getWord16be >>= return . fromIntegral++int16be :: Int16 -> Parser Int16+int16be i = expect (i ==) getInt16be++getInt32le :: Parser Int32+getInt32le = getWord32le >>= return . fromIntegral++int32le :: Int32 -> Parser Int32+int32le i = expect (i ==) getInt32le++getInt32be :: Parser Int32+getInt32be = getWord32be >>= return . fromIntegral++int32be :: Int32 -> Parser Int32+int32be i = expect (i ==) getInt32be++getInt64le :: Parser Int64+getInt64le = getWord64le >>= return . fromIntegral++int64le :: Int64 -> Parser Int64+int64le i = expect (i ==) getInt64le++getInt64be :: Parser Int64+getInt64be = getWord64be >>= return . fromIntegral++int64be :: Int64 -> Parser Int64+int64be i = expect (i ==) getInt64be++------------------------------------------------------------------------+-- Host-endian reads++-- | /O(1)./ Read a single native machine word. The word is read in+-- host order, host endian form, for the machine you're on. On a 64 bit+-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes.+getWordHost :: Parser Word+getWordHost = getPtr (sizeOf (undefined :: Word))++wordHost :: Word -> Parser Word+wordHost w = expect (w ==) getWordHost++-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness.+getWord16host :: Parser Word16+getWord16host = getPtr (sizeOf (undefined :: Word16))++word16host :: Word16 -> Parser Word16+word16host w = expect (w ==) getWord16host++-- | /O(1)./ Read a Word32 in native host order and host endianness.+getWord32host :: Parser Word32+getWord32host = getPtr  (sizeOf (undefined :: Word32))++word32host :: Word32 -> Parser Word32+word32host w = expect (w ==) getWord32host++-- | /O(1)./ Read a Word64 in native host order and host endianess.+getWord64host   :: Parser Word64+getWord64host = getPtr  (sizeOf (undefined :: Word64))++word64host :: Word64 -> Parser Word64+word64host w = expect (w ==) getWord64host++-- Variable length numbers++getVarLenBe :: Parser Word64+getVarLenBe = f 0+  where+  f :: Word64 -> Parser Word64+  f acc =  do+    w <- getWord8 >>= return . fromIntegral+    if testBit w 7+      then f      $! (shiftL acc 7) .|. (clearBit w 7)+      else return $! (shiftL acc 7) .|. w++varLenBe :: Word64 -> Parser Word64+varLenBe a = expect (a ==) getVarLenBe++getVarLenLe :: Parser Word64+getVarLenLe = do+  w <- getWord8 >>= return . fromIntegral+  if testBit w 7+    then do+      w' <- getVarLenLe+      return $! (clearBit w 7) .|. (shiftL w' 7)+    else return $! w++varLenLe :: Word64 -> Parser Word64+varLenLe a = expect (a ==) getVarLenLe
+ src/Tests/Main.hs view
@@ -0,0 +1,176 @@+module Main where++import Codec.Midi+import qualified Codec.Wav as Wav+import qualified Codec.SoundFont as SF+import Data.Audio++import Data.ByteString.Parser+import Data.ByteString.Builder++import Test.QuickCheck+import Data.Int+import Data.Word+import Data.Bits++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++import Control.Monad+import Data.Monoid+import Debug.Trace++roundTrip :: (Eq a, Show a) => (a -> Builder) -> Parser a -> a -> Bool+roundTrip b p a = if Right a == ea'+  then True+  else trace (unlines $ [show ea']) $ False+  where ea' = runParser p bs+        bs = toLazyByteString $ b a++testAudio :: IO ()+testAudio = do+  putStrLn "TESTING Inctances of Audible"+  test (prop_audible :: Word8 -> Bool)+  test (prop_audible :: Word16 -> Bool)+  test (prop_audible :: Word32 -> Bool)+  -- 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)  ++  -- These to 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+  prop_audible :: (Eq a, Audible a) => a -> Bool+  prop_audible a = (a ==  fromSample s) && (s >= -1.0) && (s <= 1.0)+    where s = toSample a++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 "midiFiles.txt"+  let midiFiles = lines c +  sequence_ $ map f midiFiles+  return ()+  where+  f n = do+    putStr $ "Parsing " ++ n ++ " ... "+    r <- importFile n+    m <- case r of+      Left e ->  fail $ "\n Failed: " ++ e ++ "\n"+      Right m -> return m+    putStrLn $ "OK"+    putStr "Testing  ... "+    when (not $ roundTrip buildMidi parseMidi m) $ fail "Failed\n"+    putStrLn "OK"+    -- exportFile ("./tmp/" ++ (takeBaseName n) ++ ".mid") m++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 "wavFiles.txt"+  let wavFiles = lines c +  sequence_ $ map f wavFiles+  return ()+  where+  f n = do+    putStr $ "Parsing " ++ n ++ " ... "+    r <- Wav.importFile n+    a <- case r of+      Left e ->  fail $ "\n Failed: " ++ e ++ "\n"+      Right a -> return $! (a :: Audio Int16)+    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"+    putStrLn "OK"+    --Wav.exportFile ("./tmp/" ++ (takeBaseName n) ++ ".wav") w++testSoundFont :: IO ()+testSoundFont =  do+  putStrLn "TESTING PARSING AND BUILDING of SoundFont"+  +  test $ roundTrip SF.buildSoundFont SF.parseSoundFont+ +  c <- readFile "soundFontFiles.txt"+  let soundFontFiles = lines c +  sequence_ $ map f soundFontFiles+  return ()+  where+  f n = do+    putStr $ "Parsing " ++ n ++ " ... "+    r <- SF.importFile n+    sf <- case r of+      Left e ->  fail $ "\n Failed: " ++ e ++ "\n"+      Right sf -> return sf+    putStrLn $ "OK"+    putStr "Testing  ... "+    when (not $ roundTrip SF.buildSoundFont SF.parseSoundFont sf) $ fail "Failed\n"+    putStrLn "OK"+    -- Wav.exportFile ("./tmp/" ++ (takeBaseName n) ++ ".wav") w++testParserBuilder :: IO ()+testParserBuilder = do+  putStrLn "TESTING PARSING AND BUILDING OF NUMERICAL TYPES"+  +  test $ roundTrip putWord8 getWord8+  test $ roundTrip putWord16be getWord16be+  test $ roundTrip putWord16le getWord16le+  test $ \w -> roundTrip putWord24be getWord24be (w .&. 0xFFFFFF)+  test $ \w -> roundTrip putWord24le getWord24le (w .&. 0xFFFFFF)+  test $ roundTrip putWord32be getWord32be+  test $ roundTrip putWord32le getWord32le+  test $ roundTrip putWord64be getWord64be+  test $ roundTrip putWord64le getWord64le+  +  test $ roundTrip putInt8 getInt8+  test $ roundTrip putInt16be getInt16be+  test $ roundTrip putInt16le getInt16le+  test $ roundTrip putInt32be getInt32be+  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 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  +  ++main :: IO ()+main = do+  testAudio+  testParserBuilder+  testMidi+  testWav+  testSoundFont