HCodecs 0.2.2 → 0.3
raw patch · 11 files changed
+3292/−3337 lines, 11 filesdep ~QuickCheckdep ~arraydep ~basesetup-changednew-uploader
Dependency ranges changed: QuickCheck, array, base
Files
- HCodecs.cabal +33/−33
- LICENSE +29/−29
- Setup.hs +2/−2
- src/Codec/Midi.hs +712/−716
- src/Codec/SoundFont.hs +917/−927
- src/Codec/Wav.hs +175/−175
- src/Data/Arbitrary.hs +116/−149
- src/Data/Audio.hs +148/−150
- src/Data/ByteString/Builder.hs +385/−385
- src/Data/ByteString/Parser.hs +595/−595
- src/Tests/Main.hs +180/−176
HCodecs.cabal view
@@ -1,33 +1,33 @@-name: HCodecs-version: 0.2.2-cabal-Version: >= 1.2-license: BSD3-license-file: LICENSE-copyright: (c) 2007-2011 George Giorgidze-author: George Giorgidze-maintainer: George Giorgidze (giorgidze@gmail.com)-homepage: http://www-db.informatik.uni-tuebingen.de/team/giorgidze-category: Codec-stability: experimental-synopsis: A library to read, write and manipulate MIDI, WAVE, and SoundFont2 files.-description:- The library provides functions to read, write and manipulate MIDI, WAVE and SoundFont2 multimedia files. It is written entirely in Haskell (without any FFI). It uses efficient parsing and building combinators for binary data stored in ByteStrings (based on the one in 'binary' package).- .- Correctness of significant parts of the library has been validated with QuickCheck and Haskell Program Coverage (HPC) tool-kits.--build-type: Simple-extra-source-files: src/Tests/Main.hs--library- hs-source-dirs: src- ghc-options : -O3 -Wall- build-Depends: base < 5, bytestring, random, array, QuickCheck < 2- exposed-modules:- Codec.Midi- Codec.Wav- Codec.SoundFont- Data.Audio- Data.ByteString.Parser- Data.ByteString.Builder- other-modules:- Data.Arbitrary+name: HCodecs +version: 0.3 +cabal-Version: >= 1.2 +license: BSD3 +license-file: LICENSE +copyright: (c) 2007-2011 George Giorgidze +author: George Giorgidze +maintainer: George Giorgidze (giorgidze@gmail.com) and Donya Quick (donya.quick@yale.edu) +homepage: http://www-db.informatik.uni-tuebingen.de/team/giorgidze and http://haskell.cs.yale.edu/ +category: Codec +stability: experimental +synopsis: A library to read, write and manipulate MIDI, WAVE, and SoundFont2 files. +description: + The library provides functions to read, write and manipulate MIDI, WAVE and SoundFont2 multimedia files. It is written entirely in Haskell (without any FFI). It uses efficient parsing and building combinators for binary data stored in ByteStrings (based on the one in 'binary' package). + . + Correctness of significant parts of the library has been validated with QuickCheck and Haskell Program Coverage (HPC) tool-kits. + +build-type: Simple +extra-source-files: src/Tests/Main.hs + +library + hs-source-dirs: src + ghc-options : -O3 -Wall + build-Depends: base < 5, bytestring, random, array, QuickCheck >= 2.5 + exposed-modules: + Codec.Midi + Codec.Wav + Codec.SoundFont + Data.Audio + Data.ByteString.Parser + Data.ByteString.Builder + other-modules: + Data.Arbitrary
LICENSE view
@@ -1,29 +1,29 @@-Copyright (c) 2007-2011 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 his 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.+Copyright (c) 2007-2011 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 his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
src/Codec/Midi.hs view
@@ -1,717 +1,713 @@--------------------------------------------------------------------------------- |--- Module : Codec.Midi--- Copyright : George Giorgidze--- License : BSD3--- --- Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/>--- Stability : Experimental--- Portability : Portable------ 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 track1 track2 = (fromAbsTime $ f trk1' trk2') ++ [(0,TrackEnd)]- where- trk1' = toAbsTime $ removeTrackEnds track1- trk2' = toAbsTime $ removeTrackEnds track2- 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]+----------------------------------------------------------------------------- +-- | +-- Module : Codec.Midi +-- Copyright : George Giorgidze +-- License : BSD3 +-- +-- Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/> +-- Stability : Experimental +-- Portability : Portable +-- +-- 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 (two) + +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 hiding ((.&.)) + + +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 + +data FileType = SingleTrack | MultiTrack | MultiPattern + deriving (Eq, Show) + +instance Arbitrary FileType where + arbitrary = oneof [return SingleTrack , return MultiTrack , return MultiPattern] + +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] + +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] + +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 track1 track2 = (fromAbsTime $ f trk1' trk2') ++ [(0,TrackEnd)] + where + trk1' = toAbsTime $ removeTrackEnds track1 + trk2' = toAbsTime $ removeTrackEnds track2 + 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
src/Codec/SoundFont.hs view
@@ -1,928 +1,918 @@--------------------------------------------------------------------------------- |--- Module : Codec.SoundFont--- Copyright : George Giorgidze--- License : BSD3--- --- Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/>--- Stability : Experimental--- Portability : Portable------ Module for reading and writting of SoundFont instrument description files.-----------------------------------------------------------------------------------module Codec.SoundFont (- SoundFont (..)- , Info (..)- , Sdta (..)- , Pdta (..)- , Phdr (..)- , Bag (..)- , Mod (..)- , Generator (..)- , isSampleIndex- , isInstIndex- , 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)- smpl1 <- arrayGen sn- oneof [- return $! Sdta smpl1 Nothing- , do sm24' <- arrayGen sn- return $! Sdta smpl1 (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-- - EndAddressCoarseOffset Int | -- 12 initial volume- - -- Amplifier- 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 Audio.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- - , EndAddressCoarseOffset 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--isSampleIndex :: Generator -> Bool-isSampleIndex g = case g of- SampleIndex _ -> True- _ -> False --isInstIndex :: Generator -> Bool-isInstIndex g = case g of- InstIndex _ -> True- _ -> False--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 smpl1 Nothing) = mconcat [- putString "LIST"- , putWord32le $ fromIntegral $ sdtaSize- , putString "sdta"- , putString "smpl"- , putWord32le $ fromIntegral $ smplSize- , Audio.buildSampleData putInt16le smpl1]- where smplSize = (Audio.sampleNumber smpl1) * 2- sdtaSize = 4 + 4 + 4 + smplSize-buildSdta (Sdta smpl1 (Just sd8)) = mconcat [- putString "LIST"- , putWord32le $ fromIntegral $ sdtaSize- , putString "sdta"- , putString "smpl"- , putWord32le $ fromIntegral $ smplSize- , Audio.buildSampleData putInt16le smpl1- , putString "sm24"- , putWord32le $ fromIntegral $ sm24Size- , Audio.buildSampleData putInt8 sd8- , mconcat $ genericReplicate (sm24Size - sn) $ putWord8 0]- where sn = Audio.sampleNumber smpl1- smplSize = sn * 2- sm24Size = if odd sn then sn + 1 else sn- sdtaSize = 4 + 4 + 4 + smplSize + 4 + 4 + sm24Size--parsePdta :: Parser Pdta-parsePdta = do- _ <- string "LIST"- _ <- getWord32le -- pdtaSize- _ <- string "pdta"- 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 pdta1 = mconcat [- putString "LIST"- , putWord32le $ fromIntegral chunkSize- , fromLazyByteString bs]- where- chunkSize = L.length bs- bs = toLazyByteString $ mconcat [- putString "pdta"- , buildSubchunk "phdr" 38 buildPhdr (phdrs pdta1)- , buildSubchunk "pbag" 4 buildBag (pbags pdta1)- , buildSubchunk "pmod" 10 buildMod (pmods pdta1)- , buildSubchunk "pgen" 4 buildGen (pgens pdta1)- , buildSubchunk "inst" 22 buildInst (insts pdta1)- , buildSubchunk "ibag" 4 buildBag (ibags pdta1)- , buildSubchunk "imod" 10 buildMod (imods pdta1)- , buildSubchunk "igen" 4 buildGen (igens pdta1) - , buildSubchunk "shdr" 46 buildShdr (shdrs pdta1) - ]---- For some subchunks minimal number of records is two--- but this check can be done later I am skiping it here-parseSubchunk :: String -> Word -> (Parser a) -> Parser (Array Word a)-parseSubchunk s size p = do- _ <- string s- 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 . EndAddressCoarseOffset . 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 Audio.ContLoop- 3 -> return $ SampleMode Audio.PressLoop- _ -> return $ SampleMode Audio.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]- - EndAddressCoarseOffset 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 Audio.ContLoop -> [putInt16le 54, putInt16le 1]- SampleMode Audio.PressLoop -> [putInt16le 54, putInt16le 3]- SampleMode Audio.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+----------------------------------------------------------------------------- +-- | +-- Module : Codec.SoundFont +-- Copyright : George Giorgidze +-- License : BSD3 +-- +-- Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/> +-- Stability : Experimental +-- Portability : Portable +-- +-- Module for reading and writting of SoundFont instrument description files. +-- +----------------------------------------------------------------------------- + +module Codec.SoundFont ( + SoundFont (..) + , Info (..) + , Sdta (..) + , Pdta (..) + , Phdr (..) + , Bag (..) + , Mod (..) + , Generator (..) + , isSampleIndex + , isInstIndex + , 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 + +-- 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) + +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) + smpl1 <- arrayGen sn + oneof [ + return $! Sdta smpl1 Nothing + , do sm24' <- arrayGen sn + return $! Sdta smpl1 (Just sm24') + ] + +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 + +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' + } + +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'} + +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' + } + +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 + + + EndAddressCoarseOffset Int | -- 12 initial volume + + -- Amplifier + 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 Audio.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 + + , EndAddressCoarseOffset 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] + +isSampleIndex :: Generator -> Bool +isSampleIndex g = case g of + SampleIndex _ -> True + _ -> False + +isInstIndex :: Generator -> Bool +isInstIndex g = case g of + InstIndex _ -> True + _ -> False + +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'} + +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' + } + +---- 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 smpl1 Nothing) = mconcat [ + putString "LIST" + , putWord32le $ fromIntegral $ sdtaSize + , putString "sdta" + , putString "smpl" + , putWord32le $ fromIntegral $ smplSize + , Audio.buildSampleData putInt16le smpl1] + where smplSize = (Audio.sampleNumber smpl1) * 2 + sdtaSize = 4 + 4 + 4 + smplSize +buildSdta (Sdta smpl1 (Just sd8)) = mconcat [ + putString "LIST" + , putWord32le $ fromIntegral $ sdtaSize + , putString "sdta" + , putString "smpl" + , putWord32le $ fromIntegral $ smplSize + , Audio.buildSampleData putInt16le smpl1 + , putString "sm24" + , putWord32le $ fromIntegral $ sm24Size + , Audio.buildSampleData putInt8 sd8 + , mconcat $ genericReplicate (sm24Size - sn) $ putWord8 0] + where sn = Audio.sampleNumber smpl1 + smplSize = sn * 2 + sm24Size = if odd sn then sn + 1 else sn + sdtaSize = 4 + 4 + 4 + smplSize + 4 + 4 + sm24Size + +parsePdta :: Parser Pdta +parsePdta = do + _ <- string "LIST" + _ <- getWord32le -- pdtaSize + _ <- string "pdta" + 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 pdta1 = mconcat [ + putString "LIST" + , putWord32le $ fromIntegral chunkSize + , fromLazyByteString bs] + where + chunkSize = L.length bs + bs = toLazyByteString $ mconcat [ + putString "pdta" + , buildSubchunk "phdr" 38 buildPhdr (phdrs pdta1) + , buildSubchunk "pbag" 4 buildBag (pbags pdta1) + , buildSubchunk "pmod" 10 buildMod (pmods pdta1) + , buildSubchunk "pgen" 4 buildGen (pgens pdta1) + , buildSubchunk "inst" 22 buildInst (insts pdta1) + , buildSubchunk "ibag" 4 buildBag (ibags pdta1) + , buildSubchunk "imod" 10 buildMod (imods pdta1) + , buildSubchunk "igen" 4 buildGen (igens pdta1) + , buildSubchunk "shdr" 46 buildShdr (shdrs pdta1) + ] + +-- For some subchunks minimal number of records is two +-- but this check can be done later I am skiping it here +parseSubchunk :: String -> Word -> (Parser a) -> Parser (Array Word a) +parseSubchunk s size p = do + _ <- string s + 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 . EndAddressCoarseOffset . 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 Audio.ContLoop + 3 -> return $ SampleMode Audio.PressLoop + _ -> return $ SampleMode Audio.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] + + EndAddressCoarseOffset 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 Audio.ContLoop -> [putInt16le 54, putInt16le 1] + SampleMode Audio.PressLoop -> [putInt16le 54, putInt16le 3] + SampleMode Audio.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 ]
src/Codec/Wav.hs view
@@ -1,176 +1,176 @@--------------------------------------------------------------------------------- |--- Module : Codec.Wav--- Copyright : George Giorgidze--- License : BSD3--- --- Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/>--- Stability : Experimental--- Portability : Portable------ Module for reading and writting of WAVE (.wav) audio files.-----------------------------------------------------------------------------------{-# LANGUAGE FlexibleContexts #-}--module Codec.Wav (- importFile- , exportFile- , parseWav- , buildWav- , AudibleInWav(..)- ) where--import Data.Audio-import Data.ByteString.Parser-import Data.ByteString.Builder--import Data.Word-import Data.Int-import qualified Data.ByteString.Lazy as L-import Data.Monoid-import Data.Array.Unboxed-import Data.Array.IO-import Data.Bits---import Control.Monad-import Control.Applicative--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) => Int -> Parser a-parserSelector 8 = (parseSample :: Parser Word8) >>= return . fromSample . toSample-parserSelector 16 = (parseSample :: Parser Int16) >>= return . fromSample . toSample-parserSelector 24 = ((getWord24le >>= return . fromIntegral . (flip shiftL) 8) :: Parser Int32) >>= return . fromSample . toSample-parserSelector 32 = (parseSample :: Parser Int32) >>= return . fromSample . toSample-parserSelector 64 = (parseSample :: Parser Int64) >>= return . fromSample . toSample-parserSelector n = fail $ show n ++ " bitsPerSample is not supported"--bytesPerSample :: (AudibleInWav a) => a -> Int-bytesPerSample a = div (bitsPerSample a) 8 --importFile :: (MArray IOUArray a IO, IArray UArray a, Audible a, AudibleInWav a) => FilePath -> IO (Either String (Audio a))-importFile n = do- bs <- L.readFile n- return $! runParser parseWav bs--exportFile :: (IArray UArray a, Audible a, AudibleInWav a) => FilePath -> Audio a -> IO ()-exportFile f w = L.writeFile f (toLazyByteString $ buildWav w)---- All numerical values are stored in little endian format----parseWav :: (MArray IOUArray a IO, IArray UArray 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- (sampleRate1,channelNumber1,bitsPerSample1) <- parseFmt- _ <- many parseUnknownChunk- sampleData1 <- parseData channelNumber1 bitsPerSample1- return $! (Audio sampleRate1 channelNumber1 sampleData1)--buildWav :: (IArray UArray 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 (Int,Int,Int)-parseFmt = do- _ <- string "fmt "- chunkSize <- getWord32le >>= return . fromIntegral- _ <- word16le 1 -- compression code- channelNumber1 <- getWord16le >>= return . fromIntegral- sampleRate1 <- getWord32le >>= return . fromIntegral- avgBytesPerSec <- getWord32le >>= return . fromIntegral- bytesPerSampleSlice <- getWord16le >>= return . fromIntegral- when (avgBytesPerSec /= sampleRate1 * bytesPerSampleSlice) $ - fail "avgBytesPerSec /= sampleRate * bytesPerSampleSlise"- bitsPerSample1 <- expect (\w -> (mod w 8 == 0) && w <= 64) getWord16le >>= return . fromIntegral- when (bytesPerSampleSlice /= (div bitsPerSample1 8) * channelNumber1) $ - fail "bytesPerSampleSlice /= (div bitsPerSample 8) * channelNumber"- skip (chunkSize - 16) -- skip extra fromat bytes- return $! (sampleRate1,channelNumber1,bitsPerSample1)--buildFmt :: (IArray UArray 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 :: (MArray IOUArray a IO, IArray UArray a, Audible a, AudibleInWav a)- => Int -> Int -> 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 UArray 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)+----------------------------------------------------------------------------- +-- | +-- Module : Codec.Wav +-- Copyright : George Giorgidze +-- License : BSD3 +-- +-- Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/> +-- Stability : Experimental +-- Portability : Portable +-- +-- Module for reading and writting of WAVE (.wav) audio files. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleContexts #-} + +module Codec.Wav ( + importFile + , exportFile + , parseWav + , buildWav + , AudibleInWav(..) + ) where + +import Data.Audio +import Data.ByteString.Parser +import Data.ByteString.Builder + +import Data.Word +import Data.Int +import qualified Data.ByteString.Lazy as L +import Data.Monoid +import Data.Array.Unboxed +import Data.Array.IO +import Data.Bits + + +import Control.Monad +import Control.Applicative + +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) => Int -> Parser a +parserSelector 8 = (parseSample :: Parser Word8) >>= return . fromSample . toSample +parserSelector 16 = (parseSample :: Parser Int16) >>= return . fromSample . toSample +parserSelector 24 = ((getWord24le >>= return . fromIntegral . (flip shiftL) 8) :: Parser Int32) >>= return . fromSample . toSample +parserSelector 32 = (parseSample :: Parser Int32) >>= return . fromSample . toSample +parserSelector 64 = (parseSample :: Parser Int64) >>= return . fromSample . toSample +parserSelector n = fail $ show n ++ " bitsPerSample is not supported" + +bytesPerSample :: (AudibleInWav a) => a -> Int +bytesPerSample a = div (bitsPerSample a) 8 + +importFile :: (MArray IOUArray a IO, IArray UArray a, Audible a, AudibleInWav a) => FilePath -> IO (Either String (Audio a)) +importFile n = do + bs <- L.readFile n + return $! runParser parseWav bs + +exportFile :: (IArray UArray a, Audible a, AudibleInWav a) => FilePath -> Audio a -> IO () +exportFile f w = L.writeFile f (toLazyByteString $ buildWav w) + +-- All numerical values are stored in little endian format +-- +parseWav :: (MArray IOUArray a IO, IArray UArray 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 + (sampleRate1,channelNumber1,bitsPerSample1) <- parseFmt + _ <- many parseUnknownChunk + sampleData1 <- parseData channelNumber1 bitsPerSample1 + return $! (Audio sampleRate1 channelNumber1 sampleData1) + +buildWav :: (IArray UArray 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 (Int,Int,Int) +parseFmt = do + _ <- string "fmt " + chunkSize <- getWord32le >>= return . fromIntegral + _ <- word16le 1 -- compression code + channelNumber1 <- getWord16le >>= return . fromIntegral + sampleRate1 <- getWord32le >>= return . fromIntegral + avgBytesPerSec <- getWord32le >>= return . fromIntegral + bytesPerSampleSlice <- getWord16le >>= return . fromIntegral + when (avgBytesPerSec /= sampleRate1 * bytesPerSampleSlice) $ + fail "avgBytesPerSec /= sampleRate * bytesPerSampleSlise" + bitsPerSample1 <- expect (\w -> (mod w 8 == 0) && w <= 64) getWord16le >>= return . fromIntegral + when (bytesPerSampleSlice /= (div bitsPerSample1 8) * channelNumber1) $ + fail "bytesPerSampleSlice /= (div bitsPerSample 8) * channelNumber" + skip (chunkSize - 16) -- skip extra fromat bytes + return $! (sampleRate1,channelNumber1,bitsPerSample1) + +buildFmt :: (IArray UArray 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 :: (MArray IOUArray a IO, IArray UArray a, Audible a, AudibleInWav a) + => Int -> Int -> 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 UArray a, Audible a, AudibleInWav a) => Audio a -> Builder +buildData a = mconcat [ + putString "data" + , putWord32le $ fromIntegral $ chunkSize + , buildSampleData buildSample sd] + where + sd = sampleData a + chunkSize = (fromIntegral $ sampleNumber sd) * (bytesPerSample $ sampleType sd) + +parseUnknownChunk :: Parser () +parseUnknownChunk = do + _ <- expect (\s -> s /= "data" && s /= "fmt ") (getString 4) + chunkSize <- getWord32le + skip(fromIntegral chunkSize) return ()
src/Data/Arbitrary.hs view
@@ -1,149 +1,116 @@--------------------------------------------------------------------------------- |--- Module : Data.Arbitrary--- Copyright : George Giorgidze--- License : BSD3--- --- Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/>--- Stability : Experimental--- Portability : Portable------ Additional instances of the 'Arbitrary' type class defined in 'Test.QuickCheck'.--- Some portions of code were copied from the test suite of 'binary' package.-----------------------------------------------------------------------------------{-# LANGUAGE FlexibleContexts, CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Data.Arbitrary (- arrayGen- , stringNulGen- ) where---import Test.QuickCheck--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L--import Data.Word-import Data.Int-import Data.Char--import Data.List-import Data.Array.IArray---- random since 1.0.1.0 defines the following instances-#if MIN_VERSION_random(1,0,1)--import System.Random ()--#else--import System.Random (RandomGen,Random,random,randomR)--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- (x1,g1) -> (fromIntegral x1, g1)-#endif--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+----------------------------------------------------------------------------- +-- | +-- Module : Data.Arbitrary +-- Copyright : George Giorgidze +-- License : BSD3 +-- +-- Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/> +-- Stability : Experimental +-- Portability : Portable +-- +-- Additional instances of the 'Arbitrary' type class defined in 'Test.QuickCheck'. +-- Some portions of code were copied from the test suite of 'binary' package. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleContexts, CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Arbitrary ( + arrayGen + , stringNulGen + , two + ) where + + +import Test.QuickCheck + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +import Data.Word +import Data.Char + +import Data.List +import Data.Array.IArray +import Control.Monad (liftM2) + +-- random since 1.0.1.0 defines the following instances +#if MIN_VERSION_random(1,0,1) + +import System.Random () + +#else + +import System.Random (RandomGen,Random,random,randomR) + +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 + (x1,g1) -> (fromIntegral x1, g1) +#endif + +instance Arbitrary L.ByteString where + arbitrary = arbitrary >>= return . L.fromChunks . filter (not. B.null) + +instance CoArbitrary L.ByteString where + coarbitrary s = coarbitrary (L.unpack s) + +instance Arbitrary B.ByteString where + arbitrary = B.pack `fmap` arbitrary + +instance CoArbitrary B.ByteString where + 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 + +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 + +two :: Monad m => m a -> m (a, a) +two m = liftM2 (,) m m
src/Data/Audio.hs view
@@ -1,150 +1,148 @@--------------------------------------------------------------------------------- |--- Module : Data.Audio--- Copyright : George Giorgidze--- License : BSD3------ Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/>--- Stability : Experimental--- Portability : Portable------ General purpose data type for representing an audio data.-----------------------------------------------------------------------------------{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Data.Audio (- Sample- , Audio (..)- , SampleData- , SampleMode(..)- , sampleType- , sampleNumber- , convert- , parseSampleData- , buildSampleData- , Audible- , toSample- , fromSample- ) where--import Data.Arbitrary-import Data.ByteString.Parser-import Data.ByteString.Builder--import Test.QuickCheck--import Data.Word-import Data.Int--import Data.Array.Unboxed-import Data.Array.IO--import Data.Monoid--import System.IO.Unsafe---type Sample = Double-type SampleData a = UArray Int a--class Audible a where- toSample :: a -> Sample- fromSample :: Sample -> a---- It is required that sampleNummer `mod` channelNumber == 0-data Audio a = Audio {- sampleRate :: Int- , channelNumber :: Int- , sampleData :: SampleData a- }--instance (Eq a, IArray UArray a) => Eq (Audio a) where- a1 == a2 = and [- sampleRate a1 == sampleRate a2- , channelNumber a1 == channelNumber a2- , assocs (sampleData a1) == assocs (sampleData a2)]---instance (Show a, IArray UArray a) => Show (Audio a) where- show a = "Sample Rate: " ++ (show $ sampleRate a) ++ "\n" ++- "Channel Number: " ++ (show $ channelNumber a) ++ "\n" ++- "Sample Data Array Bounds: " ++ (show $ bounds $ sampleData a)---instance (Arbitrary a, IArray UArray a) => Arbitrary (Audio a) where- arbitrary = do- sr <- choose (1, 44100 * 8)- cn <- choose (1, 64)- sn <- choose (1, 1024) >>= return . (fromIntegral cn *)- sd <- arrayGen sn- return (Audio sr cn sd)- coarbitrary = undefined--sampleNumber :: (IArray UArray a) => SampleData a -> Int-sampleNumber sd = (snd (bounds sd)) + 1--sampleType :: (IArray UArray a) => SampleData a -> a-sampleType sd = undefined `asTypeOf` (sd ! 0)--convert :: (Audible a, Audible b, IArray UArray a, IArray UArray b) => SampleData a -> SampleData b-convert sd = amap (fromSample . toSample) sd--parseSampleData :: (MArray IOUArray a IO, IArray UArray a) => Int -> Parser a -> Parser (SampleData a)-parseSampleData sn p = pAux 0 unsafeNewArray- where- pAux i acc | (i == sn) = seq i $ seq acc $ return acc- pAux i acc | otherwise = seq i $ seq acc $ do- s <- p- seq s (pAux (i + 1) (unsafeWriteArray acc i s))-- unsafeFreezeAux :: (MArray IOUArray a IO, IArray UArray a) => IOUArray Int a -> IO (SampleData a)- unsafeFreezeAux = unsafeFreeze-- unsafeNewArray = unsafePerformIO (newArray_ (0, sn - 1) >>= unsafeFreezeAux )- unsafeWriteArray a i e = unsafePerformIO (do a' <- unsafeThaw a; writeArray a' i e; unsafeFreezeAux a';)---buildSampleData :: (IArray UArray a) => (a -> Builder) -> SampleData a -> Builder-buildSampleData b = mconcat . map b . elems--instance Audible Int8 where- toSample a = (fromIntegral a) / (2 ** 7)- fromSample s = round $ s * (2 ** 7)-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--data SampleMode = NoLoop | ContLoop | PressLoop deriving (Eq, Show)--instance Arbitrary SampleMode where- arbitrary = oneof [return NoLoop, return ContLoop, return PressLoop]- coarbitrary = undefined+----------------------------------------------------------------------------- +-- | +-- Module : Data.Audio +-- Copyright : George Giorgidze +-- License : BSD3 +-- +-- Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/> +-- Stability : Experimental +-- Portability : Portable +-- +-- General purpose data type for representing an audio data. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Audio ( + Sample + , Audio (..) + , SampleData + , SampleMode(..) + , sampleType + , sampleNumber + , convert + , parseSampleData + , buildSampleData + , Audible + , toSample + , fromSample + ) where + +import Data.Arbitrary +import Data.ByteString.Parser +import Data.ByteString.Builder + +import Test.QuickCheck + +import Data.Word +import Data.Int + +import Data.Array.Unboxed +import Data.Array.IO + +import Data.Monoid + +import System.IO.Unsafe + + +type Sample = Double +type SampleData a = UArray Int a + +class Audible a where + toSample :: a -> Sample + fromSample :: Sample -> a + +-- It is required that sampleNummer `mod` channelNumber == 0 +data Audio a = Audio { + sampleRate :: Int + , channelNumber :: Int + , sampleData :: SampleData a + } + +instance (Eq a, IArray UArray a) => Eq (Audio a) where + a1 == a2 = and [ + sampleRate a1 == sampleRate a2 + , channelNumber a1 == channelNumber a2 + , assocs (sampleData a1) == assocs (sampleData a2)] + + +instance (Show a, IArray UArray a) => Show (Audio a) where + show a = "Sample Rate: " ++ (show $ sampleRate a) ++ "\n" ++ + "Channel Number: " ++ (show $ channelNumber a) ++ "\n" ++ + "Sample Data Array Bounds: " ++ (show $ bounds $ sampleData a) + + +instance (Arbitrary a, IArray UArray a) => Arbitrary (Audio a) where + arbitrary = do + sr <- choose (1, 44100 * 8) + cn <- choose (1, 64) + sn <- choose (1, 1024) >>= return . (fromIntegral cn *) + sd <- arrayGen sn + return (Audio sr cn sd) + +sampleNumber :: (IArray UArray a) => SampleData a -> Int +sampleNumber sd = (snd (bounds sd)) + 1 + +sampleType :: (IArray UArray a) => SampleData a -> a +sampleType sd = undefined `asTypeOf` (sd ! 0) + +convert :: (Audible a, Audible b, IArray UArray a, IArray UArray b) => SampleData a -> SampleData b +convert sd = amap (fromSample . toSample) sd + +parseSampleData :: (MArray IOUArray a IO, IArray UArray a) => Int -> Parser a -> Parser (SampleData a) +parseSampleData sn p = pAux 0 unsafeNewArray + where + pAux i acc | (i == sn) = seq i $ seq acc $ return acc + pAux i acc | otherwise = seq i $ seq acc $ do + s <- p + seq s (pAux (i + 1) (unsafeWriteArray acc i s)) + + unsafeFreezeAux :: (MArray IOUArray a IO, IArray UArray a) => IOUArray Int a -> IO (SampleData a) + unsafeFreezeAux = unsafeFreeze + + unsafeNewArray = unsafePerformIO (newArray_ (0, sn - 1) >>= unsafeFreezeAux ) + unsafeWriteArray a i e = unsafePerformIO (do a' <- unsafeThaw a; writeArray a' i e; unsafeFreezeAux a';) + + +buildSampleData :: (IArray UArray a) => (a -> Builder) -> SampleData a -> Builder +buildSampleData b = mconcat . map b . elems + +instance Audible Int8 where + toSample a = (fromIntegral a) / (2 ** 7) + fromSample s = round $ s * (2 ** 7) +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 + +data SampleMode = NoLoop | ContLoop | PressLoop deriving (Eq, Show) + +instance Arbitrary SampleMode where + arbitrary = oneof [return NoLoop, return ContLoop, return PressLoop]
src/Data/ByteString/Builder.hs view
@@ -1,386 +1,386 @@--------------------------------------------------------------------------------- |--- Module : Data.ByteString.Builder--- Copyright : Lennart Kolmodin, Ross Paterson, George Giorgidze--- License : BSD3--- --- Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/>--- Stability : experimental--- Portability : Portable------ Efficient construction of lazy bytestrings.----------------------------------------------------------------------------------module Data.ByteString.Builder (-- -- * The Builder type- Builder- , toLazyByteString-- -- * Constructing Builders- , empty- , singleton- , putWord8- , putInt8- , append- , fromByteString -- :: S.ByteString -> Builder- , fromLazyByteString -- :: L.ByteString -> Builder- , putString-- -- * Flushing the buffer state- , flush-- -- * Derived Builders- -- ** Big-endian writes- , putWord16be -- :: Word16 -> Builder- , putWord24be -- :: Word32 -> Builder- , putWord32be -- :: Word32 -> Builder- , putWord64be -- :: Word64 -> Builder-- , putInt16be -- :: Int16 -> Builder- , putInt32be -- :: Int32 -> Builder- , putInt64be -- :: Int64 -> Builder-- -- ** Little-endian writes- , putWord16le -- :: Word16 -> Builder- , putWord24le -- :: Word32 -> Builder- , putWord32le -- :: Word32 -> Builder- , putWord64le -- :: Word64 -> Builder-- , putInt16le -- :: Int16 -> Builder- , putInt32le -- :: Int32 -> Builder- , putInt64le -- :: Int64 -> Builder-- -- ** Host-endian, unaligned writes- , putWordHost -- :: Word -> Builder- , putWord16host -- :: Word16 -> Builder- , putWord32host -- :: Word32 -> Builder- , putWord64host -- :: Word64 -> Builder- -- Variable length numbers- , putVarLenBe- , putVarLenLe-- ) where--import Foreign hiding (unsafePerformIO)-import System.IO.Unsafe (unsafePerformIO)-import Data.Monoid-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------------------------------------------------------------------------------- | 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+----------------------------------------------------------------------------- +-- | +-- Module : Data.ByteString.Builder +-- Copyright : Lennart Kolmodin, Ross Paterson, George Giorgidze +-- License : BSD3 +-- +-- Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/> +-- Stability : experimental +-- Portability : Portable +-- +-- Efficient construction of lazy bytestrings. +-- +----------------------------------------------------------------------------- +module Data.ByteString.Builder ( + + -- * The Builder type + Builder + , toLazyByteString + + -- * Constructing Builders + , empty + , singleton + , putWord8 + , putInt8 + , append + , fromByteString -- :: S.ByteString -> Builder + , fromLazyByteString -- :: L.ByteString -> Builder + , putString + + -- * Flushing the buffer state + , flush + + -- * Derived Builders + -- ** Big-endian writes + , putWord16be -- :: Word16 -> Builder + , putWord24be -- :: Word32 -> Builder + , putWord32be -- :: Word32 -> Builder + , putWord64be -- :: Word64 -> Builder + + , putInt16be -- :: Int16 -> Builder + , putInt32be -- :: Int32 -> Builder + , putInt64be -- :: Int64 -> Builder + + -- ** Little-endian writes + , putWord16le -- :: Word16 -> Builder + , putWord24le -- :: Word32 -> Builder + , putWord32le -- :: Word32 -> Builder + , putWord64le -- :: Word64 -> Builder + + , putInt16le -- :: Int16 -> Builder + , putInt32le -- :: Int32 -> Builder + , putInt64le -- :: Int64 -> Builder + + -- ** Host-endian, unaligned writes + , putWordHost -- :: Word -> Builder + , putWord16host -- :: Word16 -> Builder + , putWord32host -- :: Word32 -> Builder + , putWord64host -- :: Word64 -> Builder + -- Variable length numbers + , putVarLenBe + , putVarLenLe + + ) where + +import Foreign hiding (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO) +import Data.Monoid +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 + + +------------------------------------------------------------------------ + +-- | A 'Builder' is an efficient way to build lazy 'L.ByteString's. +-- There are several functions for constructing 'Builder's, but only one +-- to inspect them: to extract any data, you have to turn them into lazy +-- 'L.ByteString's using 'toLazyByteString'. +-- +-- Internally, a 'Builder' constructs a lazy 'L.Bytestring' by filling byte +-- arrays piece by piece. As each buffer is filled, it is \'popped\' +-- off, to become a new chunk of the resulting lazy 'L.ByteString'. +-- All this is hidden from the user of the 'Builder'. + +newtype Builder = Builder { + -- Invariant (from Data.ByteString.Lazy): + -- The lists include no null ByteStrings. + runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString] + } + +instance Monoid Builder where + mempty = empty + mappend = append + +------------------------------------------------------------------------ + +-- | /O(1)./ The empty Builder, satisfying +-- +-- * @'toLazyByteString' 'empty' = 'L.empty'@ +-- +empty :: Builder +empty = Builder id + +-- | /O(1)./ A Builder taking a single byte, satisfying +-- +-- * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@ +-- +singleton :: Word8 -> Builder +singleton = writeN 1 . flip poke + +putWord8 :: Word8 -> Builder +putWord8 = singleton +------------------------------------------------------------------------ + +-- | /O(1)./ The concatenation of two Builders, an associative operation +-- with identity 'empty', satisfying +-- +-- * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@ +-- +append :: Builder -> Builder -> Builder +append (Builder f) (Builder g) = Builder (f . g) + +-- | /O(1)./ A Builder taking a 'S.ByteString', satisfying +-- +-- * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@ +-- +fromByteString :: S.ByteString -> Builder +fromByteString bs + | S.null bs = empty + | otherwise = flush `append` mapBuilder (bs :) + +-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying +-- +-- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@ +-- +fromLazyByteString :: L.ByteString -> Builder +fromLazyByteString bss = flush `append` mapBuilder (L.toChunks bss ++) + +putString :: String -> Builder +putString = fromLazyByteString . L.pack . map c2w + +------------------------------------------------------------------------ + +-- Our internal buffer type +data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- used bytes + {-# UNPACK #-} !Int -- length left + +------------------------------------------------------------------------ + +-- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'. +-- The construction work takes place if and when the relevant part of +-- the lazy 'L.ByteString' is demanded. +-- +toLazyByteString :: Builder -> L.ByteString +toLazyByteString m = L.fromChunks $ unsafePerformIO $ do + buf <- newBuffer defaultSize + return (runBuilder (m `append` flush) (const []) buf) + +-- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any, +-- yielding a new chunk in the result lazy 'L.ByteString'. +flush :: Builder +flush = Builder $ \ k buf@(Buffer p o u l) -> + if u == 0 + then k buf + else S.PS p o u : k (Buffer p (o+u) 0 l) + +------------------------------------------------------------------------ + +-- +-- copied from Data.ByteString.Lazy +-- +defaultSize :: Int +defaultSize = 32 * k - overhead + where k = 1024 + overhead = 2 * sizeOf (undefined :: Int) + +------------------------------------------------------------------------ + +-- | Sequence an IO operation on the buffer +unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder +unsafeLiftIO f = Builder $ \ k buf -> inlinePerformIO $ do + buf' <- f buf + return (k buf') + +-- | Get the size of the buffer +withSize :: (Int -> Builder) -> Builder +withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> + runBuilder (f l) k buf + +-- | Map the resulting list of bytestrings. +mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder +mapBuilder f = Builder (f .) + +------------------------------------------------------------------------ + +-- | Ensure that there are at least @n@ many bytes available. +ensureFree :: Int -> Builder +ensureFree n = n `seq` withSize $ \ l -> + if n <= l then empty else + flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize))) + +-- | Ensure that @n@ many bytes are available, and then use @f@ to write some +-- bytes into the memory. +writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder +writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f) + +writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer +writeNBuffer n f (Buffer fp o u l) = do + withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) + return (Buffer fp o (u+n) (l-n)) + +newBuffer :: Int -> IO Buffer +newBuffer size = do + fp <- S.mallocByteString size + return $! Buffer fp 0 0 size + +------------------------------------------------------------------------ +-- Aligned, host order writes of storable values + +-- | Ensure that @n@ many bytes are available, and then use @f@ to write some +-- storable values into the memory. +writeNbytes :: Storable a => Int -> (Ptr a -> IO ()) -> Builder +writeNbytes n f = ensureFree n `append` unsafeLiftIO (writeNBufferBytes n f) + +writeNBufferBytes :: Storable a => Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer +writeNBufferBytes n f (Buffer fp o u l) = do + withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) + return (Buffer fp o (u+n) (l-n)) + +------------------------------------------------------------------------ + +-- +-- We rely on the fromIntegral to do the right masking for us. +-- The inlining here is critical, and can be worth 4x performance +-- + +-- | Write a Word16 in big endian format +putWord16be :: Word16 -> Builder +putWord16be w = writeN 2 $ \p -> do + poke p (fromIntegral (shiftR w 8) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) + +-- | Write a Word16 in little endian format +putWord16le :: Word16 -> Builder +putWord16le w = writeN 2 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8) + +-- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16) + +-- | Write a 24 bit number in big endian format represented as Word32 +putWord24be :: Word32 -> Builder +putWord24be w = writeN 3 $ \p -> do + poke p (fromIntegral (shiftR w 16) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (w) :: Word8) + +-- | Write a 24 bit number in little endian format represented as Word32 +putWord24le :: Word32 -> Builder +putWord24le w = writeN 3 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftR w 16) :: Word8) + +-- | Write a Word32 in big endian format +putWord32be :: Word32 -> Builder +putWord32be w = writeN 4 $ \p -> do + poke p (fromIntegral (shiftR w 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftR w 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftR w 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) + +-- +-- a data type to tag Put/Check. writes construct these which are then +-- inlined and flattened. matching Checks will be more robust with rules. +-- + +-- | Write a Word32 in little endian format +putWord32le :: Word32 -> Builder +putWord32le w = writeN 4 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftR w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftR w 24) :: Word8) + +-- on a little endian machine: +-- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32) + +-- | Write a Word64 in big endian format +putWord64be :: Word64 -> Builder +putWord64be w = writeN 8 $ \p -> do + poke p (fromIntegral (shiftR w 56) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftR w 48) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftR w 40) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftR w 32) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftR w 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftR w 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftR w 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (w) :: Word8) + +-- | Write a Word64 in little endian format +putWord64le :: Word64 -> Builder +putWord64le w = writeN 8 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftR w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftR w 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftR w 32) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftR w 40) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftR w 48) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftR w 56) :: Word8) + +-- on a little endian machine: +-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64) + +----------------------------------------------------------------------- + +putInt8 :: Int8 -> Builder +putInt8 = putWord8 . fromIntegral + +putInt16le :: Int16 -> Builder +putInt16le = putWord16le . fromIntegral + +putInt16be :: Int16 -> Builder +putInt16be = putWord16be . fromIntegral + +putInt32le :: Int32 -> Builder +putInt32le = putWord32le . fromIntegral + +putInt32be :: Int32 -> Builder +putInt32be = putWord32be . fromIntegral + +putInt64le :: Int64 -> Builder +putInt64le = putWord64le . fromIntegral + +putInt64be :: Int64 -> Builder +putInt64be = putWord64be . fromIntegral + +------------------------------------------------------------------------ +-- Unaligned, word size ops + +-- | /O(1)./ A Builder taking a single native machine word. The word is +-- written in host order, host endian form, for the machine you're on. +-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, +-- 4 bytes. Values written this way are not portable to +-- different endian or word sized machines, without conversion. +-- +putWordHost :: Word -> Builder +putWordHost w = writeNbytes (sizeOf (undefined :: Word)) (\p -> poke p w) + +-- | Write a Word16 in native host order and host endianness. +-- 2 bytes will be written, unaligned. +putWord16host :: Word16 -> Builder +putWord16host w16 = writeNbytes (sizeOf (undefined :: Word16)) (\p -> poke p w16) + +-- | Write a Word32 in native host order and host endianness. +-- 4 bytes will be written, unaligned. +putWord32host :: Word32 -> Builder +putWord32host w32 = writeNbytes (sizeOf (undefined :: Word32)) (\p -> poke p w32) + +-- | Write a Word64 in native host order. +-- On a 32 bit machine we write two host order Word32s, in big endian form. +-- 8 bytes will be written, unaligned. +putWord64host :: Word64 -> Builder +putWord64host w = writeNbytes (sizeOf (undefined :: Word64)) (\p -> poke p w) + +------------------------------------------------------------------------ + +putVarLenBe :: Word64 -> Builder +putVarLenBe w = varLenAux2 $ reverse $ varLenAux1 w + +putVarLenLe :: Word64 -> Builder +putVarLenLe w = varLenAux2 $ varLenAux1 w + +varLenAux1 :: Word64 -> [Word8] +varLenAux1 0 = [] +varLenAux1 w = (fromIntegral $ w .&. 0x7F) : (varLenAux1 $ shiftR w 7) + +varLenAux2 :: [Word8] -> Builder +varLenAux2 [] = putWord8 0 +varLenAux2 [w] = putWord8 w varLenAux2 (w : ws) = putWord8 (setBit w 7) `append` varLenAux2 ws
src/Data/ByteString/Parser.hs view
@@ -1,596 +1,596 @@--------------------------------------------------------------------------------- |--- Module : Data.ByteString.Parser--- Copyright : Lennart Kolmodin, George Giorgidze--- License : BSD3--- --- Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/>--- Stability : experimental--- Portability : Portable------ A monad for efficiently building structures from--- encoded lazy ByteStrings.-----------------------------------------------------------------------------------{-# LANGUAGE CPP #-}--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 hiding (unsafePerformIO)--#if MIN_VERSION_base(4,4,0)-import Control.Monad.ST.Unsafe (unsafeInterleaveST)-#else-import Control.Monad.ST (unsafeInterleaveST)-#endif-import Control.Monad.ST hiding (unsafeInterleaveST)-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+----------------------------------------------------------------------------- +-- | +-- Module : Data.ByteString.Parser +-- Copyright : Lennart Kolmodin, George Giorgidze +-- License : BSD3 +-- +-- Maintainer : George Giorgidze <http://cs.nott.ac.uk/~ggg/> +-- Stability : experimental +-- Portability : Portable +-- +-- A monad for efficiently building structures from +-- encoded lazy ByteStrings. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} + +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 hiding (unsafePerformIO) + +#if MIN_VERSION_base(4,4,0) +import Control.Monad.ST.Unsafe (unsafeInterleaveST) +#else +import Control.Monad.ST (unsafeInterleaveST) +#endif +import Control.Monad.ST hiding (unsafeInterleaveST) +import Data.STRef + +-- | The parse state +data S = S {-# UNPACK #-} !B.ByteString -- current chunk + L.ByteString -- the rest of the input + {-# UNPACK #-} !Int64 -- bytes read + +-- | The Get monad is just a State monad carrying around the input ByteString +newtype Parser a = Parser { unParser :: S -> Either String (a, S) } + +instance Functor Parser where + fmap f m = Parser $ \s -> case unParser m s of + Left e -> Left e + Right (a, s') -> Right (f a, s') + +instance Monad Parser where + return a = Parser (\s -> Right (a, s)) + m >>= k = Parser $ \s -> case (unParser m) s of + Left e -> Left e + Right (a, s') -> (unParser (k a)) s' + fail err = Parser $ \(S _ _ bytes) -> + Left (err ++ ". Failed reading at byte position " ++ show bytes) +instance MonadPlus Parser where + mzero = Parser $ \_ -> Left [] + mplus p1 p2 = Parser $ \s -> case (unParser p1 s) of + Left e1 -> case (unParser p2 s) of + Left e2 -> Left (e1 ++ "\n" ++ e2) + ok -> ok + ok -> ok + +instance Applicative Parser where + pure = return + (<*>) = ap + +instance Alternative Parser where + empty = mzero + (<|>) = mplus + +------------------------------------------------------------------------ + +get :: Parser S +get = Parser $ \s -> Right (s, s) + +put :: S -> Parser () +put s = Parser $ \_ -> Right ((), s) + +------------------------------------------------------------------------ + +initState :: L.ByteString -> S +initState xs = mkState xs 0 + +mkState :: L.ByteString -> Int64 -> S +mkState l = case l of + L.Empty -> S B.empty L.empty + L.Chunk x xs -> S x xs + +-- | Run the Get monad applies a 'get'-based parser on the input ByteString +runParser :: Parser a -> L.ByteString -> Either String a +runParser m str = case unParser m (initState str) of + Left e -> Left e + Right (a, _) -> Right a + +-- | Run the Get monad applies a 'get'-based parser on the input +-- ByteString. Additional to the result of get it returns the number of +-- consumed bytes and the rest of the input. +runParserState :: Parser a -> L.ByteString -> Int64 -> Either String (a, L.ByteString, Int64) +runParserState m str off = + case unParser m (mkState str off) of + Left e -> Left e + Right (a, ~(S s ss newOff)) -> Right (a, s `join` ss, newOff) + +------------------------------------------------------------------------ + +choice :: [Parser a] -> Parser a +choice = foldl (<|>) mzero + +-- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. +skip :: Word64 -> Parser () +skip n = readN (fromIntegral n) (const ()) + +-- | Run @ga@, but return without consuming its input. +-- Fails if @ga@ fails. +lookAhead :: Parser a -> Parser a +lookAhead ga = do + s <- get + a <- ga + put s + return a + +-- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. +-- Fails if @gma@ fails. +lookAheadM :: Parser (Maybe a) -> Parser (Maybe a) +lookAheadM gma = do + s <- get + ma <- gma + when (isNothing ma) $ put s + return ma + +-- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'. +-- Fails if @gea@ fails. +lookAheadE :: Parser (Either a b) -> Parser (Either a b) +lookAheadE gea = do + s <- get + ea <- gea + case ea of + Left _ -> put s + _ -> return () + return ea + +expect :: (Show a, Eq a) => (a -> Bool) -> Parser a -> Parser a +expect f p = do + v <- p + when (not $ f v) $ fail $ show v ++ " was not expected." + return v + +getString :: Int -> Parser String +getString l = do + bs <- getLazyByteString (fromIntegral l) + return $! map B.w2c (L.unpack bs) + +getStringNul :: Parser String +getStringNul = do + bs <- getLazyByteStringNul + return $! map B.w2c (L.unpack bs) + +string :: String -> Parser String +string s = expect (s ==) (getString $ length s) + +-- Utility + +-- | Get the total number of bytes read to this point. +bytesRead :: Parser Int64 +bytesRead = do + S _ _ b <- get + return b + +-- | Get the number of remaining unparsed bytes. +-- Useful for checking whether all input has been consumed. +-- Note that this forces the rest of the input. +remaining :: Parser Int64 +remaining = do + S s ss _ <- get + return $! (fromIntegral (B.length s) + L.length ss) + +-- | Test whether all input has been consumed, +-- i.e. there are no remaining unparsed bytes. +isEmpty :: Parser Bool +isEmpty = do + S s ss _ <- get + return $! (B.null s && L.null ss) + +------------------------------------------------------------------------ +-- Utility with ByteStrings + +-- | An efficient 'get' method for strict ByteStrings. Fails if fewer +-- than @n@ bytes are left in the input. +getByteString :: Int -> Parser B.ByteString +getByteString n = readN n id + +-- | An efficient 'get' method for lazy ByteStrings. Does not fail if fewer than +-- @n@ bytes are left in the input. +getLazyByteString :: Int64 -> Parser L.ByteString +getLazyByteString n = do + S s ss bytes <- get + let big = s `join` ss + case splitAtST n big of + (consume, rest) -> do put $ mkState rest (bytes + n) + return consume + +-- | Get a lazy ByteString that is terminated with a NUL byte. Fails +-- if it reaches the end of input without hitting a NUL. +getLazyByteStringNul :: Parser L.ByteString +getLazyByteStringNul = do + S s ss bytes <- get + let big = s `join` ss + (consume, t) = L.break (== 0) big + (h, rest) = L.splitAt 1 t + when (L.null h) $ fail "too few bytes" + put $ mkState rest (bytes + L.length consume + 1) + return consume + +-- | Get the remaining bytes as a lazy ByteString +getRemainingLazyByteString :: Parser L.ByteString +getRemainingLazyByteString = do + S s ss _ <- get + return $! (s `join` ss) + +------------------------------------------------------------------------ +-- Helpers + +-- | Pull @n@ bytes from the input, as a strict ByteString. +getBytes :: Int -> Parser B.ByteString +getBytes n = do + S s ss bytes <- get + if n <= B.length s + then do let (consume,rest) = B.splitAt n s + put $! S rest ss (bytes + fromIntegral n) + return $! consume + else + case L.splitAt (fromIntegral n) (s `join` ss) of + (consuming, rest) -> + do let now = B.concat . L.toChunks $ consuming + put $! mkState rest (bytes + fromIntegral n) + -- forces the next chunk before this one is returned + when (B.length now < n) $ fail "too few bytes" + return now + + +join :: B.ByteString -> L.ByteString -> L.ByteString +join bb lb + | B.null bb = lb + | otherwise = L.Chunk bb lb + +-- | Split a ByteString. If the first result is consumed before the -- +-- second, this runs in constant heap space. +-- +-- You must force the returned tuple for that to work, e.g. +-- +-- > case splitAtST n xs of +-- > (ys,zs) -> consume ys ... consume zs +-- +splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString) +splitAtST i ps | i <= 0 = (L.empty, ps) +splitAtST i ps = runST ( + do r <- newSTRef undefined + xs <- first r i ps + ys <- unsafeInterleaveST (readSTRef r) + return (xs, ys)) + + where + first r 0 xs@(L.Chunk _ _) = writeSTRef r xs >> return L.Empty + first r _ L.Empty = writeSTRef r L.Empty >> return L.Empty + + first r n (L.Chunk x xs) + | n < l = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs) + return $! L.Chunk (B.take (fromIntegral n) x) L.Empty + | otherwise = do writeSTRef r (L.drop (n - l) xs) + liftM (L.Chunk x) $ unsafeInterleaveST (first r (n - l) xs) + + where l = fromIntegral (B.length x) + +-- Pull n bytes from the input, and apply a parser to those bytes, +-- yielding a value. If less than @n@ bytes are available, fail with an +-- error. This wraps @getBytes@. +readN :: Int -> (B.ByteString -> a) -> Parser a +readN n f = fmap f $ getBytes n + + +------------------------------------------------------------------------ +-- Primtives + +-- helper, get a raw Ptr onto a strict ByteString copied out of the +-- underlying lazy byteString. So many indirections from the raw parser +-- state that my head hurts... + +getPtr :: Storable a => Int -> Parser a +getPtr n = do + (fp,o,_) <- readN n B.toForeignPtr + return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) + +------------------------------------------------------------------------ + +satisfy :: (Word8 -> Bool) -> Parser Word8 +satisfy f = do + w <- getWord8 + guard (f w) + return w + +-- | Read a Word8 from the monad state +getWord8 :: Parser Word8 +getWord8 = getPtr (sizeOf (undefined :: Word8)) + +word8 :: Word8 -> Parser Word8 +word8 w = expect (w ==) getWord8 + +-- | Read a Word16 in big endian format +getWord16be :: Parser Word16 +getWord16be = do + s <- readN 2 id + return $! (fromIntegral (s `B.index` 0) `shiftL` 8) .|. + (fromIntegral (s `B.index` 1)) + +word16be :: Word16 -> Parser Word16 +word16be w = expect (w ==) getWord16be + +-- | Read a Word16 in little endian format +getWord16le :: Parser Word16 +getWord16le = do + s <- readN 2 id + return $! (fromIntegral (s `B.index` 1) `shiftL` 8) .|. + (fromIntegral (s `B.index` 0) ) + +word16le :: Word16 -> Parser Word16 +word16le w = expect (w ==) getWord16le + +-- | Read a 24 bit word into Word32 in big endian format +getWord24be :: Parser Word32 +getWord24be = do + s <- readN 3 id + return $! (fromIntegral (s `B.index` 0) `shiftL` 16) .|. + (fromIntegral (s `B.index` 1) `shiftL` 8) .|. + (fromIntegral (s `B.index` 2) ) + +word24be :: Word32 -> Parser Word32 +word24be w = expect (w ==) getWord24be + +getWord24le :: Parser Word32 +getWord24le = do + s <- readN 3 id + return $! (fromIntegral (s `B.index` 2) `shiftL` 16) .|. + (fromIntegral (s `B.index` 1) `shiftL` 8) .|. + (fromIntegral (s `B.index` 0) ) + +word24le :: Word32 -> Parser Word32 +word24le w = expect (w ==) getWord24le + +-- | Read a Word32 in big endian format +getWord32be :: Parser Word32 +getWord32be = do + s <- readN 4 id + return $! (fromIntegral (s `B.index` 0) `shiftL` 24) .|. + (fromIntegral (s `B.index` 1) `shiftL` 16) .|. + (fromIntegral (s `B.index` 2) `shiftL` 8) .|. + (fromIntegral (s `B.index` 3) ) + +word32be :: Word32 -> Parser Word32 +word32be w = expect (w ==) getWord32be + +-- | Read a Word32 in little endian format +getWord32le :: Parser Word32 +getWord32le = do + s <- readN 4 id + return $! (fromIntegral (s `B.index` 3) `shiftL` 24) .|. + (fromIntegral (s `B.index` 2) `shiftL` 16) .|. + (fromIntegral (s `B.index` 1) `shiftL` 8) .|. + (fromIntegral (s `B.index` 0) ) + +word32le :: Word32 -> Parser Word32 +word32le w = expect (w ==) getWord32le + + +-- | Read a Word64 in big endian format +getWord64be :: Parser Word64 +getWord64be = do + s <- readN 8 id + return $! (fromIntegral (s `B.index` 0) `shiftL` 56) .|. + (fromIntegral (s `B.index` 1) `shiftL` 48) .|. + (fromIntegral (s `B.index` 2) `shiftL` 40) .|. + (fromIntegral (s `B.index` 3) `shiftL` 32) .|. + (fromIntegral (s `B.index` 4) `shiftL` 24) .|. + (fromIntegral (s `B.index` 5) `shiftL` 16) .|. + (fromIntegral (s `B.index` 6) `shiftL` 8) .|. + (fromIntegral (s `B.index` 7) ) + +word64be :: Word64 -> Parser Word64 +word64be w = expect (w ==) getWord64be + +-- | Read a Word64 in little endian format +getWord64le :: Parser Word64 +getWord64le = do + s <- readN 8 id + return $! (fromIntegral (s `B.index` 7) `shiftL` 56) .|. + (fromIntegral (s `B.index` 6) `shiftL` 48) .|. + (fromIntegral (s `B.index` 5) `shiftL` 40) .|. + (fromIntegral (s `B.index` 4) `shiftL` 32) .|. + (fromIntegral (s `B.index` 3) `shiftL` 24) .|. + (fromIntegral (s `B.index` 2) `shiftL` 16) .|. + (fromIntegral (s `B.index` 1) `shiftL` 8) .|. + (fromIntegral (s `B.index` 0) ) + +word64le :: Word64 -> Parser Word64 +word64le w = expect (w ==) getWord64le +------------------------------------------------------------------------ +getInt8 :: Parser Int8 +getInt8 = getWord8 >>= return . fromIntegral + +int8 :: Int8 -> Parser Int8 +int8 i = expect (i ==) getInt8 + +getInt16le :: Parser Int16 +getInt16le = getWord16le >>= return . fromIntegral + +int16le :: Int16 -> Parser Int16 +int16le i = expect (i ==) getInt16le + +getInt16be :: Parser Int16 +getInt16be = getWord16be >>= return . fromIntegral + +int16be :: Int16 -> Parser Int16 +int16be i = expect (i ==) getInt16be + +getInt32le :: Parser Int32 +getInt32le = getWord32le >>= return . fromIntegral + +int32le :: Int32 -> Parser Int32 +int32le i = expect (i ==) getInt32le + +getInt32be :: Parser Int32 +getInt32be = getWord32be >>= return . fromIntegral + +int32be :: Int32 -> Parser Int32 +int32be i = expect (i ==) getInt32be + +getInt64le :: Parser Int64 +getInt64le = getWord64le >>= return . fromIntegral + +int64le :: Int64 -> Parser Int64 +int64le i = expect (i ==) getInt64le + +getInt64be :: Parser Int64 +getInt64be = getWord64be >>= return . fromIntegral + +int64be :: Int64 -> Parser Int64 +int64be i = expect (i ==) getInt64be + +------------------------------------------------------------------------ +-- Host-endian reads + +-- | /O(1)./ Read a single native machine word. The word is read in +-- host order, host endian form, for the machine you're on. On a 64 bit +-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes. +getWordHost :: Parser Word +getWordHost = getPtr (sizeOf (undefined :: Word)) + +wordHost :: Word -> Parser Word +wordHost w = expect (w ==) getWordHost + +-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness. +getWord16host :: Parser Word16 +getWord16host = getPtr (sizeOf (undefined :: Word16)) + +word16host :: Word16 -> Parser Word16 +word16host w = expect (w ==) getWord16host + +-- | /O(1)./ Read a Word32 in native host order and host endianness. +getWord32host :: Parser Word32 +getWord32host = getPtr (sizeOf (undefined :: Word32)) + +word32host :: Word32 -> Parser Word32 +word32host w = expect (w ==) getWord32host + +-- | /O(1)./ Read a Word64 in native host order and host endianess. +getWord64host :: Parser Word64 +getWord64host = getPtr (sizeOf (undefined :: Word64)) + +word64host :: Word64 -> Parser Word64 +word64host w = expect (w ==) getWord64host + +-- Variable length numbers + +getVarLenBe :: Parser Word64 +getVarLenBe = f 0 + where + f :: Word64 -> Parser Word64 + f acc = do + w <- getWord8 >>= return . fromIntegral + if testBit w 7 + then f $! (shiftL acc 7) .|. (clearBit w 7) + else return $! (shiftL acc 7) .|. w + +varLenBe :: Word64 -> Parser Word64 +varLenBe a = expect (a ==) getVarLenBe + +getVarLenLe :: Parser Word64 +getVarLenLe = do + w <- getWord8 >>= return . fromIntegral + if testBit w 7 + then do + w' <- getVarLenLe + return $! (clearBit w 7) .|. (shiftL w' 7) + else return $! w + +varLenLe :: Word64 -> Parser Word64 varLenLe a = expect (a ==) getVarLenLe
src/Tests/Main.hs view
@@ -1,177 +1,181 @@-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-import System.FilePath--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 two tests are commented, because they fail- -- Reason for that is the fact that Double is not abble to accomodate- -- 64 bit numbers in full precision- where- 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 "mid.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 "wav.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 sd1 = (convert $ sampleData a) :: SampleData Word8- when (not $ roundTrip Wav.buildWav Wav.parseWav (a {sampleData = sd1})) $ fail "Failed\n"- let sd2 = (convert $ sampleData a) :: SampleData Int32- when (not $ roundTrip Wav.buildWav Wav.parseWav (a {sampleData = sd2})) $ fail "Failed\n"- putStrLn "OK"- Wav.exportFile ("./tmp/" ++ (takeBaseName n) ++ ".wav") a--testSoundFont :: IO ()-testSoundFont = do- putStrLn "TESTING PARSING AND BUILDING of SoundFont"-- test $ roundTrip SF.buildSoundFont SF.parseSoundFont-- c <- readFile "sf2.txt"- let soundFontFiles = lines c- 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"- SF.exportFile ("./tmp/" ++ (takeBaseName n) ++ ".sf2") sf--testParserBuilder :: IO ()-testParserBuilder = do- putStrLn "TESTING PARSING AND BUILDING OF NUMERICAL TYPES"-- test $ roundTrip putWord8 getWord8- test $ roundTrip putWord16be getWord16be- test $ roundTrip putWord16le getWord16le- 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+module Main where + +import Codec.Midi +import qualified Codec.Wav as Wav +import qualified Codec.SoundFont as SF +import Data.Audio +import Data.Arbitrary + +import Data.ByteString.Parser +import Data.ByteString.Builder + +import Test.QuickCheck hiding ((.&.)) +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 +import System.FilePath + +test :: Testable prop => prop -> IO () +test = quickCheck + +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 two tests are commented, because they fail + -- Reason for that is the fact that Double is not abble to accomodate + -- 64 bit numbers in full precision + where + 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 "mid.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 "wav.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 sd1 = (convert $ sampleData a) :: SampleData Word8 + when (not $ roundTrip Wav.buildWav Wav.parseWav (a {sampleData = sd1})) $ fail "Failed\n" + let sd2 = (convert $ sampleData a) :: SampleData Int32 + when (not $ roundTrip Wav.buildWav Wav.parseWav (a {sampleData = sd2})) $ fail "Failed\n" + putStrLn "OK" + Wav.exportFile ("./tmp/" ++ (takeBaseName n) ++ ".wav") a + +testSoundFont :: IO () +testSoundFont = do + putStrLn "TESTING PARSING AND BUILDING of SoundFont" + + test $ roundTrip SF.buildSoundFont SF.parseSoundFont + + c <- readFile "sf2.txt" + let soundFontFiles = lines c + 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" + SF.exportFile ("./tmp/" ++ (takeBaseName n) ++ ".sf2") sf + +testParserBuilder :: IO () +testParserBuilder = do + putStrLn "TESTING PARSING AND BUILDING OF NUMERICAL TYPES" + + test $ roundTrip putWord8 getWord8 + test $ roundTrip putWord16be getWord16be + test $ roundTrip putWord16le getWord16le + 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