{- |
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 :: (a -> MaybeT m a) -> a -> MaybeT m a
foldCatchLeft fn :: a -> MaybeT m a
fn def :: a
def = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe a) -> MaybeT m a) -> m (Maybe a) -> MaybeT m a
forall a b. (a -> b) -> a -> b
$ do
 Maybe a
v <- MaybeT m a -> m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m a -> m (Maybe a)) -> MaybeT m a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> MaybeT m a
fn a
def
 case Maybe a
v of
  Just res :: a
res -> MaybeT m a -> m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT ((a -> MaybeT m a) -> a -> MaybeT m a
forall (m :: * -> *) a.
Monad m =>
(a -> MaybeT m a) -> a -> MaybeT m a
foldCatchLeft a -> MaybeT m a
fn a
res)
  _ -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
def)

whileM :: Monad m => MaybeT m a -> MaybeT m [a]
whileM :: MaybeT m a -> MaybeT m [a]
whileM fn :: MaybeT m a
fn = ([a] -> [a]) -> MaybeT m [a] -> MaybeT m [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [a] -> [a]
forall a. [a] -> [a]
reverse (MaybeT m [a] -> MaybeT m [a]) -> MaybeT m [a] -> MaybeT m [a]
forall a b. (a -> b) -> a -> b
$ ([a] -> MaybeT m [a]) -> [a] -> MaybeT m [a]
forall (m :: * -> *) a.
Monad m =>
(a -> MaybeT m a) -> a -> MaybeT m a
foldCatchLeft (\ l :: [a]
l -> (a -> [a]) -> MaybeT m a -> MaybeT m [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
l) MaybeT m a
fn) []

type SaxEvL = [SAXEvent String String]
type DbgData = (Maybe [String], Bool)
type MSaxState a = MaybeT (State (SaxEvL, DbgData)) a

getM :: MSaxState (SaxEvL, DbgData)
getM :: MSaxState (SaxEvL, DbgData)
getM = State (SaxEvL, DbgData) (SaxEvL, DbgData)
-> MSaxState (SaxEvL, DbgData)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftToMaybeT State (SaxEvL, DbgData) (SaxEvL, DbgData)
forall s. State s s
get

putM :: (SaxEvL, DbgData) -> MSaxState ()
putM :: (SaxEvL, DbgData) -> MSaxState ()
putM = State (SaxEvL, DbgData) () -> MSaxState ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftToMaybeT (State (SaxEvL, DbgData) () -> MSaxState ())
-> ((SaxEvL, DbgData) -> State (SaxEvL, DbgData) ())
-> (SaxEvL, DbgData)
-> MSaxState ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SaxEvL, DbgData) -> State (SaxEvL, DbgData) ()
forall s. s -> State s ()
put

debugS' :: String -> State (SaxEvL, DbgData) (Maybe a)
debugS' :: String -> State (SaxEvL, DbgData) (Maybe a)
debugS' s :: String
s = do
 (evl :: SaxEvL
evl, (dbg :: Maybe [String]
dbg, do_dbg :: Bool
do_dbg)) <- State (SaxEvL, DbgData) (SaxEvL, DbgData)
forall s. State s s
get
 if Bool
do_dbg then do
  State (SaxEvL, DbgData) ()
-> ([String] -> State (SaxEvL, DbgData) ())
-> Maybe [String]
-> State (SaxEvL, DbgData) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((SaxEvL, DbgData) -> State (SaxEvL, DbgData) ()
forall s. s -> State s ()
put (SaxEvL
evl, ([String] -> Maybe [String]
forall a. a -> Maybe a
Just [String
s], Bool
do_dbg)))
        (\ msg :: [String]
msg -> (SaxEvL, DbgData) -> State (SaxEvL, DbgData) ()
forall s. s -> State s ()
put (SaxEvL
evl, ([String] -> Maybe [String]
forall a. a -> Maybe a
Just ([String] -> Maybe [String]) -> [String] -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ String
s String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msg, Bool
do_dbg)))
        Maybe [String]
