diff --git a/Text/XML/Expat/Chunked.hs b/Text/XML/Expat/Chunked.hs
--- a/Text/XML/Expat/Chunked.hs
+++ b/Text/XML/Expat/Chunked.hs
@@ -1,8 +1,28 @@
{-# LANGUAGE ScopedTypeVariables #-}
-module Text.XML.Expat.Chunked where
+module Text.XML.Expat.Chunked (
+ -- * Tree structure
+ CNode,
+ NodeG(..),
-import Text.XML.Expat.Chunked.Iterator
+ -- * Generic node manipulation
+ module Text.XML.Expat.NodeClass,
+
+ -- * Generic manipulation of the child list
+ module Data.List.Class,
+
+ -- * Parse to tree
+ ParserOptions(..),
+ defaultParserOptions,
+ Encoding(..),
+ Text.XML.Expat.Chunked.parse,
+ HandlerT(..),
+ XMLParseError(..),
+ XMLParseLocation(..)
+ ) where
+
+import Control.Monad.ListT
import qualified Text.XML.Expat.IO as IO
+import Text.XML.Expat.NodeClass
import Text.XML.Expat.SAX
import Text.XML.Expat.Tree
@@ -10,61 +30,54 @@
import Control.Monad.Trans
import qualified Data.ByteString as B
import Data.IORef
-import Data.Iteratee hiding (head)
-import qualified Data.Iteratee as It
+import Data.Iteratee hiding (head, peek)
import Data.Iteratee.WrappedByteString
import Data.List.Class
-import Data.Sequence (Seq, (|>), index)
-import qualified Data.Sequence as Seq
import Data.Word
------- Queue ------------------------------------------------------------------
+------ Types ------------------------------------------------------------------
-newtype Queue a = Queue (Seq (Maybe a))
+-- | A tree representation that uses a monadic list as its child list type.
+type CNode m tag text = NodeG (ListT (HandlerT m)) tag text
-emptyQueue :: Queue a
-emptyQueue = Queue (Seq.empty)
-queuePush :: a -> Queue a -> Queue a
-queuePush value (Queue s) = Queue (s |> Just value)
-
-queueEnd :: Queue a -> Queue a
-queueEnd (Queue s) = Queue (s |> Nothing)
+------ Queue ------------------------------------------------------------------
-data QueueValue a
- = Value a
+-- Mutable queue implemented as a linked list
+data QueueCell a
+ = Value a (QueueHead a)
| End
| Pending
-queueIndex :: Queue a -> Int -> QueueValue a
-queueIndex q@(Queue s) i
- | i >= Seq.length s = Pending
- | otherwise = case s `index` i of
- Just value -> Value value
- Nothing -> End
-
-
------- Stack ------------------------------------------------------------------
-
-newtype Stack a = Stack [a]
+newtype QueueHead a = QueueHead (IORef (QueueCell a))
+newtype QueueTail a = QueueTail (IORef (IORef (QueueCell a)))
-emptyStack :: Stack a
-emptyStack = Stack []
+newQueue :: IO (QueueHead a, QueueTail a)
+newQueue = do
+ end <- newIORef Pending
+ endRef <- newIORef end
+ return (QueueHead end, QueueTail endRef)
-stackTop :: Stack a -> a
-stackTop (Stack s) = head s
+peek :: QueueHead a -> IO (QueueCell a)
+peek (QueueHead hRef) = readIORef hRef
-stackPop :: Stack a -> Stack a
-stackPop (Stack s) = Stack (tail s)
+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
-stackPush :: a -> Stack a -> Stack a
-stackPush it (Stack s) = Stack (it:s)
+pushEnd :: QueueTail a -> IO ()
+pushEnd (QueueTail qtRef) = do
+ tl <- readIORef qtRef
+ writeIORef tl End
------ Handler ----------------------------------------------------------------
-data Result m a = Yield (HandlerT m a) | Result a
+data Result m a = Yield (HandlerT m a) | Result a | HandlerErr String
data HandlerT m a = HandlerT {
runHandlerT :: m (Result m a)
@@ -78,9 +91,10 @@
f >>= g = HandlerT $ do
res1 <- runHandlerT f
case res1 of
- Yield c -> return $ Yield (c >>= g)
- Result a -> runHandlerT (g a)
- fail err = HandlerT $ fail err
+ Yield c -> return $ Yield (c >>= g)
+ Result a -> runHandlerT (g a)
+ HandlerErr err -> return $ HandlerErr err
+ fail err = HandlerT $ return $ HandlerErr err
instance MonadTrans HandlerT where
lift m = HandlerT $ do
@@ -97,49 +111,52 @@
-------------------------------------------------------------------------------
-type CNode m tag text = NodeG (Iterator (HandlerT m)) tag text
-
+-- | An iteratee that parses the input document, passing a representation of it
+-- to the specified handler monad. The monad runs lazily using co-routines, so
+-- if it requests a part of the tree that hasn't been parsed yet, it will
+-- be suspended, and continued when it's available.
+--
+-- This implementation does /not/ use Haskell's lazy I/O.
parse :: forall m a tag text . (
MonadIO m,
GenericXMLString tag,
GenericXMLString text
) =>
ParserOptions tag text
- -> (Maybe (CNode m tag text) -> HandlerT m a)
+ -> (CNode m tag text -> HandlerT m a)
-> IterateeG WrappedByteString Word8 m (Either ErrMsg a)
parse opts code = IterateeG $ \str -> do
let enc = parserEncoding opts
parser <- liftIO $ IO.newParser enc
- rootRef <- liftIO $ newIORef emptyQueue
- stackRef <- liftIO $ newIORef $ rootRef `stackPush` emptyStack
+ (rootHd, rootTl) <- liftIO $ newQueue
+ stackRef <- liftIO $ newIORef [rootTl]
liftIO $ IO.setStartElementHandler parser $ \cName cAttrs -> do
- name <- mkText cName
+ name <- textFromCString cName
attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do
- attrName <- mkText cAttrName
- attrValue <- mkText cAttrValue
+ attrName <- textFromCString cAttrName
+ attrValue <- textFromCString cAttrValue
return (attrName, attrValue)
--loc <- getParseLocation parser
stack <- readIORef stackRef
- newRef <- newIORef emptyQueue
- let elt = Element name attrs (Iterator $ iter newRef 0)
- modifyIORef (stackTop stack) (elt `queuePush`)
- modifyIORef stackRef (newRef `stackPush`)
+ (hd, tl) <- newQueue
+ push (head stack) $ Element name attrs (ListT $ iter hd)
+ writeIORef stackRef (tl:stack)
return True
liftIO $ IO.setEndElementHandler parser $ \_ -> do
- --name <- mkText cName
+ --name <- textFromCString cName
--loc <- getParseLocation parser
stack <- readIORef stackRef
- modifyIORef (stackTop stack) queueEnd
- writeIORef stackRef (stackPop stack)
+ pushEnd (head stack)
+ writeIORef stackRef (tail stack)
return True
liftIO $ IO.setCharacterDataHandler parser $ \cText -> do
txt <- gxFromCStringLen cText
--loc <- getParseLocation parser
stack <- readIORef stackRef
- modifyIORef (stackTop stack) (Text txt `queuePush`)
+ push (head stack) $ Text txt
return True
let nextIter :: HandlerT m a
@@ -165,21 +182,24 @@
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 $ show handlerErr) str
let process = do
- elt <- iter rootRef 0
+ elt <- iter rootHd
case elt of
- Nil -> code Nothing
- Cons node _ -> code (Just node)
+ Nil -> fail "no root node"
+ Cons node _ -> code node
runIter (nextIter process) str
where
- iter :: IORef (Queue (CNode m tag text)) -> Int -> HandlerT m (ListItem (Iterator (HandlerT m)) (CNode m tag text))
- iter ref i = do
- queue <- liftIO (readIORef ref)
- case queue `queueIndex` i of -- to do: make it throw away heads we don't have references to
- Pending -> yield >> iter ref i
- End -> return $ Nil
- Value a -> return $
- let i' = i + 1
- in Cons a (Iterator $ iter ref i')
+ iter :: QueueHead (CNode m tag text) -> HandlerT m (ListItem (ListT (HandlerT m)) (CNode 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')
+
diff --git a/Text/XML/Expat/Chunked/Iterator.hs b/Text/XML/Expat/Chunked/Iterator.hs
deleted file mode 100644
--- a/Text/XML/Expat/Chunked/Iterator.hs
+++ /dev/null
@@ -1,101 +0,0 @@
-{-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances,
- StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses #-}
-module Text.XML.Expat.Chunked.Iterator (Iterator (..)) where
-
-import Data.List.Class (List(..), ListItem(..), foldrL)
-
-import Control.Applicative (Applicative(..))
-import Control.Monad (MonadPlus(..), ap, liftM)
--- import Control.Monad.Cont.Class (MonadCont(..))
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Reader.Class (MonadReader(..))
-import Control.Monad.State.Class (MonadState(..))
-import Control.Monad.Trans (MonadTrans(..), MonadIO(..))
-import Data.Monoid (Monoid(..))
-
-
-newtype Iterator m a = Iterator { runIterator :: m (ListItem (Iterator m) a) }
-
-deriving instance (Eq (m (ListItem (Iterator m) a))) => Eq (Iterator m a)
-deriving instance (Ord (m (ListItem (Iterator m) a))) => Ord (Iterator m a)
-deriving instance (Read (m (ListItem (Iterator m) a))) => Read (Iterator m a)
-deriving instance (Show (m (ListItem (Iterator m) a))) => Show (Iterator m a)
-
-{-
-instance (Monad m, MonadPlus (Iterator m)) => List (Iterator m) where
- type ItemM (Iterator m) = m
- runList = runIterator
- joinL m = Iterator $ do
- it <- m
- runIterator it
--}
-
--- for mappend, fmap, bind
-foldrL' :: List l => (a -> l b -> l b) -> l b -> l a -> l b
-foldrL' consFunc nilFunc =
- joinL . foldrL step (return nilFunc)
- where
- step x = return . consFunc x . joinL
-
--- like generic cons except using that one
--- would cause an infinite loop
-cons :: Monad m => a -> Iterator m a -> Iterator m a
-cons x = Iterator . return . Cons x
-
-instance Monad m => Monoid (Iterator m a) where
- mempty = Iterator $ return Nil
- mappend = flip (foldrL' cons)
-
-instance Monad m => Functor (Iterator m) where
- fmap func = foldrL' (cons . func) mempty
-
-instance Monad m => Monad (Iterator m) where
- return = Iterator . return . (`Cons` mempty)
- a >>= b = foldrL' mappend mempty (fmap b a)
-
-instance Monad m => Applicative (Iterator m) where
- pure = return
- (<*>) = ap
-
-instance Monad m => MonadPlus (Iterator m) where
- mzero = mempty
- mplus = mappend
-
-instance MonadTrans Iterator where
- lift = Iterator . liftM (`Cons` mempty)
-
-instance Monad m => List (Iterator m) where
- type ItemM (Iterator m) = m
- runList = runIterator
- joinL = Iterator . (>>= runList)
-
--- YUCK:
--- I can't believe I'm doing this,
--- for compatability with mtl's Iterator.
--- I hate the O(N^2) code length auto-lifts. DRY!!
-
-instance MonadIO m => MonadIO (Iterator m) where
- liftIO = lift . liftIO
-
-{-
--- TODO: understand and verify this instance :)
-instance MonadCont m => MonadCont (Iterator m) where
- callCC f =
- Iterator $ callCC thing
- where
- thing c = runIterator . f $ Iterator . c . (`Cons` mempty)
--}
-
-instance MonadError e m => MonadError e (Iterator m) where
- throwError = lift . throwError
- catchError m = Iterator . catchError (runList m) . (runList .)
-
-instance MonadReader s m => MonadReader s (Iterator m) where
- ask = lift ask
- local f = Iterator . local f . runList
-
-instance MonadState s m => MonadState s (Iterator m) where
- get = lift get
- put = lift . put
-
-
diff --git a/hexpat-iteratee.cabal b/hexpat-iteratee.cabal
--- a/hexpat-iteratee.cabal
+++ b/hexpat-iteratee.cabal
@@ -1,9 +1,22 @@
Cabal-Version: >= 1.6
Name: hexpat-iteratee
-Version: 0.1
-Synopsis: chunked XML parsing using iteratees
+Version: 0.2
+Synopsis: Chunked XML parsing using iteratees
Description:
- Provides chunked XML parsing using iteratees
+ This package provides chunked XML parsing using iteratees. It is especially suited
+ to implementing XML-based socket protocols, but is useful wherever lazy parsing is
+ needed on production systems where you can't tolerate the problems that come with
+ Haskell's lazy I\/O.
+ .
+ The XML is presented as a lazy tree, and is processed by a handler implemented using
+ a special HandlerT monad. This monad is suspended whenever it tries to read a part
+ of the tree that hasn't been parsed yet, and continued as soon as it is available.
+ The resulting code looks and functions very much as if you were using lazy I\/O,
+ only without the associated problems. The handler monad may have effects.
+ .
+ Background: Haskell's lazy I\/O can be problematic in some applications because it
+ doesn't handle I\/O errors properly, and you can't predict when it will clean up its
+ resources, which could result in file handles running out.
Category: XML
License: BSD3
License-File: LICENSE
@@ -14,7 +27,14 @@
(c) 2010 Stephen Blackheath
Homepage: http://haskell.org/haskellwiki/Hexpat/
Build-Type: Simple
-Stability: prototype
+Stability: pre-alpha
+Extra-Source-Files:
+ test/test1.hs
+ test/test2.hs
+ test/test3.hs
+ test/test4.hs
+ test/sudoku.xml
+ test/broken.xml
source-repository head
type: darcs
location: http://code.haskell.org/hexpat-iteratee/
@@ -29,8 +49,7 @@
extensible-exceptions >= 0.1 && < 0.2,
iteratee >= 0.3,
hexpat >= 0.13,
- List >= 0.2
+ List >= 0.3
Exposed-Modules:
Text.XML.Expat.Chunked
- Text.XML.Expat.Chunked.Iterator
ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-matches -fno-warn-missing-signatures -fno-warn-orphans
diff --git a/test/broken.xml b/test/broken.xml
new file mode 100644
--- /dev/null
+++ b/test/broken.xml
diff --git a/test/sudoku.xml b/test/sudoku.xml
new file mode 100644
--- /dev/null
+++ b/test/sudoku.xml
@@ -0,0 +1,27 @@
+
+
+
+ black
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ blackh
+
+
+
+
diff --git a/test/test1.hs b/test/test1.hs
new file mode 100644
--- /dev/null
+++ b/test/test1.hs
@@ -0,0 +1,30 @@
+import Text.XML.Expat.Chunked
+import Text.XML.Expat.Format
+import Text.XML.Expat.Tree hiding (parse)
+
+import Control.Monad
+import Control.Monad.Trans
+import qualified Data.ByteString as B
+import Data.Iteratee
+import Data.List.Class
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.IO
+
+
+main :: IO ()
+main = do
+ eErr <- fileDriver (parse defaultParserOptions dump) "sudoku.xml"
+ case eErr of
+ Left err -> putStrLn $ "failed: "++show err
+ Right () -> putStrLn ""
+
+dump :: CNode IO Text Text -> HandlerT IO ()
+dump doc = do
+ let txt = formatG doc
+ execute $ forL txt $ liftIO . B.hPutStr stdout
+ where
+ mapL :: List c => (a -> ItemM c b) -> c a -> c b
+ mapL f = joinM . liftM f
+ forL = flip mapL
+
diff --git a/test/test2.hs b/test/test2.hs
new file mode 100644
--- /dev/null
+++ b/test/test2.hs
@@ -0,0 +1,25 @@
+import Text.XML.Expat.Chunked
+import Text.XML.Expat.Format
+import Text.XML.Expat.Tree hiding (parse)
+
+import Control.Monad
+import Control.Monad.Trans
+import qualified Data.ByteString as B
+import Data.Iteratee
+import Data.List.Class
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.IO
+
+
+main :: IO ()
+main = do
+ eErr <- fileDriver (parse defaultParserOptions dump) "sudoku.xml"
+ case eErr of
+ Left err -> putStrLn $ "failed: "++show err
+ Right () -> putStrLn ""
+
+dump :: CNode IO Text Text -> HandlerT IO ()
+dump doc = do
+ fail "die!"
+
diff --git a/test/test3.hs b/test/test3.hs
new file mode 100644
--- /dev/null
+++ b/test/test3.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+import Text.XML.Expat.Chunked
+import Text.XML.Expat.Format
+import Text.XML.Expat.Tree hiding (parse)
+
+import Control.Exception
+import Control.Monad
+import Control.Monad.Trans
+import qualified Data.ByteString as B
+import Data.Iteratee
+import Data.Iteratee.Base.StreamChunk (ReadableChunk (..))
+import Data.List.Class
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.IO
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Foreign.Storable
+
+
+main :: IO ()
+main = do
+ eErr <- myFileDriver (parse defaultParserOptions dump) "sudoku.xml"
+ case eErr of
+ Left err -> putStrLn $ "failed: "++show err
+ Right () -> putStrLn ""
+
+dump :: CNode IO Text Text -> HandlerT IO ()
+dump doc = do
+ let txt = formatG doc
+ forIter txt $ liftIO . B.hPutStr stdout
+ return ()
+
+forIter :: (List l) => l a -> (a -> ItemM l b) -> ItemM l [b]
+forIter iter body = fi iter []
+ where
+ fi iter acc = do
+ elt <- runList iter
+ case elt of
+ Cons value iter' -> do
+ b <- body value
+ fi iter' (b:acc)
+ Nil -> return (reverse acc)
+
+-- ------------------------------------------------------------------------
+-- Binary Random IO enumerators
+
+myBufSize = 16
+
+-- |The enumerator of a file Handle. This version enumerates
+-- over the entire contents of a file, in order, unless stopped by
+-- the iteratee. In particular, seeking is not supported.
+myEnumHandle :: forall s el m a.(ReadableChunk s el, MonadIO m) =>
+ Handle ->
+ EnumeratorGM s el m a
+myEnumHandle h i =
+ liftIO (mallocForeignPtrBytes (fromIntegral buffer_size)) >>= loop i
+ where
+ buffer_size = myBufSize - mod myBufSize (sizeOf (undefined :: el))
+ loop iter fp = do
+ s <- liftIO . withForeignPtr fp $ \p -> do
+ n <- try $ hGetBuf h p buffer_size :: IO (Either SomeException Int)
+ case n of
+ Left _ -> return $ Left "IO error"
+ Right 0 -> return $ Right Nothing
+ Right n' -> liftM (Right . Just) $ readFromPtr p (fromIntegral n')
+ liftIO $ putStr "|" -- ###
+ checkres fp iter s
+ checkres fp iter = either (flip enumErr iter)
+ (maybe (return iter)
+ (check fp <=< runIter iter . Chunk))
+ check _p (Done x _) = return . return $ x
+ check p (Cont i' Nothing) = loop i' p
+ check _p (Cont _ (Just e)) = return $ throwErr e
+
+-- |Process a file using the given IterateeGM. This function wraps
+-- enumHandle as a convenience.
+myFileDriver :: (MonadIO m, ReadableChunk s el) =>
+ IterateeG s el m a ->
+ FilePath ->
+ m a
+myFileDriver iter filepath = do
+ h <- liftIO $ openBinaryFile filepath ReadMode
+ result <- myEnumHandle h iter >>= run
+ liftIO $ hClose h
+ return result
+
diff --git a/test/test4.hs b/test/test4.hs
new file mode 100644
--- /dev/null
+++ b/test/test4.hs
@@ -0,0 +1,30 @@
+import Text.XML.Expat.Chunked
+import Text.XML.Expat.Format
+import Text.XML.Expat.Tree hiding (parse)
+
+import Control.Monad
+import Control.Monad.Trans
+import qualified Data.ByteString as B
+import Data.Iteratee
+import Data.List.Class
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.IO
+
+
+main :: IO ()
+main = do
+ eErr <- fileDriver (parse defaultParserOptions dump) "broken.xml"
+ case eErr of
+ Left err -> putStrLn $ "failed: "++show err
+ Right () -> putStrLn ""
+
+dump :: CNode IO Text Text -> HandlerT IO ()
+dump doc = do
+ let txt = formatG doc
+ execute $ forL txt $ liftIO . B.hPutStr stdout
+ where
+ mapL :: List c => (a -> ItemM c b) -> c a -> c b
+ mapL f = joinM . liftM f
+ forL = flip mapL
+