hets/Common/SAX.hs

{- |
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)