dbg
  Maybe a -> State (SaxEvL, DbgData) (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
   else Maybe a -> State (SaxEvL, DbgData) (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

debugS :: String -> MSaxState a
debugS :: String -> MSaxState a
debugS s :: String
s = State (SaxEvL, DbgData) (Maybe a) -> MSaxState a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (State (SaxEvL, DbgData) (Maybe a) -> MSaxState a)
-> State (SaxEvL, DbgData) (Maybe a) -> MSaxState a
forall a b. (a -> b) -> a -> b
$ String -> State (SaxEvL, DbgData) (Maybe a)
forall a. String -> State (SaxEvL, DbgData) (Maybe a)
debugS' String
s

runMSaxState :: MSaxState a -> SaxEvL -> Bool
                -> (Maybe a, (SaxEvL, DbgData))
runMSaxState :: MSaxState a -> SaxEvL -> Bool -> (Maybe a, (SaxEvL, DbgData))
runMSaxState f :: MSaxState a
f evl :: SaxEvL
evl b :: Bool
b = State (SaxEvL, DbgData) (Maybe a)
-> (SaxEvL, DbgData) -> (Maybe a, (SaxEvL, DbgData))
forall s a. State s a -> s -> (a, s)
runState (MSaxState a -> State (SaxEvL, DbgData) (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MSaxState a
f) (SaxEvL
evl, (Maybe [String]
forall a. Maybe a
Nothing, Bool
b))

getD :: MSaxState SaxEvL
getD :: MSaxState SaxEvL
getD = ((SaxEvL, DbgData) -> SaxEvL)
-> MSaxState (SaxEvL, DbgData) -> MSaxState SaxEvL
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (SaxEvL, DbgData) -> SaxEvL
forall a b. (a, b) -> a
fst MSaxState (SaxEvL, DbgData)
getM

putD :: SaxEvL -> MSaxState ()
putD :: SaxEvL -> MSaxState ()
putD evl :: SaxEvL
evl = do
 (_, dbg :: DbgData
dbg) <- MSaxState (SaxEvL, DbgData)
getM
 (SaxEvL, DbgData) -> MSaxState ()
putM (SaxEvL
evl, DbgData
dbg)

parsexml :: L.ByteString -> SaxEvL
parsexml :: ByteString -> SaxEvL
parsexml = ParseOptions String String -> ByteString -> SaxEvL
forall tag text.
(GenericXMLString tag, GenericXMLString text) =>
ParseOptions tag text -> ByteString -> [SAXEvent tag text]
parse ParseOptions String String
forall tag text. ParseOptions tag text
defaultParseOptions

dropSpaces :: MSaxState ()
dropSpaces :: MSaxState ()
dropSpaces = do
 SaxEvL
evl <- MSaxState SaxEvL
getD
 SaxEvL -> MSaxState ()
putD (SaxEvL -> MSaxState ()) -> SaxEvL -> MSaxState ()
forall a b. (a -> b) -> a -> b
$ (SAXEvent String String -> Bool) -> SaxEvL -> SaxEvL
forall a. (a -> Bool) -> [a] -> [a]
dropWhile
  (\ e :: SAXEvent String String
e ->
     case SAXEvent String String
e of
      CharacterData d :: String
d -> (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
d
      _ -> Bool
False
  ) SaxEvL
evl

tag :: MSaxState (Bool, String)
tag :: MSaxState (Bool, String)
tag = do
 MSaxState ()
dropSpaces
 SaxEvL
d <- MSaxState SaxEvL
getD
 case SaxEvL
d of
   [] -> String -> MSaxState (Bool, String)
forall a. HasCallStack => String -> a
error "Common.SAX.tag"
   h :: SAXEvent String String
h : xs :: SaxEvL
xs -> do
     SaxEvL -> MSaxState ()
putD SaxEvL
xs
     case SAXEvent String String
h of
       StartElement s :: String
s _ -> (Bool, String) -> MSaxState (Bool, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, String
s)
       EndElement s :: String
s -> (Bool, String) -> MSaxState (Bool, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, String
s)
       _ -> String -> MSaxState (Bool, String)
forall a. String -> MSaxState a
debugS (String -> MSaxState (Bool, String))
-> String -> MSaxState (Bool, String)
forall a b. (a -> b) -> a -> b
$ "Expected a tag - instead got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SAXEvent String String -> String
forall a. Show a => a -> String
show SAXEvent String String
h

expectTag :: Bool -> String -> MSaxState String
expectTag :: Bool -> String -> MSaxState String
expectTag st :: Bool
st s :: String
s = do
 (SaxEvL, DbgData)
d <- MSaxState (SaxEvL, DbgData)
getM
 State (SaxEvL, DbgData) (Maybe String) -> MSaxState String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (State (SaxEvL, DbgData) (Maybe String) -> MSaxState String)
-> State (SaxEvL, DbgData) (Maybe String) -> MSaxState String
forall a b. (a -> b) -> a -> b
$ do
  Maybe (Bool, String)
v <- MSaxState (Bool, String)
-> State (SaxEvL, DbgData) (Maybe (Bool, String))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MSaxState (Bool, String)
tag
  case Maybe (Bool, String)
v of
   Just p :: (Bool, String)
p -> let p2 :: (Bool, String)
p2 = (Bool
st, String
s) in if (Bool, String)
p2 (Bool, String) -> (Bool, String) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Bool, String)
p
                 then do
                  (SaxEvL, DbgData) -> State (SaxEvL, DbgData) ()
forall s. s -> State s ()
put (SaxEvL, DbgData)
d
                  String -> State (SaxEvL, DbgData) (Maybe String)
forall a. String -> State (SaxEvL, DbgData) (Maybe a)
debugS' (String -> State (SaxEvL, DbgData) (Maybe String))
-> String -> State (SaxEvL, DbgData) (Maybe String)
forall a b. (a -> b) -> a -> b
$ "Expected tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Bool, String) -> String
forall a. Show a => a -> String
show (Bool, String)
p2
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ " but instead got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Bool, String) -> String
forall a. Show a => a -> String
show (Bool, String)
p
                 else Maybe String -> State (SaxEvL, DbgData) (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> State (SaxEvL, DbgData) (Maybe String))
-> Maybe String -> State (SaxEvL, DbgData) (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
s
   Nothing -> do
    (SaxEvL, DbgData) -> State (SaxEvL, DbgData) ()
forall s. s -> State s ()
put (SaxEvL, DbgData)
d
    String -> State (SaxEvL, DbgData) (Maybe String)
forall a. String -> State (SaxEvL, DbgData) (Maybe a)
debugS' "Expected a tag, but didn't find one - see previous message!"

readWithTag :: MSaxState a -> String -> MSaxState a
readWithTag :: MSaxState a -> String -> MSaxState a
readWithTag fn :: MSaxState a
fn tagName :: String
tagName = do
 Bool -> String -> MSaxState String
expectTag Bool
True String
tagName
 a
d <- MSaxState a
fn
 Bool -> String -> MSaxState String
expectTag Bool
False String
tagName
 a -> MSaxState a
forall (m :: * -> *) a. Monad m => a -> m a
return a
d

readL :: Show a => MSaxState a -> String -> MSaxState [a]
readL :: MSaxState a -> String -> MSaxState [a]
readL fn :: MSaxState a
fn = MSaxState [a] -> String -> MSaxState [a]
forall a. MSaxState a -> String -> MSaxState a
readWithTag (MSaxState a -> MSaxState [a]
forall (m :: * -> *) a. Monad m => MaybeT m a -> MaybeT m [a]
whileM MSaxState a
fn)

foldS :: Show a => (a -> MSaxState a) -> a -> String -> MSaxState a
foldS :: (a -> MSaxState a) -> a -> String -> MSaxState a
foldS fn :: a -> MSaxState a
fn def :: a
def = MSaxState a -> String -> MSaxState a
forall a. MSaxState a -> String -> MSaxState a
readWithTag ((a -> MSaxState a) -> a -> MSaxState a
forall (m :: * -> *) a.
Monad m =>
(a -> MaybeT m a) -> a -> MaybeT m a
foldCatchLeft a -> MSaxState a
fn a
def)