src/Text/XML/MusicXML/Util.lhs

\begin{code}

-- |  
-- Maintainer : silva.samuel@alumni.uminho.pt
-- Stability  : experimental
-- Portability: HaXML
-- 
module Text.XML.MusicXML.Util where
import Text.XML.HaXml.Types 
-- (Attribute,AttValue(..),
--    Element(..), Content(..))
import Control.Exception(throw, Exception(..))
import Control.Monad (MonadPlus(..))
import Data.Char (isSpace)
import Prelude (String, Maybe(..), Either(..), Bool(..),
    Monad(..), Show(..), Int, Functor(..), Eq(..), 
    (.), (++), (&&),
    id, map, concat, either, maybe, and,
    const, lookup, unwords)

\end{code} \begin{code}

-- * Result
-- | 
data Result a = Ok a | Error String
    deriving (Eq, Show)
-- |
instance Monad Result where
    (Ok a)      >>= b = b a
    (Error msg) >>= _ = Error msg
    return x = Ok x
    fail msg = Error msg
-- |
instance Functor Result where
    fmap f (Ok a)      = Ok (f a)
    fmap _ (Error msg) = Error msg
-- |
instance MonadPlus Result where
    mzero = Error "unknow error"
    (Ok a) `mplus` _ = (Ok a)
    (Error _) `mplus` b = b

-- |
isOK :: Result a -> Bool
isOK (Ok _) = True
isOK _      = False
-- |
isError :: Result a -> Bool
isError (Error _) = True
isError _         = False
-- | 
fromOK :: Result a -> a
fromOK (Ok a)      = a
fromOK (Error msg) = throw (ErrorCall msg)
-- | 
fromError :: Result a -> String
fromError (Ok _)      = []
fromError (Error msg) = msg

-- * ST
-- |
newtype ST s a = ST {state :: s -> (s,a)}
instance Monad (ST s) where 
    return x = ST (\s -> (s,x))
    p >>= f  = ST (\s1 -> let (s2, r) = state p s1 in state (f r) s2)
instance Functor (ST s) where 
    fmap f st = ST (\s -> (\(x,y) -> (x, f y)) (state st s) )
-- |
liftST :: (s -> a) -> ST s a
liftST f = ST (\s -> (s,f s))

