-----------------------------------------------------------------------------

-- |

-- 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 :: Parser Word8
parseSample = Parser Word8
getWord8
  buildSample :: Word8 -> Builder
buildSample = Word8 -> Builder
putWord8
  bitsPerSample :: Word8 -> Int
bitsPerSample Word8
_ = Int
8

instance AudibleInWav Int16 where
  parseSample :: Parser Int16
parseSample = Parser Int16
getInt16le
  buildSample :: Int16 -> Builder
buildSample = Int16 -> Builder
putInt16le
  bitsPerSample :: Int16 -> Int
bitsPerSample Int16
_ = Int
16

instance AudibleInWav Int32 where
  parseSample :: Parser Int32
parseSample = Parser Int32
getInt32le
  buildSample :: Int32 -> Builder
buildSample = Int32 -> Builder
putInt32le
  bitsPerSample :: Int32 -> Int
bitsPerSample Int32
_ = Int
32

instance AudibleInWav Int64 where
  parseSample :: Parser Int64
parseSample = Parser Int64
getInt64le
  buildSample :: Int64 -> Builder
buildSample = Int64 -> Builder
putInt64le
  bitsPerSample :: Int64 -> Int
bitsPerSample Int64
_ = Int
64

parserSelector :: (Audible a, AudibleInWav a) => Int -> Parser a
parserSelector :: forall a. (Audible a, AudibleInWav a) => Int -> Parser a
parserSelector Int
8  = (Parser Word8
forall a. AudibleInWav a => Parser a
parseSample :: Parser Word8) Parser Word8 -> (Word8 -> Parser a) -> Parser a
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Parser a
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Parser a) -> (Word8 -> a) -> Word8 -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sample -> a
forall a. Audible a => Sample -> a
fromSample (Sample -> a) -> (Word8 -> Sample) -> Word8 -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Sample
forall a. Audible a => a -> Sample
toSample
parserSelector Int
16 = (Parser Int16
forall a. AudibleInWav a => Parser a
parseSample :: Parser Int16) Parser Int16 -> (Int16 -> Parser a) -> Parser a
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Parser a
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Parser a) -> (Int16 -> a) -> Int16 -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sample -> a
forall a. Audible a => Sample -> a
fromSample (Sample -> a) -> (Int16 -> Sample) -> Int16 -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Sample
forall a. Audible a => a -> Sample
toSample
parserSelector Int
24 = ((Parser Word32
getWord24le Parser Word32 -> (Word32 -> Parser Int32) -> Parser Int32
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int32 -> Parser Int32
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32 -> Parser Int32)
-> (Word32 -> Int32) -> Word32 -> Parser Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int32) -> (Word32 -> Word32) -> Word32 -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word32 -> Int -> Word32) -> Int -> Word32 -> Word32
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL) Int
8) :: Parser Int32) Parser Int32 -> (Int32 -> Parser a) -> Parser a
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Parser a
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Parser a) -> (Int32 -> a) -> Int32 -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sample -> a
forall a. Audible a => Sample -> a
fromSample (Sample -> a) -> (Int32 -> Sample) -> Int32 -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Sample
forall a. Audible a => a -> Sample
toSample
parserSelector Int
32 = (Parser Int32
forall a. AudibleInWav a => Parser a
parseSample :: Parser Int32) Parser Int32 -> (Int32 -> Parser a) -> Parser a
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Parser a
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Parser a) -> (Int32 -> a) -> Int32 -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sample -> a
forall a. Audible a => Sample -> a
fromSample (Sample -> a) -> (Int32 -> Sample) -> Int32 -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Sample
forall a. Audible a => a -> Sample
toSample
parserSelector Int
64 = (Parser Int64
forall a. AudibleInWav a => Parser a
parseSample :: Parser Int64) Parser Int64 -> (Int64 -> Parser a) -> Parser a
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Parser a
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Parser a) -> (Int64 -> a) -> Int64 -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sample -> a
forall a. Audible a => Sample -> a
fromSample (Sample -> a) -> (Int64 -> Sample) -> Int64 -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Sample
forall a. Audible a => a -> Sample
toSample
parserSelector Int
n  = String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" bitsPerSample is not supported"

