diff --git a/HCodecs.cabal b/HCodecs.cabal
--- a/HCodecs.cabal
+++ b/HCodecs.cabal
@@ -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
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -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.
diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,2 @@
-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple
+main = defaultMain
diff --git a/src/Codec/ByteString/Builder.hs b/src/Codec/ByteString/Builder.hs
--- a/src/Codec/ByteString/Builder.hs
+++ b/src/Codec/ByteString/Builder.hs
@@ -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
diff --git a/src/Codec/ByteString/Parser.hs b/src/Codec/ByteString/Parser.hs
--- a/src/Codec/ByteString/Parser.hs
+++ b/src/Codec/ByteString/Parser.hs
@@ -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
diff --git a/src/Codec/Internal/Arbitrary.hs b/src/Codec/Internal/Arbitrary.hs
--- a/src/Codec/Internal/Arbitrary.hs
+++ b/src/Codec/Internal/Arbitrary.hs
@@ -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
diff --git a/src/Codec/Internal/TestSuite.hs b/src/Codec/Internal/TestSuite.hs
--- a/src/Codec/Internal/TestSuite.hs
+++ b/src/Codec/Internal/TestSuite.hs
@@ -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
diff --git a/src/Codec/Midi.hs b/src/Codec/Midi.hs
--- a/src/Codec/Midi.hs
+++ b/src/Codec/Midi.hs
@@ -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
diff --git a/src/Codec/SoundFont.hs b/src/Codec/SoundFont.hs
--- a/src/Codec/SoundFont.hs
+++ b/src/Codec/SoundFont.hs
@@ -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
+    ]
diff --git a/src/Codec/Wav.hs b/src/Codec/Wav.hs
--- a/src/Codec/Wav.hs
+++ b/src/Codec/Wav.hs
@@ -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 ()
diff --git a/src/Data/Audio.hs b/src/Data/Audio.hs
--- a/src/Data/Audio.hs
+++ b/src/Data/Audio.hs
@@ -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]