module Text.XML.Expat.Chunked (
Node,
Tree.NodeG(..),
UNode,
module Text.XML.Expat.Internal.NodeClass,
module Data.List.Class,
QNode,
module Text.XML.Expat.Internal.Qualified,
NNode,
module Text.XML.Expat.Internal.Namespaced,
ParseOptions(..),
defaultParseOptions,
Encoding(..),
Text.XML.Expat.Chunked.parse,
XMLT,
XMLParseError(..),
XMLParseLocation(..)
) where
import Control.Monad.ListT
import qualified Text.XML.Expat.Internal.IO as IO
import Text.XML.Expat.Internal.Namespaced
import Text.XML.Expat.Internal.NodeClass
import Text.XML.Expat.Internal.Qualified
import Text.XML.Expat.SAX
import qualified Text.XML.Expat.Tree as Tree
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import qualified Data.ByteString as B
import Data.IORef
import Data.Iteratee hiding (head, peek)
import Data.Iteratee.WrappedByteString
import Data.List.Class
import Data.Word
type Node s m tag text = Tree.NodeG (ListT (XMLT s m)) tag text
type UNode s m text = Node s m text text
type QNode s m a text = Node s a (QName text) text
type NNode s m text a = Node s a (NName text) text
data QueueCell a
= Value a (QueueHead a)
| End
| Pending
newtype QueueHead a = QueueHead (IORef (QueueCell a))
newtype QueueTail a = QueueTail (IORef (IORef (QueueCell a)))
newQueue :: IO (QueueHead a, QueueTail a)
newQueue = do
end <- newIORef Pending
endRef <- newIORef end
return (QueueHead end, QueueTail endRef)
peek :: QueueHead a -> IO (QueueCell a)
peek (QueueHead hRef) = readIORef hRef
push :: QueueTail a -> a -> IO ()
push (QueueTail qtRef) val = do
tl <- readIORef qtRef
newTl <- newIORef Pending
writeIORef tl (Value val (QueueHead newTl))
writeIORef qtRef newTl
pushEnd :: QueueTail a -> IO ()
pushEnd (QueueTail qtRef) = do
tl <- readIORef qtRef
writeIORef tl End
data Result s m a = Yield (XMLT s m a) | Result a | HandlerErr String
data XMLT s m a = XMLT {
runXMLT :: m (Result s m a)
}
instance Monad m => Functor (XMLT s m) where
fmap = liftM
instance Monad m => Monad (XMLT s m) where
return a = XMLT $ return $ Result a
f >>= g = XMLT $ do
res1 <- runXMLT f
case res1 of
Yield c -> return $ Yield (c >>= g)
Result a -> runXMLT (g a)
HandlerErr err -> return $ HandlerErr err
fail err = XMLT $ return $ HandlerErr err
instance MonadTrans (XMLT s) where
lift m = XMLT $ do
r <- m
return $ Result r
instance MonadIO m => MonadIO (XMLT s m) where
liftIO m = XMLT $ do
r <- liftIO m
return $ Result r
yield :: Monad m => XMLT s m ()
yield = XMLT $ return $ Yield (XMLT $ return $ Result ())
parse :: forall m a tag text . (
MonadIO m,
GenericXMLString tag,
GenericXMLString text
) =>
ParseOptions tag text
-> (forall s . ListT (XMLT s m) (Node s m tag text) -> XMLT s m a)
-> m (IterateeG WrappedByteString Word8 m (Either ErrMsg a))
parse opts handler = do
let enc = defaultEncoding opts
parser <- liftIO $ IO.newParser enc
(rootHd, rootTl) <- liftIO $ newQueue
stackRef <- liftIO $ newIORef [rootTl]
liftIO $ IO.setStartElementHandler parser $ \_ cName cAttrs -> do
name <- textFromCString cName
attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do
attrName <- textFromCString cAttrName
attrValue <- textFromCString cAttrValue
return (attrName, attrValue)
stack <- readIORef stackRef
(hd, tl) <- newQueue
push (head stack) $ Tree.Element name attrs (ListT $ iter hd)
case stack of
[_] -> pushEnd rootTl
_ -> return ()
writeIORef stackRef (tl:stack)
return True
liftIO $ IO.setEndElementHandler parser $ \_ _ -> do
stack <- readIORef stackRef
pushEnd (head stack)
writeIORef stackRef (tail stack)
return True
liftIO $ IO.setCharacterDataHandler parser $ \_ cText -> do
txt <- gxFromCStringLen cText
stack <- readIORef stackRef
push (head stack) $ Tree.Text txt
return True
let nextIter :: XMLT s m a
-> IterateeG WrappedByteString Word8 m (Either ErrMsg a)
nextIter handler = IterateeG $ \str -> do
case str of
EOF (Just err) -> return $ Done (Left err) str
_ -> do
mErr <- liftIO $ IO.withParser parser $ \pp -> case str of
Chunk (WrapBS blk) -> IO.parseChunk pp blk False
EOF _ -> IO.parseChunk pp B.empty True
res <- runXMLT handler
return $ case res of
Yield handler' -> do
case (str, mErr) of
(Chunk _, Just err) -> Cont (nextIter handler') (Just $ Err $ show err)
(Chunk _, Nothing) -> Cont (nextIter handler') Nothing
(EOF _, Just err) -> Done (Left $ Err $ show err) str
(EOF _, Nothing) -> Done (Left $ Err "EOF not handled") str
Result a -> do
case mErr of
Just err -> Done (Left $ Err $ show err) str
Nothing -> Done (Right a) str
HandlerErr handlerErr -> do
case mErr of
Just parseErr -> Done (Left $ Err $ show parseErr) str
Nothing -> Done (Left $ Err handlerErr) str
res <- runXMLT $ handler $ ListT $ iter rootHd
return $ case res of
Yield handler' -> nextIter handler'
Result a -> fail $ "handler returned before it demanded from the tree"
HandlerErr err -> fail $ "handler error before it demanded from the tree: "++err
where
iter :: QueueHead (Node s m tag text) -> XMLT s m (ListItem (ListT (XMLT s m)) (Node s m tag text))
iter hd = do
cell <- liftIO $ peek hd
case cell of
Pending -> yield >> iter hd
End -> return $ Nil
Value a hd' -> return $ Cons a (ListT $ iter hd')