bytesPerSample :: (AudibleInWav a) => a -> Int
bytesPerSample :: forall a. AudibleInWav a => a -> Int
bytesPerSample a
a = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (a -> Int
forall a. AudibleInWav a => a -> Int
bitsPerSample a
a) Int
8 

importFile :: (MArray IOUArray a IO, IArray UArray a, Audible a, AudibleInWav a) => FilePath -> IO (Either String (Audio a))
importFile :: forall a.
(MArray IOUArray a IO, IArray UArray a, Audible a,
 AudibleInWav a) =>
String -> IO (Either String (Audio a))
importFile String
n = do
  bs <- String -> IO ByteString
L.readFile String
n
  return $! runParser parseWav bs

exportFile :: (IArray UArray a, Audible a, AudibleInWav a) => FilePath -> Audio a ->  IO ()
exportFile :: forall a.
(IArray UArray a, Audible a, AudibleInWav a) =>
String -> Audio a -> IO ()
exportFile String
f Audio a
w = String -> ByteString -> IO ()
L.writeFile String
f (Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Audio a -> Builder
forall a.
(IArray UArray a, Audible a, AudibleInWav a) =>
Audio a -> Builder
buildWav Audio a
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 :: forall a.
(MArray IOUArray a IO, IArray UArray a, Audible a,
 AudibleInWav a) =>
Parser (Audio a)
parseWav = do
  _ <- String -> Parser String
string 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 :: forall a.
(IArray UArray a, Audible a, AudibleInWav a) =>
Audio a -> Builder
buildWav Audio a
a = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
    String -> Builder
putString String
"RIFF"
  , Word32 -> Builder
putWord32le (Word32 -> Builder) -> Word32 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
chunkSize
  , String -> Builder
putString String
"WAVE"
  , Audio a -> Builder
forall a.
(IArray UArray a, Audible a, AudibleInWav a) =>
Audio a -> Builder
buildFmt Audio a
a
  , Audio a -> Builder
forall a.
(IArray UArray a, Audible a, AudibleInWav a) =>
Audio a -> Builder
buildData Audio a
a]
  where
  sd :: SampleData a
sd = Audio a -> SampleData a
forall a. Audio a -> SampleData a
sampleData Audio a
a
  chunkSize :: Int
chunkSize =
      Int
4  -- "WAVE" 

    Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
24 -- fmt chunk

    Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8  -- data chunk header  

    Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ SampleData a -> Int
forall a. IArray UArray a => SampleData a -> Int
sampleNumber SampleData a
sd) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (a -> Int
forall a. AudibleInWav a => a -> Int
bytesPerSample (a -> Int) -> a -> Int
forall a b. (a -> b) -> a -> b
$ SampleData a -> a
forall a. IArray UArray a => SampleData a -> a
sampleType SampleData a
sd)
       -- sample data


parseFmt :: Parser (Int,Int,Int)
parseFmt :: Parser (Int, Int, Int)
parseFmt = do
  _ <- String -> Parser String
