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