diff --git a/HCodecs.cabal b/HCodecs.cabal
new file mode 100644
--- /dev/null
+++ b/HCodecs.cabal
@@ -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
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/src/Codec/Midi.hs b/src/Codec/Midi.hs
new file mode 100644
--- /dev/null
+++ b/src/Codec/Midi.hs
@@ -0,0 +1,753 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Codec.Midi
+-- Copyright : George Giorgidze
+-- License : BSD3
+--
+-- Maintainer : George Giorgidze
+-- 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
diff --git a/src/Codec/SoundFont.hs b/src/Codec/SoundFont.hs
new file mode 100644
--- /dev/null
+++ b/src/Codec/SoundFont.hs
@@ -0,0 +1,933 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Codec.SoundFont
+-- Copyright : George Giorgidze
+-- License : BSD3
+--
+-- Maintainer : George Giorgidze
+-- 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
diff --git a/src/Codec/Wav.hs b/src/Codec/Wav.hs
new file mode 100644
--- /dev/null
+++ b/src/Codec/Wav.hs
@@ -0,0 +1,177 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Codec.Wav
+-- Copyright : George Giorgidze
+-- License : BSD3
+--
+-- Maintainer : George Giorgidze
+-- 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 ()
diff --git a/src/Data/Arbitrary.hs b/src/Data/Arbitrary.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Arbitrary.hs
@@ -0,0 +1,143 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Arbitrary
+-- Copyright : George Giorgidze
+-- License : BSD3
+--
+-- Maintainer : George Giorgidze
+-- 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
diff --git a/src/Data/Audio.hs b/src/Data/Audio.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Audio.hs
@@ -0,0 +1,155 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Audio
+-- Copyright : George Giorgidze
+-- License : BSD3
+--
+-- Maintainer : George Giorgidze
+-- 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
diff --git a/src/Data/ByteString/Builder.hs b/src/Data/ByteString/Builder.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/Builder.hs
@@ -0,0 +1,386 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.ByteString.Builder
+-- Copyright : Lennart Kolmodin, Ross Paterson, George Giorgidze
+-- License : BSD3
+--
+-- Maintainer : George Giorgidze
+-- 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
diff --git a/src/Data/ByteString/Parser.hs b/src/Data/ByteString/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/Parser.hs
@@ -0,0 +1,591 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.ByteString.Parser
+-- Copyright : Lennart Kolmodin, George Giorgidze
+-- License : BSD3
+--
+-- Maintainer : George Giorgidze
+-- 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
diff --git a/src/Tests/Main.hs b/src/Tests/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Tests/Main.hs
@@ -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