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

-- * 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) = error msg
-- | 
fromError :: Result a -> String
fromError (Ok _)      = []
fromError (Error msg) = msg

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

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

-- * 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

-- * 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) -> StateT m [Attribute] (Maybe a)
read_IMPLIED key func = 
    StateT (\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) -> StateT 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 -> StateT 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 -> StateT m [Attribute] a
read_FIXED key func def = 
    read_IMPLIED key func >>=
    maybe (return def) return

-- |
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 -> StateT Result [Content i] (Element i)
read_ELEMENT tag = liftStateT (State (\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 :: StateT Result [Content i] PCDATA
read_PCDATA = liftStateT (State (\s -> read_PCDATA' s))
-- |
show_PCDATA :: PCDATA -> [Content ()]
show_PCDATA pcdata = [CString False pcdata ()]

-- * Elements
-- |
read_MAYBE :: StateT Result [Content i] a -> 
    StateT Result [Content i] (Maybe a)
read_MAYBE st = StateT (\s -> 
        ((stateT 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 => StateT Result [Content i] a -> StateT Result [Content i] [a]
read_LIST st = StateT (\s -> 
    let x = stateT st s
    in case x of
       Ok (x1,x2) -> if s == x1 then return (s,[x2])
                     else let y = stateT (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 => StateT Result [Content i] a -> StateT Result [Content i] [a]
read_LIST1 st = StateT (\s -> 
    let x = stateT st s
    in case x of
       Ok (x1,x2) -> if s == x1 then return (s,[x2])
                     else let y = stateT (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

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

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)