module Sound.Audacity.XML.Parser where import qualified Text.HTML.Tagchup.Tag as Tag import qualified Text.XML.Basic.Attribute as Attr import qualified Text.XML.Basic.Name.MixedCase as Name import Text.Printf (printf) import qualified Control.Monad.Trans.State as MS import qualified Control.Monad.Trans.Maybe as MM import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Exception.Synchronous as ME import Control.Monad (MonadPlus, void, when, guard, mzero) import Control.Applicative (many) import qualified Data.List.HT as ListHT import Data.String.HT (trim) import Data.Char (isSpace) type T = MS.StateT [Tag.T Name.T String] (MM.MaybeT (ME.Exceptional Message)) type Message = String tag :: T (Tag.T Name.T String) tag :: T (T T String) tag = ([T T String] -> MaybeT (Exceptional String) (T T String, [T T String])) -> T (T T String) forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a MS.StateT (([T T String] -> MaybeT (Exceptional String) (T T String, [T T String])) -> T (T T String)) -> ([T T String] -> MaybeT (Exceptional String) (T T String, [T T String])) -> T (T T String) forall a b. (a -> b) -> a -> b $ Exceptional String (Maybe (T T String, [T T String])) -> MaybeT (Exceptional String) (T T String, [T T String]) forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a MM.MaybeT (Exceptional String (Maybe (T T String, [T T String])) -> MaybeT (Exceptional String) (T T String, [T T String])) -> ([T T String] -> Exceptional String (Maybe (T T String, [T T String]))) -> [T T String] -> MaybeT (Exceptional String) (T T String, [T T String]) forall b c a. (b -> c) -> (a -> b) -> a -> c . Maybe (T T String, [T T String]) -> Exceptional String (Maybe (T T String, [T T String])) forall (m :: * -> *) a. Monad m => a -> m a return (Maybe (T T String, [T T String]) -> Exceptional String (Maybe (T T String, [T T String]))) -> ([T T String] -> Maybe (T T String, [T T String])) -> [T T String] -> Exceptional String (Maybe (T T String, [T T String])) forall b c a. (b -> c) -> (a -> b) -> a -> c . [T T String] -> Maybe (T T String, [T T String]) forall a. [a] -> Maybe (a, [a]) ListHT.viewL fromMaybeGen :: (MonadPlus m) => Maybe a -> m a fromMaybeGen :: Maybe a -> m a fromMaybeGen = m a -> (a -> m a) -> Maybe a -> m a forall b a. b -> (a -> b) -> Maybe a -> b maybe m a forall (m :: * -> *) a. MonadPlus m => m a mzero a -> m a forall (m :: * -> *) a. Monad m => a -> m a return fromMaybe :: Maybe a -> T a fromMaybe :: Maybe a -> T a fromMaybe = MaybeT (Exceptional String) a -> T a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a MT.lift (MaybeT (Exceptional String) a -> T a) -> (Maybe a -> MaybeT (Exceptional String) a) -> Maybe a -> T a forall b c a. (b -> c) -> (a -> b) -> a -> c . Exceptional String (Maybe a) -> MaybeT (Exceptional String) a forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a MM.MaybeT (Exceptional String (Maybe a) -> MaybeT (Exceptional String) a) -> (Maybe a -> Exceptional String (Maybe a)) -> Maybe a -> MaybeT (Exceptional String) a forall b c a. (b -> c) -> (a -> b) -> a -> c . Maybe a -> Exceptional String (Maybe a) forall (m :: * -> *) a. Monad m => a -> m a return tagOpen :: Tag.Name Name.T -> T [Attr.T Name.T String] tagOpen :: Name T -> T [T T String] tagOpen Name T name = do T T String x <- T (T T String) tag (Name T foundName, [T T String] attrs) <- Maybe (Name T, [T T String]) -> T (Name T, [T T String]) forall a. Maybe a -> T a fromMaybe (Maybe (Name T, [T T String]) -> T (Name T, [T T String])) -> Maybe (Name T, [T T String]) -> T (Name T, [T T String]) forall a b. (a -> b) -> a -> b $ T T String -> Maybe (Name T, [T T String]) forall name string. T name string -> Maybe (Name name, [T name string]) Tag.maybeOpen T T String x Bool -> StateT [T T String] (MaybeT (Exceptional String)) () forall (f :: * -> *). Alternative f => Bool -> f () guard (Bool -> StateT [T T String] (MaybeT (Exceptional String)) ()) -> Bool -> StateT [T T String] (MaybeT (Exceptional String)) () forall a b. (a -> b) -> a -> b $ Name T foundName Name T -> Name T -> Bool forall a. Eq a => a -> a -> Bool == Name T name [T T String] -> T [T T String] forall (m :: * -> *) a. Monad m => a -> m a return [T T String] attrs tagClose :: Tag.Name Name.T -> T () tagClose :: Name T -> StateT [T T String] (MaybeT (Exceptional String)) () tagClose Name T name = do T T String x <- T (T T String) tag Name T foundName <- Maybe (Name T) -> T (Name T) forall a. Maybe a -> T a fromMaybe (Maybe (Name T) -> T (Name T)) -> Maybe (Name T) -> T (Name T) forall a b. (a -> b) -> a -> b $ T T String -> Maybe (Name T) forall name string. T name string -> Maybe (Name name) Tag.maybeClose T T String x Bool -> StateT [T T String] (MaybeT (Exceptional String)) () forall (f :: * -> *). Alternative f => Bool -> f () guard (Bool -> StateT [T T String] (MaybeT (Exceptional String)) ()) -> Bool -> StateT [T T String] (MaybeT (Exceptional String)) () forall a b. (a -> b) -> a -> b $ Name T foundName Name T -> Name T -> Bool forall a. Eq a => a -> a -> Bool == Name T name lookupAttr :: String -> [Attr.T Name.T String] -> T String lookupAttr :: String -> [T T String] -> T String lookupAttr String name [T T String] attrs = MaybeT (Exceptional String) String -> T String forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a MT.lift (MaybeT (Exceptional String) String -> T String) -> MaybeT (Exceptional String) String -> T String forall a b. (a -> b) -> a -> b $ Exceptional String String -> MaybeT (Exceptional String) String forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a MT.lift (Exceptional String String -> MaybeT (Exceptional String) String) -> Exceptional String String -> MaybeT (Exceptional String) String forall a b. (a -> b) -> a -> b $ String -> Maybe String -> Exceptional String String forall e a. e -> Maybe a -> Exceptional e a ME.fromMaybe (String -> String -> String -> String forall r. PrintfType r => String -> r printf String "did not find attribute %s in%s" String name ([T T String] -> String -> String forall name string. (Attribute name, C string) => [T name string] -> String -> String Attr.formatListBlankHead [T T String] attrs String "")) (Maybe String -> Exceptional String String) -> Maybe String -> Exceptional String String forall a b. (a -> b) -> a -> b $ String -> [T T String] -> Maybe String forall name string. Attribute name => String -> [T name string] -> Maybe string Attr.lookupLit String name [T T String] attrs lookupAttrRead :: (Read a) => String -> [Attr.T Name.T String] -> T a lookupAttrRead :: String -> [T T String] -> T a lookupAttrRead String name [T T String] attrs = do String str <- String -> [T T String] -> T String lookupAttr String name [T T String] attrs case ReadS a forall a. Read a => ReadS a reads String str of [(a x, String "")] -> a -> T a forall (m :: * -> *) a. Monad m => a -> m a return a x [(a, String)] _ -> MaybeT (Exceptional String) a -> T a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a MT.lift (MaybeT (Exceptional String) a -> T a) -> MaybeT (Exceptional String) a -> T a forall a b. (a -> b) -> a -> b $ Exceptional String a -> MaybeT (Exceptional String) a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a MT.lift (Exceptional String a -> MaybeT (Exceptional String) a) -> Exceptional String a -> MaybeT (Exceptional String) a forall a b. (a -> b) -> a -> b $ String -> Exceptional String a forall e a. e -> Exceptional e a ME.throw (String -> Exceptional String a) -> String -> Exceptional String a forall a b. (a -> b) -> a -> b $ String "could not parse attribute value " String -> String -> String forall a. [a] -> [a] -> [a] ++ String str lookupAttrBool :: String -> [Attr.T Name.T String] -> T Bool lookupAttrBool :: String -> [T T String] -> T Bool lookupAttrBool String name [T T String] attrs = do String str <- String -> [T T String] -> T String lookupAttr String name [T T String] attrs case String str of String "0" -> Bool -> T Bool forall (m :: * -> *) a. Monad m => a -> m a return Bool False String "1" -> Bool -> T Bool forall (m :: * -> *) a. Monad m => a -> m a return Bool True String _ -> MaybeT (Exceptional String) Bool -> T Bool forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a MT.lift (MaybeT (Exceptional String) Bool -> T Bool) -> MaybeT (Exceptional String) Bool -> T Bool forall a b. (a -> b) -> a -> b $ Exceptional String Bool -> MaybeT (Exceptional String) Bool forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a MT.lift (Exceptional String Bool -> MaybeT (Exceptional String) Bool) -> Exceptional String Bool -> MaybeT (Exceptional String) Bool forall a b. (a -> b) -> a -> b $ String -> Exceptional String Bool forall e a. e -> Exceptional e a ME.throw (String -> Exceptional String Bool) -> String -> Exceptional String Bool forall a b. (a -> b) -> a -> b $ String "not a bool value: " String -> String -> String forall a. [a] -> [a] -> [a] ++ String str skipSpace :: T () skipSpace :: StateT [T T String] (MaybeT (Exceptional String)) () skipSpace = do T T String x <- T (T T String) tag String text <- Maybe String -> T String forall a. Maybe a -> T a fromMaybe (Maybe String -> T String) -> Maybe String -> T String forall a b. (a -> b) -> a -> b $ T T String -> Maybe String forall name string. T name string -> Maybe string Tag.maybeText T T String x Bool -> StateT [T T String] (MaybeT (Exceptional String)) () -> StateT [T T String] (MaybeT (Exceptional String)) () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Bool -> Bool not (Bool -> Bool) -> Bool -> Bool forall a b. (a -> b) -> a -> b $ (Char -> Bool) -> String -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all Char -> Bool isSpace String text) (StateT [T T String] (MaybeT (Exceptional String)) () -> StateT [T T String] (MaybeT (Exceptional String)) ()) -> StateT [T T String] (MaybeT (Exceptional String)) () -> StateT [T T String] (MaybeT (Exceptional String)) () forall a b. (a -> b) -> a -> b $ MaybeT (Exceptional String) () -> StateT [T T String] (MaybeT (Exceptional String)) () forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a MT.lift (MaybeT (Exceptional String) () -> StateT [T T String] (MaybeT (Exceptional String)) ()) -> MaybeT (Exceptional String) () -> StateT [T T String] (MaybeT (Exceptional String)) () forall a b. (a -> b) -> a -> b $ Exceptional String () -> MaybeT (Exceptional String) () forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a MT.lift (Exceptional String () -> MaybeT (Exceptional String) ()) -> Exceptional String () -> MaybeT (Exceptional String) () forall a b. (a -> b) -> a -> b $ String -> Exceptional String () forall e a. e -> Exceptional e a ME.throw (String -> Exceptional String ()) -> String -> Exceptional String () forall a b. (a -> b) -> a -> b $ String "expected spaces, but found: " String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show (String -> String trim String text) skipSpaces :: T () skipSpaces :: StateT [T T String] (MaybeT (Exceptional String)) () skipSpaces = StateT [T T String] (MaybeT (Exceptional String)) [()] -> StateT [T T String] (MaybeT (Exceptional String)) () forall (f :: * -> *) a. Functor f => f a -> f () void (StateT [T T String] (MaybeT (Exceptional String)) [()] -> StateT [T T String] (MaybeT (Exceptional String)) ()) -> StateT [T T String] (MaybeT (Exceptional String)) [()] -> StateT [T T String] (MaybeT (Exceptional String)) () forall a b. (a -> b) -> a -> b $ StateT [T T String] (MaybeT (Exceptional String)) () -> StateT [T T String] (MaybeT (Exceptional String)) [()] forall (f :: * -> *) a. Alternative f => f a -> f [a] many StateT [T T String] (MaybeT (Exceptional String)) () skipSpace