HCodecs 0.5.1 → 0.5.2

raw patch · 11 files changed

+3216/−3209 lines, 11 filesdep +faildep ~basesetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: fail

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• HCodecs.cabal +64/−62
• LICENSE +29/−29
• Setup.hs +2/−2
• src/Codec/ByteString/Builder.hs +395/−395
• src/Codec/ByteString/Parser.hs +600/−595
• src/Codec/Internal/Arbitrary.hs +52/−52
• src/Codec/Internal/TestSuite.hs +117/−117
• src/Codec/Midi.hs +717/−717
• src/Codec/SoundFont.hs +920/−920
• src/Codec/Wav.hs +175/−175
• src/Data/Audio.hs +145/−145

@@ -1,62 +1,64 @@-name: HCodecs-version: 0.5.1-cabal-Version: >= 1.8-license: BSD3-license-file: LICENSE-copyright: (c) 2007-2014 George Giorgidze-author: George Giorgidze-maintainer: George Giorgidze (giorgidze@gmail.com)-          , Pavel Krajcevski (krajcevski@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--source-repository head-  type:     git-  location: https://github.com/Mokosha/HCodecs.git--library-  hs-source-dirs: src-  ghc-options: -O3 -Wall-  build-depends:-      base             <  5-    , bytestring-    , random-    , semigroups-    , array            >= 0.4-    , QuickCheck       >= 2.0--  exposed-modules:-    Codec.Midi-    Codec.Wav-    Codec.SoundFont-    Codec.ByteString.Parser-    Codec.ByteString.Builder-    Data.Audio-  other-modules:-    Codec.Internal.Arbitrary--test-suite tests-  type: exitcode-stdio-1.0-  hs-source-dirs: src-  ghc-options: -O3 -Wall-  build-depends:-      base < 5-    , bytestring-    , random-    , semigroups-    , array >= 0.4-    , QuickCheck >= 2.0--  main-is: Codec/Internal/TestSuite.hs+name: HCodecs
+version: 0.5.2
+cabal-Version: >= 1.8
+license: BSD3
+license-file: LICENSE
+copyright: (c) 2007-2014 George Giorgidze
+author: George Giorgidze
+maintainer: George Giorgidze (giorgidze@gmail.com)
+          , Pavel Krajcevski (krajcevski@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
+
+source-repository head
+  type:     git
+  location: https://github.com/Mokosha/HCodecs.git
+
+library
+  hs-source-dirs: src
+  ghc-options: -O3 -Wall
+  build-depends:
+      base             <  5
+    , bytestring
+    , random
+    , semigroups
+    , array            >= 0.4
+    , QuickCheck       >= 2.0
+    , fail
+
+  exposed-modules:
+    Codec.Midi
+    Codec.Wav
+    Codec.SoundFont
+    Codec.ByteString.Parser
+    Codec.ByteString.Builder
+    Data.Audio
+  other-modules:
+    Codec.Internal.Arbitrary
+
+test-suite tests
+  type: exitcode-stdio-1.0
+  hs-source-dirs: src
+  ghc-options: -O3 -Wall
+  build-depends:
+      base < 5
+    , bytestring
+    , random
+    , semigroups
+    , array >= 0.4
+    , QuickCheck >= 2.0
+    , fail
+
+  main-is: Codec/Internal/TestSuite.hs

@@ -1,29 +1,29 @@-Copyright (c) 2007-2014 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-2014 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.

@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple
+main = defaultMain

@@ -1,395 +1,395 @@--------------------------------------------------------------------------------- |--- 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 Codec.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 qualified Data.ByteString.Internal as S-import qualified Data.ByteString          as S-import qualified Data.ByteString.Lazy     as L--import Foreign.Storable         (Storable, poke, sizeOf)-import Foreign.Ptr              (Ptr, plusPtr)-import Foreign.ForeignPtr       (ForeignPtr, withForeignPtr)-import System.IO.Unsafe         (unsafePerformIO)-import Data.ByteString.Internal (c2w)--import Data.Bits-import Data.Word-import Data.Int-import Data.Semigroup------------------------------------------------------------------------------ | 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 Semigroup Builder where-    (<>) = append--instance Monoid Builder where-    mempty  = empty-    mappend = (<>)------------------------------------------------------------------------------ | /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 -> unsafePerformIO $ 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+-----------------------------------------------------------------------------
+-- |
+-- 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 Codec.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 qualified Data.ByteString.Internal as S
+import qualified Data.ByteString          as S
+import qualified Data.ByteString.Lazy     as L
+
+import Foreign.Storable         (Storable, poke, sizeOf)
+import Foreign.Ptr              (Ptr, plusPtr)
+import Foreign.ForeignPtr       (ForeignPtr, withForeignPtr)
+import System.IO.Unsafe         (unsafePerformIO)
+import Data.ByteString.Internal (c2w)
+
+import Data.Bits
+import Data.Word
+import Data.Int
+import Data.Semigroup
+
+------------------------------------------------------------------------
+
+-- | 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 Semigroup Builder where
+    (<>) = append
+
+instance Monoid Builder where
+    mempty  = empty
+    mappend = (<>)
+
+------------------------------------------------------------------------
+
+-- | /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 -> unsafePerformIO $ 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

@@ -1,595 +1,600 @@--------------------------------------------------------------------------------- |--- 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.-----------------------------------------------------------------------------------module Codec.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 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.Storable        (Storable, peek, sizeOf)-import Foreign.Ptr             (plusPtr, castPtr)-import Foreign.ForeignPtr      (withForeignPtr)-import Control.Monad.ST        (runST)-import Control.Monad.ST.Unsafe (unsafeInterleaveST)--import Control.Monad-import Control.Applicative-import Data.STRef-import Data.Word-import Data.Int-import Data.Bits-import Data.Maybe--import System.IO.Unsafe        (unsafePerformIO)---- | 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 `bsJoin` 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 `bsJoin` 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 `bsJoin` 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 `bsJoin` 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 `bsJoin` 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--bsJoin :: B.ByteString -> L.ByteString -> L.ByteString-bsJoin 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 . unsafePerformIO $ 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+-----------------------------------------------------------------------------
+-- |
+-- 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.
+--
+-----------------------------------------------------------------------------
+
+module Codec.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 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 Prelude                 hiding (fail)
+
+import Foreign.Storable        (Storable, peek, sizeOf)
+import Foreign.Ptr             (plusPtr, castPtr)
+import Foreign.ForeignPtr      (withForeignPtr)
+import Control.Monad.ST        (runST)
+import Control.Monad.ST.Unsafe (unsafeInterleaveST)
+import Control.Monad.Fail
+
+import Control.Monad           hiding (fail)
+import Control.Applicative
+import Data.STRef
+import Data.Word
+import Data.Int
+import Data.Bits
+import Data.Maybe
+
+import System.IO.Unsafe        (unsafePerformIO)
+
+-- | 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'
+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 MonadFail Parser where
+  fail err = Parser $ \(S _ _ bytes) ->
+    Left (err ++ ". Failed reading at byte position " ++ show bytes)
+
+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 `bsJoin` 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 `bsJoin` 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 `bsJoin` 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 `bsJoin` 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 `bsJoin` 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
+
+bsJoin :: B.ByteString -> L.ByteString -> L.ByteString
+bsJoin 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 . unsafePerformIO $ 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

@@ -1,52 +1,52 @@--------------------------------------------------------------------------------- |--- Module      : Data.Arbitrary--- Copyright   : George Giorgidze--- License     : BSD3------ Maintainer  : George Giorgidze <http://cs.nott.ac.uk/~ggg/>--- Stability   : Experimental--- Portability : Portable------ Additional instances of the 'Arbitrary' type class defined in 'Test.QuickCheck'.--- Some portions of code were copied from the test suite of 'binary' package.-----------------------------------------------------------------------------------{-# LANGUAGE FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Codec.Internal.Arbitrary (-    arrayGen-  , stringNulGen-  ) where--import qualified Data.ByteString      as B-import qualified Data.ByteString.Lazy as L--import Test.QuickCheck-import Data.Array.IArray-import Data.List-import Data.Word-import Data.Char--instance Arbitrary L.ByteString where-  arbitrary = arbitrary >>= return . L.fromChunks . filter (not. B.null)--instance Arbitrary B.ByteString where-  arbitrary = B.pack `fmap` arbitrary-  -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+-----------------------------------------------------------------------------
+-- |
+-- Module      : Data.Arbitrary
+-- Copyright   : George Giorgidze
+-- License     : BSD3
+--
+-- Maintainer  : George Giorgidze <http://cs.nott.ac.uk/~ggg/>
+-- Stability   : Experimental
+-- Portability : Portable
+--
+-- Additional instances of the 'Arbitrary' type class defined in 'Test.QuickCheck'.
+-- Some portions of code were copied from the test suite of 'binary' package.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Codec.Internal.Arbitrary (
+    arrayGen
+  , stringNulGen
+  ) where
+
+import qualified Data.ByteString      as B
+import qualified Data.ByteString.Lazy as L
+
+import Test.QuickCheck
+import Data.Array.IArray
+import Data.List
+import Data.Word
+import Data.Char
+
+instance Arbitrary L.ByteString where
+  arbitrary = arbitrary >>= return . L.fromChunks . filter (not. B.null)
+
+instance Arbitrary B.ByteString where
+  arbitrary = B.pack `fmap` arbitrary
+  
+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

@@ -1,117 +1,117 @@-module Main (main) where--import qualified Codec.Wav as Wav-import qualified Codec.SoundFont as SF-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L--import Test.QuickCheck (quickCheck, (==>))--import Data.Audio-import Codec.Midi-import Codec.ByteString.Parser-import Codec.ByteString.Builder--import Data.Int-import Data.Word-import Data.Bits-import Data.Monoid-import Debug.Trace--roundTrip :: (Eq a, Show a) => (a -> Builder) -> Parser a -> a -> Bool-roundTrip b p a = if Right a == ea'-  then True-  else trace (unlines $ [show ea']) $ False-  where ea' = runParser p bs-        bs = toLazyByteString $ b a--testAudio :: IO ()-testAudio = do-  putStrLn "TESTING Inctances of Audible"-  quickCheck (prop_audible :: Word8 -> Bool)-  quickCheck (prop_audible :: Word16 -> Bool)-  quickCheck (prop_audible :: Word32 -> Bool)-  -- quickCheck (prop_audible :: Word64 -> Bool)-  quickCheck (prop_audible :: Int8 -> Bool)-  quickCheck (prop_audible :: Int16 -> Bool)-  quickCheck (prop_audible :: Int32 -> Bool)-  -- quickCheck (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"--  quickCheck $ roundTrip buildMessage (parseMessage Nothing)-  quickCheck $ roundTrip buildMidi parseMidi-  quickCheck $ \trk -> trk == fromAbsTime (toAbsTime trk :: Track Ticks)-  quickCheck $ \trk td -> trk == fromRealTime td (toRealTime td trk)--  quickCheck $ \m -> (not $ null $ tracks m) ==>-                       let (Midi SingleTrack _ trks) = toSingleTrack m-                       in  length (concat $ tracks m) - length (concat trks) == length (tracks m) - 1--testWav :: IO ()-testWav =  do-  putStrLn "TESTING PARSING AND BUILDING of Wav"-  quickCheck $ roundTrip (Wav.buildWav :: Audio Word8 -> Builder) Wav.parseWav-  quickCheck $ roundTrip (Wav.buildWav :: Audio Int16 -> Builder) Wav.parseWav-  quickCheck $ roundTrip (Wav.buildWav :: Audio Int32 -> Builder) Wav.parseWav--testSoundFont :: IO ()-testSoundFont =  do-  putStrLn "TESTING PARSING AND BUILDING of SoundFont"-  quickCheck $ roundTrip SF.buildSoundFont SF.parseSoundFont--testParserBuilder :: IO ()-testParserBuilder = do-  putStrLn "TESTING PARSING AND BUILDING OF NUMERICAL TYPES"--  quickCheck $ roundTrip putWord8 getWord8-  quickCheck $ roundTrip putWord16be getWord16be-  quickCheck $ roundTrip putWord16le getWord16le-  quickCheck $ \w -> roundTrip putWord24be getWord24be (w .&. 0xFFFFFF)-  quickCheck $ \w -> roundTrip putWord24le getWord24le (w .&. 0xFFFFFF)-  quickCheck $ roundTrip putWord32be getWord32be-  quickCheck $ roundTrip putWord32le getWord32le-  quickCheck $ roundTrip putWord64be getWord64be-  quickCheck $ roundTrip putWord64le getWord64le--  quickCheck $ roundTrip putInt8 getInt8-  quickCheck $ roundTrip putInt16be getInt16be-  quickCheck $ roundTrip putInt16le getInt16le-  quickCheck $ roundTrip putInt32be getInt32be-  quickCheck $ roundTrip putInt32le getInt32le-  quickCheck $ roundTrip putInt64be getInt64be-  quickCheck $ roundTrip putInt64le getInt64le--  quickCheck $ roundTrip putWordHost getWordHost-  quickCheck $ roundTrip putWord16host getWord16host-  quickCheck $ roundTrip putWord32host getWord32host-  quickCheck $ roundTrip putWord64host getWord64host--  quickCheck $ roundTrip putVarLenBe getVarLenBe-  quickCheck $ roundTrip putVarLenLe getVarLenLe--  putStrLn "TESTING PARSING AND BUILDING OF String and ByteString"--  quickCheck $ \s1 s2 -> roundTrip (\s -> putString s `mappend` putString s2) (getString $ length s1) s1-  quickCheck $ \s1 s2 -> roundTrip (\s -> fromByteString s `mappend` fromByteString s2) (getByteString $ B.length s1) s1-  quickCheck $ \s1 s2 -> roundTrip (\s -> fromLazyByteString s `mappend` fromLazyByteString s2) (getLazyByteString $  L.length s1) s1-  quickCheck $ \bs -> roundTrip fromLazyByteString getRemainingLazyByteString bs---main :: IO ()-main = do-  testAudio-  testParserBuilder-  testMidi-  testWav-  testSoundFont+module Main (main) where
+
+import qualified Codec.Wav as Wav
+import qualified Codec.SoundFont as SF
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+
+import Test.QuickCheck (quickCheck, (==>))
+
+import Data.Audio
+import Codec.Midi
+import Codec.ByteString.Parser
+import Codec.ByteString.Builder
+
+import Data.Int
+import Data.Word
+import Data.Bits
+import Data.Monoid
+import Debug.Trace
+
+roundTrip :: (Eq a, Show a) => (a -> Builder) -> Parser a -> a -> Bool
+roundTrip b p a = if Right a == ea'
+  then True
+  else trace (unlines $ [show ea']) $ False
+  where ea' = runParser p bs
+        bs = toLazyByteString $ b a
+
+testAudio :: IO ()
+testAudio = do
+  putStrLn "TESTING Inctances of Audible"
+  quickCheck (prop_audible :: Word8 -> Bool)
+  quickCheck (prop_audible :: Word16 -> Bool)
+  quickCheck (prop_audible :: Word32 -> Bool)
+  -- quickCheck (prop_audible :: Word64 -> Bool)
+  quickCheck (prop_audible :: Int8 -> Bool)
+  quickCheck (prop_audible :: Int16 -> Bool)
+  quickCheck (prop_audible :: Int32 -> Bool)
+  -- quickCheck (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"
+
+  quickCheck $ roundTrip buildMessage (parseMessage Nothing)
+  quickCheck $ roundTrip buildMidi parseMidi
+  quickCheck $ \trk -> trk == fromAbsTime (toAbsTime trk :: Track Ticks)
+  quickCheck $ \trk td -> trk == fromRealTime td (toRealTime td trk)
+
+  quickCheck $ \m -> (not $ null $ tracks m) ==>
+                       let (Midi SingleTrack _ trks) = toSingleTrack m
+                       in  length (concat $ tracks m) - length (concat trks) == length (tracks m) - 1
+
+testWav :: IO ()
+testWav =  do
+  putStrLn "TESTING PARSING AND BUILDING of Wav"
+  quickCheck $ roundTrip (Wav.buildWav :: Audio Word8 -> Builder) Wav.parseWav
+  quickCheck $ roundTrip (Wav.buildWav :: Audio Int16 -> Builder) Wav.parseWav
+  quickCheck $ roundTrip (Wav.buildWav :: Audio Int32 -> Builder) Wav.parseWav
+
+testSoundFont :: IO ()
+testSoundFont =  do
+  putStrLn "TESTING PARSING AND BUILDING of SoundFont"
+  quickCheck $ roundTrip SF.buildSoundFont SF.parseSoundFont
+
+testParserBuilder :: IO ()
+testParserBuilder = do
+  putStrLn "TESTING PARSING AND BUILDING OF NUMERICAL TYPES"
+
+  quickCheck $ roundTrip putWord8 getWord8
+  quickCheck $ roundTrip putWord16be getWord16be
+  quickCheck $ roundTrip putWord16le getWord16le
+  quickCheck $ \w -> roundTrip putWord24be getWord24be (w .&. 0xFFFFFF)
+  quickCheck $ \w -> roundTrip putWord24le getWord24le (w .&. 0xFFFFFF)
+  quickCheck $ roundTrip putWord32be getWord32be
+  quickCheck $ roundTrip putWord32le getWord32le
+  quickCheck $ roundTrip putWord64be getWord64be
+  quickCheck $ roundTrip putWord64le getWord64le
+
+  quickCheck $ roundTrip putInt8 getInt8
+  quickCheck $ roundTrip putInt16be getInt16be
+  quickCheck $ roundTrip putInt16le getInt16le
+  quickCheck $ roundTrip putInt32be getInt32be
+  quickCheck $ roundTrip putInt32le getInt32le
+  quickCheck $ roundTrip putInt64be getInt64be
+  quickCheck $ roundTrip putInt64le getInt64le
+
+  quickCheck $ roundTrip putWordHost getWordHost
+  quickCheck $ roundTrip putWord16host getWord16host
+  quickCheck $ roundTrip putWord32host getWord32host
+  quickCheck $ roundTrip putWord64host getWord64host
+
+  quickCheck $ roundTrip putVarLenBe getVarLenBe
+  quickCheck $ roundTrip putVarLenLe getVarLenLe
+
+  putStrLn "TESTING PARSING AND BUILDING OF String and ByteString"
+
+  quickCheck $ \s1 s2 -> roundTrip (\s -> putString s `mappend` putString s2) (getString $ length s1) s1
+  quickCheck $ \s1 s2 -> roundTrip (\s -> fromByteString s `mappend` fromByteString s2) (getByteString $ B.length s1) s1
+  quickCheck $ \s1 s2 -> roundTrip (\s -> fromLazyByteString s `mappend` fromLazyByteString s2) (getLazyByteString $  L.length s1) s1
+  quickCheck $ \bs -> roundTrip fromLazyByteString getRemainingLazyByteString bs
+
+
+main :: IO ()
+main = do
+  testAudio
+  testParserBuilder
+  testMidi
+  testWav
+  testSoundFont

@@ -1,717 +1,717 @@--------------------------------------------------------------------------------- |--- 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 qualified Data.ByteString.Lazy as L--import Test.QuickCheck (Arbitrary, arbitrary, choose, oneof)--import Codec.ByteString.Parser-import Codec.ByteString.Builder-import Codec.Internal.Arbitrary ()--import Data.Word-import Data.Bits-import Data.Maybe-import Data.List-import Data.Monoid (mempty, mconcat, mappend)-import Control.Applicative-import Control.Monad--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--two :: Applicative f => f a -> f (a,a)-two a = pure ((,)) <*> a <*> a+-----------------------------------------------------------------------------
+-- |
+-- 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 qualified Data.ByteString.Lazy as L
+
+import Test.QuickCheck (Arbitrary, arbitrary, choose, oneof)
+
+import Codec.ByteString.Parser
+import Codec.ByteString.Builder
+import Codec.Internal.Arbitrary ()
+
+import Data.Word
+import Data.Bits
+import Data.Maybe
+import Data.List
+import Data.Monoid (mempty, mconcat, mappend)
+import Control.Applicative
+import Control.Monad
+
+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
+
+two :: Applicative f => f a -> f (a,a)
+two a = pure ((,)) <*> a <*> a

@@ -1,920 +1,920 @@--------------------------------------------------------------------------------- |--- 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 Codec.ByteString.Parser-import Codec.ByteString.Builder-import Codec.Internal.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 (mconcat)-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 <- choose (minBound :: Word16, maxBound)-         w2 <- 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 <- choose (minBound :: Word16, maxBound)-         w2 <- 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-    ]+-----------------------------------------------------------------------------
+-- |
+-- 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 Codec.ByteString.Parser
+import Codec.ByteString.Builder
+import Codec.Internal.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 (mconcat)
+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 <- choose (minBound :: Word16, maxBound)
+         w2 <- 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 <- choose (minBound :: Word16, maxBound)
+         w2 <- 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
+    ]

@@ -1,175 +1,175 @@--------------------------------------------------------------------------------- |--- 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 Codec.ByteString.Parser-import Codec.ByteString.Builder--import Data.Word-import Data.Int-import qualified Data.ByteString.Lazy as L-import Data.Monoid (mconcat)-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 ()+-----------------------------------------------------------------------------
+-- |
+-- 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 Codec.ByteString.Parser
+import Codec.ByteString.Builder
+
+import Data.Word
+import Data.Int
+import qualified Data.ByteString.Lazy as L
+import Data.Monoid (mconcat)
+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 ()

@@ -1,145 +1,145 @@--------------------------------------------------------------------------------- |--- 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.Array.IO     (MArray, IOUArray, newArray_, writeArray)-import Data.Array.Unsafe (unsafeFreeze, unsafeThaw)--import Codec.Internal.Arbitrary-import Codec.ByteString.Parser-import Codec.ByteString.Builder--import Test.QuickCheck-import System.IO.Unsafe-import Data.Array.Unboxed-import Data.Word-import Data.Int-import Data.Monoid (mconcat)--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, 8)-    sn <- choose (1, 128) >>= 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]+-----------------------------------------------------------------------------
+-- |
+-- 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.Array.IO     (MArray, IOUArray, newArray_, writeArray)
+import Data.Array.Unsafe (unsafeFreeze, unsafeThaw)
+
+import Codec.Internal.Arbitrary
+import Codec.ByteString.Parser
+import Codec.ByteString.Builder
+
+import Test.QuickCheck
+import System.IO.Unsafe
+import Data.Array.Unboxed
+import Data.Word
+import Data.Int
+import Data.Monoid (mconcat)
+
+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, 8)
+    sn <- choose (1, 128) >>= 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]