module Sound.WaveSurfer (
Time, DTime,
Label, Attribute,
Record(..), duration,
Result,
encode, decode,
interact
) where
import Data.Binary.Put (Put, runPut, putByteString)
import Data.Maybe (mapMaybe)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import Data.ByteString.Lex.Double (readDouble)
import Text.Delimited (Result)
import qualified Text.Delimited as DT
import Prelude hiding (interact)
import Text.Show.ByteString (putAscii, showp, unlinesP, unwordsP)
import qualified Text.Show.ByteString as ShowP
type Time = Double
type DTime = Time
type Label = BS.ByteString
type Attribute = (Label, Maybe Label)
data Record = Record {
onset :: Time,
offset :: Time,
label :: Label,
attributes :: [Attribute]
} deriving (Eq, Show)
type Content = [Record]
duration :: Record -> DTime
duration e = offset e onset e
whiteSpace :: [Char]
whiteSpace = [' ', '\t']
comment :: Char
comment = '#'
putAttribute :: Attribute -> Put
putAttribute (key, value) = do
putByteString key
case value of
Just v -> putAscii ':' >> putByteString v
Nothing -> return ()
putRecord :: Record -> Put
putRecord r = unwordsP ([t0, t1, putByteString (label r)] ++ attrs)
where
t0 = showp (onset r)
t1 = showp (offset r)
attrs = map putAttribute (attributes r)
putContent :: Content -> Put
putContent = unlinesP . map putRecord
encode :: Content -> ByteString
encode = runPut . putContent
instance Monad (Either a) where
return = Right
x >>= f = case x of
Left a -> Left a
Right r -> f r
decodeAttributes :: DT.Record -> Result [Attribute]
decodeAttributes = return . map f
where f s = let (k, v) = BSC.break (==':') s
v' = BS.tail v
in (k, if BS.null v' then Nothing else Just v')
decodeDouble :: DT.Field -> Result Double
decodeDouble s = case readDouble s of
Just (d, _) -> Right d
Nothing -> Left ("Couldn't parse Double: " ++ show s)
decodeRecord :: DT.Record -> Result Record
decodeRecord (t0:t1:lbl:attrs) = do
t0' <- decodeDouble t0
t1' <- decodeDouble t1
attrs' <- decodeAttributes attrs
return (Record t0' t1' lbl attrs')
decodeRecord r = Left ("Couldn't parse record: " ++ show r)
decode :: ByteString -> Result Content
decode s = do
xs <- DT.decode whiteSpace s
mapM decodeRecord (filter f xs)
where
f [] = False
f (r:rs) = not (BSC.null r) && (BSC.head r /= comment)
interact :: (Record -> Record) -> ByteString -> Result ByteString
interact f s = do
c <- decode s
let c' = map f c
return (encode c')