string 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 (\Word16
w -> (Word16 -> Word16 -> Word16
forall a. Integral a => a -> a -> a
mod Word16
w Word16
8 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0) Bool -> Bool -> Bool
&& Word16
w Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16
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 :: forall a.
(IArray UArray a, Audible a, AudibleInWav a) =>
Audio a -> Builder
buildFmt Audio a
a = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
    String -> Builder
putString   (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ String
"fmt "
  , Word32 -> Builder
putWord32le (Word32 -> Builder) -> Word32 -> Builder
forall a b. (a -> b) -> a -> b
$ Word32
16 -- chunk size

  , Word16 -> Builder
putWord16le (Word16 -> Builder) -> Word16 -> Builder
forall a b. (a -> b) -> a -> b
$ Word16
1  -- compression code

  , Word16 -> Builder
putWord16le (Word16 -> Builder) -> Word16 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Audio a -> Int
forall a. Audio a -> Int
channelNumber Audio a
a
  , Word32 -> Builder
putWord32le (Word32 -> Builder) -> Word32 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Audio a -> Int
forall a. Audio a -> Int
sampleRate Audio a
a
  , Word32 -> Builder
putWord32le (Word32 -> Builder) -> Word32 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int
avgBytesPerSec
  , Word16 -> Builder
putWord16le (Word16 -> Builder) -> Word16 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Int
bytesPerSampleSlice
  , Word16 -> Builder
putWord16le (Word16 -> Builder) -> Word16 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Int
bitsPS
  ]
  where
  sd :: SampleData a
sd = Audio a -> SampleData a
forall a. Audio a -> SampleData a
sampleData Audio a
a
  bitsPS :: Int
bitsPS = a -> Int
forall a. AudibleInWav a => a -> Int
bitsPerSample (a -> Int) -> a -> Int
forall a b. (a -> b) -> a -> b
$ SampleData a -> a
forall a. IArray UArray a => SampleData a -> a
sampleType SampleData a
sd
  bytesPS :: Int
bytesPS = a -> Int
forall a. AudibleInWav a => a -> Int
bytesPerSample (a -> Int) -> a -> Int
forall a b. (a -> b) -> a -> b
$ SampleData a -> a
forall a. IArray UArray a => SampleData a -> a
sampleType SampleData a
sd
  bytesPerSampleSlice :: Int
bytesPerSampleSlice = Int
bytesPS Int -> Int -> Int
forall a. Num a => a -> a -> a
* Audio a -> Int
forall a. Audio a -> Int
channelNumber Audio a
a
  avgBytesPerSec :: Int
avgBytesPerSec = Audio a -> Int
forall a. Audio a -> Int
sampleRate Audio a
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bytesPerSampleSlice
  
parseData :: (MArray IOUArray a IO, IArray UArray a, Audible a, AudibleInWav a)
  => Int -> Int -> Parser (SampleData a)
parseData :: forall a.
(MArray IOUArray a IO, IArray UArray a, Audible a,
 AudibleInWav a) =>
Int -> Int -> Parser (SampleData a)
parseData Int
cn Int
bitsPS = do
  _ <- String -> Parser String
string String
"data"
  let bytesPS = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
bitsPS Int
8
  chunkSize <- expect (\Word32
w -> Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w) Int
bytesPS Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) getWord32le
               >>= return . fromIntegral
  let sn = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
chunkSize Int
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 :: forall a.
(IArray UArray a, Audible a, AudibleInWav a) =>
Audio a -> Builder
buildData Audio a
a = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
    String -> Builder
putString String
"data"
  , Word32 -> Builder
putWord32le (Word32 -> Builder) -> Word32 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int
chunkSize
  , (a -> Builder) -> SampleData a -> Builder
forall a.
IArray UArray a =>
(a -> Builder) -> SampleData a -> Builder
buildSampleData a -> Builder
forall a. AudibleInWav a => a -> Builder
buildSample SampleData a
sd]
  where
  sd :: SampleData a
sd = Audio a -> SampleData a
forall a. Audio a -> SampleData a
sampleData Audio a
a
  chunkSize :: Int
chunkSize = (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ SampleData a -> Int
forall a. IArray UArray a => SampleData a -> Int
sampleNumber SampleData a
sd) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (a -> Int
forall a. AudibleInWav a => a -> Int
bytesPerSample (a -> Int) -> a -> Int
forall a b. (a -> b) -> a -> b
$ SampleData a -> a
forall a. IArray UArray a => SampleData a -> a
sampleType SampleData a
sd)

parseUnknownChunk :: Parser ()
parseUnknownChunk :: Parser ()
parseUnknownChunk = do
  _ <- (String -> Bool) -> Parser String -> Parser String
forall a. (Show a, Eq a) => (a -> Bool) -> Parser a -> Parser a
expect (\String
s -> String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"data" Bool -> Bool -> Bool
&& String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"fmt ") (Int -> Parser String
getString Int
4)
  chunkSize <- getWord32le
  skip(fromIntegral chunkSize)
  return ()