SAX.hs revision e9458b1a7a19a63aa4c179f9ab20f4d50681c168
{- |
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)