-- * STM
-- |
newtype STM m s a = STM {stateM :: s -> m (s, a)}
-- |
instance (Monad m) => Monad (STM m s) where
    return x = STM (\s -> return (s,x))
    p >>= f  = STM (\s -> do {
        ; (s',l) <- stateM p s
        ; stateM (f l) s'})
    fail msg = STM (\_ -> fail msg)
-- |
instance MonadPlus m => MonadPlus (STM m s) where
    mzero = STM (\_ -> mzero)
    a `mplus` b = STM (\s -> (stateM a s) `mplus` (stateM b s))
-- |
instance Monad m => Functor (STM m s) where
    fmap f stm = STM (\s -> stateM stm s >>= (\(s1, a) -> return (s1, f a)))
-- |
liftSTM :: Monad m => ST s (m a) -> STM m s a
liftSTM p = STM (\s -> do {
    ; let (s', l) = (state p s)
    ; lx <- l
    ; return (s',lx)})
-- |
returnSTM :: Monad m => m a -> STM m s a
returnSTM x = STM (\s -> x>>=(\y -> return (s,y)))

\end{code} \begin{code}

-- * Basic
-- |
type CDATA = Prelude.String
-- |
read_CDATA :: Prelude.String -> Result CDATA
read_CDATA = return
-- |
show_CDATA :: CDATA -> Prelude.String
show_CDATA = id
-- | 
type ID = Prelude.String
-- |
read_ID :: Prelude.String -> Result ID
read_ID = return 
-- |
show_ID :: ID -> Prelude.String
show_ID = id

\end{code} \begin{code}

-- * Attributes
-- | 
read_IMPLIED' :: String -> (String -> Result a) -> [Attribute] -> Maybe a
read_IMPLIED' key func s = maybe Nothing 
            (result . func . unwords . 
                map (either id (const "")) . (\(AttValue l) -> l))
            (lookup key s)
    where -- |
          result :: Result a -> Maybe a
          result (Ok x) = Just x
          result (Error _) = Nothing
-- |
read_IMPLIED :: Monad m => 
    String -> (String -> Result a) -> STM m [Attribute] (Maybe a)
read_IMPLIED key func = 
    STM (\s-> return (s, read_IMPLIED' key func s))
-- |
show_IMPLIED :: String -> (a -> String) -> Maybe a -> [Attribute]
show_IMPLIED key function = maybe [] (show_REQUIRED key function)
-- |
read_REQUIRED :: Monad m => String -> (String -> Result a) -> STM m [Attribute] a
read_REQUIRED key func = 
    read_IMPLIED key func >>= 
    maybe (fail ("I expect "++key++" as required attribute")) return
-- |
show_REQUIRED :: String -> (a -> String) -> a -> [Attribute]
show_REQUIRED key function = 
    (:[]) . (\x -> (key, x)) . AttValue . (:[]) . Left . function
-- |
read_DEFAULT :: Monad m => 
    String -> (String -> Result a) -> a -> STM m [Attribute] a
read_DEFAULT key func def = 
    read_IMPLIED key func >>= 
    maybe (return def) return
-- |
show_DEFAULT :: String -> (a -> String) -> a -> [Attribute]
show_DEFAULT = show_REQUIRED
-- |
show_FIXED :: String -> (a -> String) -> a -> [Attribute]
show_FIXED = show_REQUIRED
-- |
read_FIXED :: Monad m => 
    String -> (String -> Result a) -> a -> STM m [Attribute] a
read_FIXED key func def = 
    read_IMPLIED key func >>=
    maybe (return def) return

\end{code} \begin{code}

-- |
read_ELEMENT' :: String -> [Content i] -> ([Content i], Result (Element i))
read_ELEMENT' tag ((CElem (e@(Elem key _ _)) _):t) | key == tag = (t, Ok e)
read_ELEMENT' tag ((CString _ s _):t) | Prelude.and (map isSpace s) = 
    read_ELEMENT' tag t
read_ELEMENT' tag (((CMisc _ _):t)) = read_ELEMENT' tag t
read_ELEMENT' tag l                 = 
    (l, Error ("I expect " ++ tag ++ " element" ++ moreinfo))
    where moreinfo :: String 
          moreinfo = ": [" ++ concat (map conts l) ++ "]"
          -- |
          conts :: Content i -> String
          conts (CElem (Elem k _ _) _) = "<" ++ k ++ "/>"
          conts (CString _ s _) = s
          conts (CRef _ _) = "(ref)"
          conts (CMisc _ _) = "(misc)"
-- |
read_ELEMENT :: String -> STM Result [Content i] (Element i)
read_ELEMENT tag = liftSTM (ST (\s -> read_ELEMENT' tag s))
-- |
show_ELEMENT :: String -> [Attribute] -> [Content ()] -> [Content ()]
show_ELEMENT tag attr contents = [CElem (Elem tag attr contents) ()]
-- |
attributes :: Element i -> [Attribute]
attributes (Elem _ x _) = x
-- |
childs :: Element i -> [Content i]
childs (Elem _ _ x) = x
-- |
type PCDATA = Prelude.String
-- |
read_PCDATA' :: [Content i] -> ([Content i], Result PCDATA)
read_PCDATA' []                  = ([], return [])
read_PCDATA' ((CString _ y _):t) = 
    let (a,b) = read_PCDATA' t
    in (a, b >>= return.(y++))
read_PCDATA' ((CRef y _):t)      = 
    let (a,b) = read_PCDATA' t
    in (a, b >>= return.(read_REF y++))
read_PCDATA' (l@((CElem _ _):_)) = (l, return [])
read_PCDATA' (_:t)               = read_PCDATA' t
-- |
read_REF :: Reference -> PCDATA
read_REF (RefEntity x) = '&' : x ++ ";"
read_REF (RefChar x) = '#' : show x
-- |
read_PCDATA :: STM Result [Content i] PCDATA
read_PCDATA = liftSTM (ST (\s -> read_PCDATA' s))
-- |
show_PCDATA :: PCDATA -> [Content ()]
show_PCDATA pcdata = [CString False pcdata ()]

\end{code} \begin{code}

-- * Elements
-- |
read_MAYBE :: STM Result [Content i] a -> 
    STM Result [Content i] (Maybe a)
read_MAYBE st = STM (\s -> 
        ((stateM st s) >>= (\(z1,z2) -> return (z1, return z2))) 
        `mplus` return (s,Nothing) )
-- |
show_MAYBE :: (a -> [Content ()]) -> Maybe a -> [Content ()]
show_MAYBE f = maybe [] f
-- |
read_LIST :: Eq i => STM Result [Content i] a -> STM Result [Content i] [a]
read_LIST st = STM (\s -> 
    let x = stateM st s
    in case x of
       Ok (x1,x2) -> if s == x1 then return (s,[x2])
                     else let y = stateM (read_LIST st) x1
                          in case y of 
                                Ok (y1,y2) -> return (y1, x2:y2)
                                Error _ -> return (x1, [x2])
       Error _ -> return (s, [])
    )
-- |
show_LIST :: (a -> [Content ()]) -> [a] -> [Content ()]
show_LIST f = concat . map f
-- |
read_LIST1 :: Eq i => STM Result [Content i] a -> STM Result [Content i] [a]
read_LIST1 st = STM (\s -> 
    let x = stateM st s
    in case x of
       Ok (x1,x2) -> if s == x1 then return (s,[x2])
                     else let y = stateM (read_LIST1 st) x1
                          in case y of 
                                Ok (y1,y2) -> return (y1, x2:y2)
                                Error _ -> return (x1, [x2])
       Error _ -> fail "empty list"
    )
-- |
show_LIST1 :: (a -> [Content ()]) -> [a] -> [Content ()]
show_LIST1 = show_LIST

\end{code} \begin{code}

-- * Read 
-- |
read_1 :: Monad m => STM m s a -> s -> STM m s' a
read_1 st1 s = returnSTM (stateM st1 s >>= (\(_,x) -> return x) )
-- |
read_2 :: Monad m => STM m s a -> STM m s b -> s -> STM m s' (a,b)
read_2 st1 st2 s = returnSTM (do
    (s1,a) <- stateM st1 s
    (_,b) <- stateM st2 s1
    return (a,b))
-- |
read_3 :: Monad m => STM m s a -> STM m s b -> STM m s c -> 
    s -> STM m s' (a,b,c)
read_3 st1 st2 st3 s = returnSTM (do
    (s1,a) <- stateM st1 s
    (s2,b) <- stateM st2 s1
    (_,c) <- stateM st3 s2
    return (a,b,c))
-- |
read_4 :: Monad m => STM m s a -> STM m s b -> STM m s c -> 
    STM m s d -> s -> STM m s' (a,b,c,d)
read_4 st1 st2 st3 st4 s = returnSTM (do
    (s1,a) <- stateM st1 s
    (s2,b) <- stateM st2 s1
    (s3,c) <- stateM st3 s2
    (_,d) <- stateM st4 s3
    return (a,b,c,d))
-- |
read_5 :: Monad m => STM m s a -> STM m s b -> STM m s c -> 
    STM m s d -> STM m s e -> s -> STM m s' (a,b,c,d,e)
read_5 st1 st2 st3 st4 st5 s = returnSTM (do
    (s1,a) <- stateM st1 s
    (s2,b) <- stateM st2 s1
    (s3,c) <- stateM st3 s2
    (s4,d) <- stateM st4 s3
    (_,e) <- stateM st5 s4
    return (a,b,c,d,e))
-- |
read_6 :: Monad m => STM m s a -> STM m s b -> STM m s c -> 
    STM m s d -> STM m s e -> STM m s f -> s -> STM m s' (a,b,c,d,e,f)
read_6 st1 st2 st3 st4 st5 st6 s = returnSTM (do
    (s1,a) <- stateM st1 s
    (s2,b) <- stateM st2 s1
    (s3,c) <- stateM st3 s2
    (s4,d) <- stateM st4 s3
    (s5,e) <- stateM st5 s4
    (_,f) <- stateM st6 s5
    return (a,b,c,d,e,f))
-- |
read_7 :: Monad m => STM m s a -> STM m s b -> STM m s c -> 
    STM m s d -> STM m s e -> STM m s f -> STM m s g -> 
    s -> STM m s' (a,b,c,d,e,f,g)
read_7 st1 st2 st3 st4 st5 st6 st7 s = returnSTM (do
    (s1,a) <- stateM st1 s
    (s2,b) <- stateM st2 s1
    (s3,c) <- stateM st3 s2
    (s4,d) <- stateM st4 s3
    (s5,e) <- stateM st5 s4
    (s6,f) <- stateM st6 s5
    (_,g) <- stateM st7 s6
    return (a,b,c,d,e,f,g))
-- |
read_8 :: Monad m => STM m s a -> STM m s b -> STM m s c -> 
    STM m s d -> STM m s e -> STM m s f -> STM m s g -> 
    STM m s h -> s -> STM m s' (a,b,c,d,e,f,g,h)
read_8 st1 st2 st3 st4 st5 st6 st7 st8 s = returnSTM (do
    (s1,a) <- stateM st1 s
    (s2,b) <- stateM st2 s1
    (s3,c) <- stateM st3 s2
    (s4,d) <- stateM st4 s3
    (s5,e) <- stateM st5 s4
    (s6,f) <- stateM st6 s5
    (s7,g) <- stateM st7 s6
    (_,h) <- stateM st8 s7
    return (a,b,c,d,e,f,g,h))
-- |
read_9 :: Monad m => STM m s a -> STM m s b -> STM m s c -> 
    STM m s d -> STM m s e -> STM m s f -> STM m s g -> 
    STM m s h -> STM m s i -> s -> STM m s' (a,b,c,d,e,f,g,h,i)
read_9 st1 st2 st3 st4 st5 st6 st7 st8 st9 s = returnSTM (do
    (s1,a) <- stateM st1 s
    (s2,b) <- stateM st2 s1
    (s3,c) <- stateM st3 s2
    (s4,d) <- stateM st4 s3
    (s5,e) <- stateM st5 s4
    (s6,f) <- stateM st6 s5
    (s7,g) <- stateM st7 s6
    (s8,h) <- stateM st8 s7
    (_,i) <- stateM st9 s8
    return (a,b,c,d,e,f,g,h,i))
-- |
read_10 :: Monad m => STM m s a -> STM m s b -> STM m s c -> 
    STM m s d -> STM m s e -> STM m s f -> STM m s g -> 
    STM m s h -> STM m s i -> STM m s j -> 
    s -> STM m s' (a,b,c,d,e,f,g,h,i,j)
read_10 st1 st2 st3 st4 st5 st6 st7 st8 st9 st10 s = 
  returnSTM (do
    (s1,a) <- stateM st1 s
    (s2,b) <- stateM st2 s1
    (s3,c) <- stateM st3 s2
    (s4,d) <- stateM st4 s3
    (s5,e) <- stateM st5 s4
    (s6,f) <- stateM st6 s5
    (s7,g) <- stateM st7 s6
    (s8,h) <- stateM st8 s7
    (s9,i) <- stateM st9 s8
    (_,j) <- stateM st10 s9
    return (a,b,c,d,e,f,g,h,i,j))
-- |
read_11 :: Monad m => STM m s a -> STM m s b -> STM m s c -> 
    STM m s d -> STM m s e -> STM m s f -> STM m s g -> 
    STM m s h -> STM m s i -> STM m s j -> STM m s k ->
    s -> STM m s' (a,b,c,d,e,f,g,h,i,j,k)
read_11 st1 st2 st3 st4 st5 st6 st7 st8 st9 st10 st11 s = 
  returnSTM (do
    (s1,a) <- stateM st1 s
    (s2,b) <- stateM st2 s1
    (s3,c) <- stateM st3 s2
    (s4,d) <- stateM st4 s3
    (s5,e) <- stateM st5 s4
    (s6,f) <- stateM st6 s5
    (s7,g) <- stateM st7 s6
    (s8,h) <- stateM st8 s7
    (s9,i) <- stateM st9 s8
    (s10,j) <- stateM st10 s9
    (_,k) <- stateM st11 s10
    return (a,b,c,d,e,f,g,h,i,j,k))
-- |
read_12 :: Monad m => STM m s a -> STM m s b -> STM m s c -> 
    STM m s d -> STM m s e -> STM m s f -> STM m s g -> 
    STM m s h -> STM m s i -> STM m s j -> STM m s k -> 
    STM m s l -> s -> STM m s' (a,b,c,d,e,f,g,h,i,j,k,l)
read_12 st1 st2 st3 st4 st5 st6 st7 st8 st9 st10 st11 st12 s = 
  returnSTM (do
    (s1,a) <- stateM st1 s
    (s2,b) <- stateM st2 s1
    (s3,c) <- stateM st3 s2
    (s4,d) <- stateM st4 s3
    (s5,e) <- stateM st5 s4
    (s6,f) <- stateM st6 s5
    (s7,g) <- stateM st7 s6
    (s8,h) <- stateM st8 s7
    (s9,i) <- stateM st9 s8
    (s10,j) <- stateM st10 s9
    (s11,k) <- stateM st11 s10
    (_,l) <- stateM st12 s11
    return (a,b,c,d,e,f,g,h,i,j,k,l))
-- |
read_13 :: Monad m => STM m s a -> STM m s b -> STM m s c -> 
    STM m s d -> STM m s e -> STM m s f -> STM m s g -> 
    STM m s h -> STM m s i -> STM m s j -> STM m s k -> 
    STM m s l -> STM m s n -> s -> STM m s' (a,b,c,d,e,f,g,h,i,j,k,l,n)
read_13 st1 st2 st3 st4 st5 st6 st7 st8 st9 st10 st11 st12 st13 s = 
  returnSTM (do
    (s1,a) <- stateM st1 s
    (s2,b) <- stateM st2 s1
    (s3,c) <- stateM st3 s2
    (s4,d) <- stateM st4 s3
    (s5,e) <- stateM st5 s4
    (s6,f) <- stateM st6 s5
    (s7,g) <- stateM st7 s6
    (s8,h) <- stateM st8 s7
    (s9,i) <- stateM st9 s8
    (s10,j) <- stateM st10 s9
    (s11,k) <- stateM st11 s10
    (s12,l) <- stateM st12 s11
    (_,m) <- stateM st13 s12
    return (a,b,c,d,e,f,g,h,i,j,k,l,m))
-- |
read_17 :: Monad m => STM m s a -> STM m s b -> STM m s c -> 
    STM m s d -> STM m s e -> STM m s f -> STM m s g -> 
    STM m s h -> STM m s i -> STM m s j -> STM m s k -> 
    STM m s l -> STM m s n -> STM m s o -> STM m s p -> 
    STM m s q -> STM m s r -> s -> 
    STM m s' (a,b,c,d,e,f,g,h,i,j,k,l,n,o,p,q,r)
read_17 st1  st2  st3  st4  st5  st6  st7  st8  st9
        st10 st11 st12 st13 st14 st15 st16 st17 s = 
  returnSTM (do
    (s1,a) <- stateM st1 s
    (s2,b) <- stateM st2 s1
    (s3,c) <- stateM st3 s2
    (s4,d) <- stateM st4 s3
    (s5,e) <- stateM st5 s4
    (s6,f) <- stateM st6 s5
    (s7,g) <- stateM st7 s6
    (s8,h) <- stateM st8 s7
    (s9,i) <- stateM st9 s8
    (s10,j) <- stateM st10 s9
    (s11,k) <- stateM st11 s10
    (s12,l) <- stateM st12 s11
    (s13,n) <- stateM st13 s12
    (s14,o) <- stateM st14 s13
    (s15,p) <- stateM st15 s14
    (s16,q) <- stateM st16 s15
    (_,r)   <- stateM st17 s16
    return (a,b,c,d,e,f,g,h,i,j,k,l,n,o,p,q,r))

\end{code} \begin{code}

instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, 
    Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p, Show q) 
    => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where 
  show (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) = "(" ++ show a ++ "," ++ 
    show b ++ "," ++ show c ++ "," ++ show d ++ "," ++ show e ++ "," ++ 
    show f ++ "," ++ show g ++ "," ++ show h ++ "," ++ show i ++ "," ++ 
    show j ++ "," ++ show k ++ "," ++ show l ++ "," ++ show m ++ "," ++ 
    show n ++ "," ++ show o ++ "," ++ show p ++ "," ++ show q ++ ")"

instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, 
    Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p, Eq q) 
    => Eq (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where 
    (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1) ==
        (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2) =
        (a1 == a2) && (b1 == b2) && (c1 == c2) && (d1 == d2) && (e1 == e2) &&
        (f1 == f2) && (g1 == g2) && (h1 == h2) && (i1 == i2) && (j1 == j2) &&
        (k1 == k2) && (l1 == l2) && (m1 == m2) && (n1 == n2) && (o1 == o2) &&
        (p1 == p2) && (q1 == q2)

\end{code}