hexpat-iteratee 0.3 → 0.4

raw patch · 7 files changed

+170/−72 lines, 7 filesdep +transformersdep −mtldep ~Listdep ~hexpatPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

Dependencies removed: mtl

Dependency ranges changed: List, hexpat

API changes (from Hackage documentation)

Files

• Text/XML/Expat/Chunked.hs +82/−57
• hexpat-iteratee.cabal +10/−7
• test/client-server/server.hs +70/−0
• test/test1.hs +3/−2
• test/test2.hs +1/−2
• test/test3.hs +1/−2
• test/test4.hs +3/−2

@@ -1,33 +1,45 @@ {-# LANGUAGE ScopedTypeVariables #-} module Text.XML.Expat.Chunked (-        -- * Tree structure-        CNode,-        NodeG(..),+  -- * Tree structure+  Node,+  Tree.NodeG(..),+  UNode, -        -- * Generic node manipulation-        module Text.XML.Expat.NodeClass,+  -- * Generic node manipulation+  module Text.XML.Expat.Internal.NodeClass, -        -- * Generic manipulation of the child list-        module Data.List.Class,+  -- * 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+  -- * Qualified nodes+  QNode,+  module Text.XML.Expat.Internal.Qualified, +  -- * Namespaced nodes+  NNode,+  module Text.XML.Expat.Internal.Namespaced,++  -- * Parse to tree+  ParserOptions(..),+  defaultParserOptions,+  Encoding(..),+  Text.XML.Expat.Chunked.parse,+  XMLT(..),+  XMLParseError(..),+  XMLParseLocation(..)+  ) where+ import Control.Monad.ListT-import qualified Text.XML.Expat.IO as IO-import Text.XML.Expat.NodeClass+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 Text.XML.Expat.Tree+import qualified Text.XML.Expat.Tree as Tree  import Control.Monad-import Control.Monad.Trans+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)@@ -39,9 +51,22 @@ ------ Types ------------------------------------------------------------------  -- | A tree representation that uses a monadic list as its child list type.-type CNode m tag text = NodeG (ListT (HandlerT m)) tag text+--+-- Note that you can use the type function 'ListOf' to give a list of+-- any node type, using that node's associated list type, e.g.+-- @ListOf (UNode Text)@+type Node m tag text = Tree.NodeG (ListT (XMLT m)) tag text +-- | Type alias for a single node with unqualified tag names where tag and+-- text are the same string type.+type UNode m text = Node m text text +-- | Type alias for a single annotated node where qualified names are used for tags+type QNode m a text = Node a (QName text) text++-- | Type alias for a single annotated node where namespaced names are used for tags+type NNode m text a = Node a (NName text) text+ ------ Queue ------------------------------------------------------------------  -- Mutable queue implemented as a linked list@@ -77,37 +102,39 @@  ------ Handler ---------------------------------------------------------------- -data Result m a = Yield (HandlerT m a) | Result a | HandlerErr String+data Result m a = Yield (XMLT m a) | Result a | HandlerErr String -data HandlerT m a = HandlerT {-        runHandlerT :: m (Result m a)+-- | The monad transformer used for writing your handler for chunked XML trees,+-- which executes as a co-routine.+data XMLT m a = XMLT {+        runXMLT :: m (Result m a)     } -instance Monad m => Functor (HandlerT m) where+instance Monad m => Functor (XMLT m) where     fmap = liftM -instance Monad m => Monad (HandlerT m) where-    return a = HandlerT $ return $ Result a-    f >>= g = HandlerT $ do-        res1 <- runHandlerT f+instance Monad m => Monad (XMLT 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       -> runHandlerT (g a)+            Result a       -> runXMLT (g a)             HandlerErr err -> return $ HandlerErr err -    fail err = HandlerT $ return $ HandlerErr err+    fail err = XMLT $ return $ HandlerErr err -instance MonadTrans HandlerT where-    lift m = HandlerT $ do+instance MonadTrans XMLT where+    lift m = XMLT $ do         r <- m         return $ Result r -instance MonadIO m => MonadIO (HandlerT m) where-    liftIO m = HandlerT $ do+instance MonadIO m => MonadIO (XMLT m) where+    liftIO m = XMLT $ do         r <- liftIO m         return $ Result r -yield :: Monad m => HandlerT m ()-yield = HandlerT $ return $ Yield (HandlerT $ return $ Result ())+yield :: Monad m => XMLT m ()+yield = XMLT $ return $ Yield (XMLT $ return $ Result ())  ------------------------------------------------------------------------------- @@ -123,9 +150,9 @@              GenericXMLString text          ) =>          ParserOptions tag text-      -> (CNode m tag text -> HandlerT m a)-      -> IterateeG WrappedByteString Word8 m (Either ErrMsg a)-parse opts code = IterateeG $ \str -> do+      -> (ListT (XMLT m) (Node m tag text) -> XMLT m a)+      -> m (IterateeG WrappedByteString Word8 m (Either ErrMsg a))+parse opts handler = do     let enc = parserEncoding opts      parser <- liftIO $ IO.newParser enc@@ -142,7 +169,7 @@         --loc <- getParseLocation parser         stack <- readIORef stackRef         (hd, tl) <- newQueue-        push (head stack) $ Element name attrs (ListT $ iter hd)+        push (head stack) $ Tree.Element name attrs (ListT $ iter hd)         writeIORef stackRef (tl:stack)         return True     liftIO $ IO.setEndElementHandler parser $ \_ _ -> do@@ -156,12 +183,12 @@         txt <- gxFromCStringLen cText         --loc <- getParseLocation parser         stack <- readIORef stackRef-        push (head stack) $ Text txt+        push (head stack) $ Tree.Text txt         return True -    let nextIter :: HandlerT m a+    let nextIter :: XMLT m a                  -> IterateeG WrappedByteString Word8 m (Either ErrMsg a)-        nextIter c = IterateeG $ \str -> do+        nextIter handler = IterateeG $ \str -> do             case str of                 EOF (Just err) -> return $ Done (Left err) str                 _ -> do@@ -169,13 +196,13 @@                         Chunk (WrapBS blk) -> IO.parseChunk pp blk False                         EOF _              -> IO.parseChunk pp B.empty True -                    res <- runHandlerT c+                    res <- runXMLT handler                      return $ case res of-                        Yield c' -> do+                        Yield handler' -> do                             case (str, mErr) of-                                (Chunk _, Just err) -> Cont (nextIter c') (Just $ Err $ show err)-                                (Chunk _, Nothing)  -> Cont (nextIter c') Nothing+                                (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@@ -185,17 +212,15 @@                         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 rootHd-            case elt of-                Nil         -> fail "no root node"-                Cons node _ -> code node-    runIter (nextIter process) 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 (CNode m tag text) -> HandlerT m (ListItem (ListT (HandlerT m)) (CNode m tag text))+    iter :: QueueHead (Node m tag text) -> XMLT m (ListItem (ListT (XMLT m)) (Node m tag text))     iter hd = do         cell <- liftIO $ peek hd         case cell of

@@ -1,6 +1,6 @@ Cabal-Version: >= 1.6 Name: hexpat-iteratee-Version: 0.3+Version: 0.4 Synopsis: Chunked XML parsing using iteratees Description:   This package provides chunked XML parsing using iteratees.  It is especially suited@@ -9,10 +9,12 @@   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.+  a monad transformer called XMLT.  The resulting 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.+  only without the associated problems. Your handlers can have effects, yet they+  come out in quite a functional style.   .   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@@ -35,6 +37,7 @@     test/test4.hs     test/sudoku.xml     test/broken.xml+    test/client-server/server.hs source-repository head     type:     darcs     location: http://code.haskell.org/hexpat-iteratee/@@ -43,13 +46,13 @@   Build-Depends:     base >= 3 && < 5,     bytestring,-    mtl,+    transformers,     parallel,     containers,     extensible-exceptions >= 0.1 && < 0.2,     iteratee >= 0.3,-    hexpat >= 0.15,-    List >= 0.3+    hexpat >= 0.16,+    List >= 0.4   Exposed-Modules:     Text.XML.Expat.Chunked   ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-matches -fno-warn-missing-signatures -fno-warn-orphans

@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.ListT+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B (unsafeUseAsCStringLen)+import Data.Iteratee+import Data.Iteratee.IO.Fd+import Data.Iteratee.WrappedByteString+import Data.List.Class+import Data.Text (Text)+import qualified Data.Text as T+import Network+import System.IO+import System.Posix.IO (handleToFd, fdWriteBuf, closeFd)+import System.Posix.Types (Fd)+import Text.XML.Expat.Chunked+import Text.XML.Expat.Format+import Foreign.Ptr+++main :: IO ()+main = do+    let port = 6333+    putStrLn $ "listening on port "++show port+    ls <- listenOn $ PortNumber port+    forever $ do+        (h, _, _) <- accept ls+        forkIO $ handleToFd h >>= \fd -> do+            iter <- parse defaultParserOptions (session fd)+            result <- enumFd fd iter >>= run+            print result+          `finally`+            closeFd fd++fdPutStrBS :: Fd -> B.ByteString -> IO ()+fdPutStrBS fd bs = B.unsafeUseAsCStringLen bs $ \(buf, len) ->+        writeFully (castPtr buf) (fromIntegral len)+  where+    writeFully _ len | len == 0 = return ()+    writeFully buf len = do+        written <- fdWriteBuf fd buf len+        if written < 0+            then fail "write failed"+            else writeFully (buf `plusPtr` fromIntegral written) (len - written)++session :: Fd                      -- ^ Socket for writing output to+        -> ListOf (UNode IO Text)  -- ^ Input XML document+        -> XMLT IO ()+session fd inputXML = do+    let outputXML = formatG $ indent 2 $ Element "server" [] (processRoot inputXML)+    execute $ liftIO . fdPutStrBS fd =<< outputXML+    return ()++processRoot :: ListOf (UNode IO Text) -> ListOf (UNode IO Text)+processRoot root = do+    Element _ _ children <- root+    child <- children+    extractElements child+  where+    extractElements :: UNode IO Text -> UNodes IO Text+    extractElements elt | isElement elt = processCommand elt `cons` mzero+    extractElements _                   = mzero++processCommand :: UNode IO Text -> UNode IO Text+processCommand (Element "hello" _ _) = Element "hello-back" [] mzero+processCommand (Element cmd _ _) = Element "unknown" [("command", cmd)] mzero+

@@ -1,6 +1,5 @@ import Text.XML.Expat.Chunked import Text.XML.Expat.Format-import Text.XML.Expat.Tree hiding (parse)  import Control.Monad import Control.Monad.Trans@@ -19,12 +18,14 @@         Left err -> putStrLn $ "failed: "++show err         Right () -> putStrLn "" -dump :: CNode IO Text Text -> HandlerT IO ()+dump :: UNode IO Text -> XMLT 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+    joinM :: List c => c (ItemM c a) -> c a+    joinM = (>>= joinL . liftM return)     forL = flip mapL 

@@ -1,6 +1,5 @@ import Text.XML.Expat.Chunked import Text.XML.Expat.Format-import Text.XML.Expat.Tree hiding (parse)  import Control.Monad import Control.Monad.Trans@@ -19,7 +18,7 @@         Left err -> putStrLn $ "failed: "++show err         Right () -> putStrLn "" -dump :: CNode IO Text Text -> HandlerT IO ()+dump :: UNode IO Text -> XMLT IO () dump doc = do     fail "die!" 

@@ -1,7 +1,6 @@ {-# 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@@ -25,7 +24,7 @@         Left err -> putStrLn $ "failed: "++show err         Right () -> putStrLn "" -dump :: CNode IO Text Text -> HandlerT IO ()+dump :: UNode IO Text -> XMLT IO () dump doc = do     let txt = formatG doc     forIter txt $ liftIO . B.hPutStr stdout

@@ -1,6 +1,5 @@ import Text.XML.Expat.Chunked import Text.XML.Expat.Format-import Text.XML.Expat.Tree hiding (parse)  import Control.Monad import Control.Monad.Trans@@ -19,12 +18,14 @@         Left err -> putStrLn $ "failed: "++show err         Right () -> putStrLn "" -dump :: CNode IO Text Text -> HandlerT IO ()+dump :: UNode IO Text -> XMLT 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+    joinM :: List c => c (ItemM c a) -> c a+    joinM = (>>= joinL . liftM return)     forL = flip mapL