XML.hs

-- Copyright (C) 2007-2008 Stefan Kersten
-- 
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

module Sound.SonicVisualiser.XML where

import Control.Arrow
import Control.Exception
import Prelude hiding (catch)
import Control.Monad
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Sound.SonicVisualiser.Types
import Text.XML.Light

type ModelMap = Map Int Model
type DataMap  = Map Int Data

mkName :: String -> QName
mkName s = QName s Nothing Nothing

getAttr :: String -> Element -> IO String
getAttr name e =
    case findAttr (mkName name) e of
        Nothing -> fail $ "getAttr: missing attribute " ++ name
        Just s  -> return s

getAttrDefault :: String -> String -> Element -> IO String
getAttrDefault name def e = return $ fromMaybe def (findAttr (mkName name) e)

readAttr :: Read a => String -> Element -> IO a
readAttr name e =
    case findAttr (mkName name) e of
        Nothing -> fail $ "readAttr: missing attribute " ++ name
        Just s  -> catch (readIO s) (const $ fail $ "readAttr: parse error " ++ name)

readAttrDefault :: Read a => String -> a -> Element -> IO a
readAttrDefault name def e =
    case findAttr (mkName name) e of
        Nothing -> return def
        Just s  -> catch (readIO s) (const $ fail $ "readAttr: parse error " ++ name)

getPoint :: Element -> IO Point
getPoint e = do
    frame <- catch (liftM fromJust (readAttr "frame" e)) (const parseError)
    value <- readAttr "value" e
    return $ Point {
        pointFrame = frame,
        pointValue = value,
        pointLabel = findAttr (mkName "label") e
    }
    where
        readAttr name e = 
            case findAttr (mkName name) e of
                Nothing -> return Nothing
                Just s  -> catch (readIO s >>= return . Just) (const parseError)
        parseError = fail "getPoint: couldn't parse point"
        
getPoints :: Element -> IO [Point]
getPoints e = do
    let ps = filterChildrenName (== mkName "point") e
    mapM getPoint ps

getDatasets :: Element -> IO DataMap
getDatasets e = do
    ds <- mapM pair (filterChildrenName (== mkName "dataset") e)
    return (Map.fromList ds)
    where
        pair e = do
            id <- readId (findAttr (mkName "id") e)
            ps <- getPoints e
            return (id, DataSet ps)
        readId attr = catch (readIO (fromJust attr)) (\_ -> fail "getDatasets: couldn't parse id")

readModelType :: String -> IO ModelType
readModelType "wavefile"   = return WaveFile
readModelType "sparse"     = return SparseMatrix
readModelType s            = fail $ "unknown ModelType " ++ s

getModel :: DataMap -> Element -> IO (Int, Model)
getModel ds e = do
    mid         <- readAttr "id" e
    name        <- getAttr "name" e
    sampleRate  <- readAttr "sampleRate" e
    startFrame  <- readAttr "start" e
    endFrame    <- readAttr "end" e
    theType     <- getAttr "type" e >>= readModelType
    dimensions  <- readAttrDefault "dimensions" (1 :: Int) e
    resolution  <- readAttrDefault "resolution" (1 :: Int) e
    isMain      <- getAttrDefault  "mainModel" "false" e >>= (return . (==) "true")
    theData     <- case theType of
                        WaveFile ->
                            getAttr "file" e >>= return . File
                        SparseMatrix -> do
                            dsid <- readAttr "dataset" e
                            return $ fromMaybe (DataSet []) (Map.lookup dsid ds)
    return (mid, Model {
        modelName       = name,
        modelSampleRate = sampleRate,
        modelStartFrame = startFrame,
        modelEndFrame   = endFrame,
        modelType       = theType,
        modelDimensions = dimensions,
        modelResolution = resolution,
        modelIsMain     = isMain,
        modelData       = theData
    })

getModels :: DataMap -> Element -> IO ModelMap
getModels ds e = do
    assocs <- mapM (getModel ds) (filterChildrenName (== mkName "model") e)
    return $ Map.fromList assocs

getLayer :: ModelMap -> Element -> IO (Maybe Layer)
getLayer ms e = do
    name <- getAttr "name" e -- TODO: decode XML
    mid  <- readAttr "model" e
    return $ maybe Nothing (Just . Layer name) (Map.lookup mid ms)

getLayers :: ModelMap -> Element -> IO [Layer]
getLayers ms e =  do
    ls <- mapM (getLayer ms) (filterChildrenName (== mkName "layer") e)
    return $ [ x | Just x <- ls ]

getDerivation :: ModelMap -> Element -> IO (Maybe Derivation)
getDerivation ms e = do
    sourceId    <- readAttr "source"     e
    modelId     <- readAttr "model"      e
    channel     <- readAttr "channel"    e
    domain      <- readAttr "domain"     e
    stepSize    <- readAttr "stepSize"   e
    blockSize   <- readAttr "blockSize"  e
    windowType  <- readAttr "windowType" e
    transform   <- getAttr  "transform"  e
    return $ do
        source <- Map.lookup sourceId ms
        model  <- Map.lookup modelId  ms
        return $ Derivation {
            derivationSource        = source,
            derivationModel         = model,
            derivationChannel       = channel,
            derivationDomain        = domain,
            derivationStepSize      = stepSize,
            derivationBlockSize     = blockSize,
            derivationWindowType    = windowType,
            derivationTransform     = transform
        }

getDerivations :: ModelMap -> Element -> IO [Derivation]
getDerivations ms e = do
    ds <- mapM (getDerivation ms) (filterChildrenName (== mkName "derivations") e)
    return $ [ x | Just x <- ds ]

readString :: String -> IO Document
readString s = do
    case parseXMLDoc s of
        Nothing -> fail "XML parse error"
        Just xml -> do
            let xmlData = (findChildren (mkName "sv") >>> head >>> findChildren (mkName "data") >>> head) xml
            dmap   <- getDatasets xmlData
            mmap   <- getModels dmap xmlData
            layers <- getLayers mmap xmlData
            derivs <- getDerivations mmap xmlData
            let doc = Document (Map.elems mmap) layers derivs
            return doc

-- EOF