content: {- |
  Module      :  ./Common/SAX.hs
  Description :  A few helper functions to work with the sax parser
  Copyright   :  (c) Jonathan von Schroeder, DFKI GmbH 2010
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  jonathan.von_schroeder@dfki.de
  Stability   :  experimental
  Portability :  portable
  
  -}
  
  module Common.SAX where
  
  import Control.Monad
  import Common.Lib.Maybe
  import Common.Lib.State
  
  import Text.XML.Expat.SAX
  import qualified Data.ByteString.Lazy as L
  import Data.Char
  
  foldCatchLeft :: Monad m => (a -> MaybeT m a) -> a -> MaybeT m a
  foldCatchLeft fn def = MaybeT $ do
   v <- runMaybeT $ fn def
   case v of
    Just res -> runMaybeT (foldCatchLeft fn res)
    _ -> return (Just def)
  
  whileM :: Monad m => MaybeT m a -> MaybeT m [a]
  whileM fn = liftM reverse $ foldCatchLeft (\ l -> liftM (: l) fn) []
  
  type SaxEvL = [SAXEvent String String]
  type DbgData = (Maybe [String], Bool)
  type MSaxState a = MaybeT (State (SaxEvL, DbgData)) a
  
  getM :: MSaxState (SaxEvL, DbgData)
  getM = liftToMaybeT get
  
  putM :: (SaxEvL, DbgData) -> MSaxState ()
  putM = liftToMaybeT . put
  
  debugS' :: String -> State (SaxEvL, DbgData) (Maybe a)
  debugS' s = do
   (evl, (dbg, do_dbg)) <- get
   if do_dbg then do
    maybe (put (evl, (Just [s], do_dbg)))
          (\ msg -> put (evl, (Just $ s : msg, do_dbg)))
          dbg
    return Nothing
     else return Nothing
  
  debugS :: String -> MSaxState a
  debugS s = MaybeT $ debugS' s
  
  runMSaxState :: MSaxState a -> SaxEvL -> Bool
                  -> (Maybe a, (SaxEvL, DbgData))
  runMSaxState f evl b = runState (runMaybeT f) (evl, (Nothing, b))
  
  getD :: MSaxState SaxEvL
  getD = liftM fst getM
  
  putD :: SaxEvL -> MSaxState ()
  putD evl = do
   (_, dbg) <- getM
   putM (evl, dbg)
  
  parsexml :: L.ByteString -> SaxEvL
  parsexml = parse defaultParseOptions
  
  dropSpaces :: MSaxState ()
  dropSpaces = do
   evl <- getD
   putD $ dropWhile
    (\ e ->
       case e of
        CharacterData d -> all isSpace d
        _ -> False
    ) evl
  
  tag :: MSaxState (Bool, String)
  tag = do
   dropSpaces
   d <- getD
   case d of
     [] -> error "Common.SAX.tag"
     h : xs -> do
       putD xs
       case h of
         StartElement s _ -> return (True, s)
         EndElement s -> return (False, s)
         _ -> debugS $ "Expected a tag - instead got: " ++ show h
  
  expectTag :: Bool -> String -> MSaxState String
  expectTag st s = do
   d <- getM
   MaybeT $ do
    v <- runMaybeT tag
    case v of
     Just p -> let p2 = (st, s) in if p2 /= p
                   then do
                    put d
                    debugS' $ "Expected tag " ++ show p2
                             ++ " but instead got: " ++ show p
                   else return $ Just s
     Nothing -> do
      put d
      debugS' "Expected a tag, but didn't find one - see previous message!"
  
  readWithTag :: MSaxState a -> String -> MSaxState a
  readWithTag fn tagName = do
   expectTag True tagName
   d <- fn
   expectTag False tagName
   return d
  
  readL :: Show a => MSaxState a -> String -> MSaxState [a]
  readL fn = readWithTag (whileM fn)
  
  foldS :: Show a => (a -> MSaxState a) -> a -> String -> MSaxState a
  foldS fn def = readWithTag (foldCatchLeft fn def)
  