hexpat-iteratee 0.4 → 0.5

raw patch · 7 files changed

+108/−51 lines, 7 filesdep ~hexpatdep ~iterateePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hexpat, iteratee

API changes (from Hackage documentation)

Files

• Text/XML/Expat/Chunked.hs +45/−21
• hexpat-iteratee.cabal +3/−3
• test/client-server/server.hs +35/−12
• test/test1.hs +6/−7
• test/test2.hs +5/−2
• test/test3.hs +7/−3
• test/test4.hs +7/−3

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, Rank2Types #-} module Text.XML.Expat.Chunked (   -- * Tree structure   Node,@@ -20,11 +20,11 @@   module Text.XML.Expat.Internal.Namespaced,    -- * Parse to tree-  ParserOptions(..),-  defaultParserOptions,+  ParseOptions(..),+  defaultParseOptions,   Encoding(..),   Text.XML.Expat.Chunked.parse,-  XMLT(..),+  XMLT,   XMLParseError(..),   XMLParseLocation(..)   ) where@@ -55,17 +55,29 @@ -- 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+--+-- The /s/ parameter is a dummy type used to prevent nodes escaping from the+-- handler.  See 's' for more explanation.+type Node s m tag text = Tree.NodeG (ListT (XMLT s 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+--+-- The /s/ parameter is a dummy type used to prevent nodes escaping from the+-- handler.  See 's' for more explanation.+type UNode s m text = Node s 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+--+-- The /s/ parameter is a dummy type used to prevent nodes escaping from the+-- handler.  See 's' for more explanation.+type QNode s m a text = Node s 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+--+-- The /s/ parameter is a dummy type used to prevent nodes escaping from the+-- handler.  See 's' for more explanation.+type NNode s m text a = Node s a (NName text) text  ------ Queue ------------------------------------------------------------------ @@ -102,18 +114,18 @@  ------ Handler ---------------------------------------------------------------- -data Result m a = Yield (XMLT m a) | Result a | HandlerErr String+data Result s m a = Yield (XMLT s m a) | Result a | HandlerErr String  -- | 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)+data XMLT s m a = XMLT {+        runXMLT :: m (Result s m a)     } -instance Monad m => Functor (XMLT m) where+instance Monad m => Functor (XMLT s m) where     fmap = liftM -instance Monad m => Monad (XMLT m) where+instance Monad m => Monad (XMLT s m) where     return a = XMLT $ return $ Result a     f >>= g = XMLT $ do         res1 <- runXMLT f@@ -123,17 +135,17 @@             HandlerErr err -> return $ HandlerErr err      fail err = XMLT $ return $ HandlerErr err -instance MonadTrans XMLT where+instance MonadTrans (XMLT s) where     lift m = XMLT $ do         r <- m         return $ Result r -instance MonadIO m => MonadIO (XMLT m) where+instance MonadIO m => MonadIO (XMLT s m) where     liftIO m = XMLT $ do         r <- liftIO m         return $ Result r -yield :: Monad m => XMLT m ()+yield :: Monad m => XMLT s m () yield = XMLT $ return $ Yield (XMLT $ return $ Result ())  -------------------------------------------------------------------------------@@ -144,16 +156,23 @@ -- be suspended, and continued when it's available. -- -- This implementation does /not/ use Haskell's lazy I/O.+--+-- The /s/ type argument is a dummy type, which you should just leave polymorphic+-- by typing /s/ when using the type.  The \"forall s .\" in the type signature+-- prevents any parsed nodes escaping from the handler, because they may refer+-- to parts of the tree that haven't been parsed yet, and this parsing can't+-- take happen outside the handler.  If you need to extract nodes from your+-- handler, use a function like 'fromNodeContainer' to convert the container type. parse :: forall m a tag text . (              MonadIO m,              GenericXMLString tag,              GenericXMLString text          ) =>-         ParserOptions tag text-      -> (ListT (XMLT m) (Node m tag text) -> XMLT m a)+         ParseOptions tag text+      -> (forall s . ListT (XMLT s m) (Node s m tag text) -> XMLT s m a)   -- ^ Handler for parsed tree       -> m (IterateeG WrappedByteString Word8 m (Either ErrMsg a)) parse opts handler = do-    let enc = parserEncoding opts+    let enc = defaultEncoding opts      parser <- liftIO $ IO.newParser enc @@ -170,6 +189,11 @@         stack <- readIORef stackRef         (hd, tl) <- newQueue         push (head stack) $ Tree.Element name attrs (ListT $ iter hd)+        case stack of   -- If this is the first startElement of the document,+                        -- then end the root queue now.  XML documents only have+                        -- one root tag.+            [_] -> pushEnd rootTl+            _   -> return ()         writeIORef stackRef (tl:stack)         return True     liftIO $ IO.setEndElementHandler parser $ \_ _ -> do@@ -186,7 +210,7 @@         push (head stack) $ Tree.Text txt         return True -    let nextIter :: XMLT m a+    let nextIter :: XMLT s m a                  -> IterateeG WrappedByteString Word8 m (Either ErrMsg a)         nextIter handler = IterateeG $ \str -> do             case str of@@ -220,7 +244,7 @@         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 m tag text) -> XMLT m (ListItem (ListT (XMLT m)) (Node m tag text))+    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

@@ -1,6 +1,6 @@ Cabal-Version: >= 1.6 Name: hexpat-iteratee-Version: 0.4+Version: 0.5 Synopsis: Chunked XML parsing using iteratees Description:   This package provides chunked XML parsing using iteratees.  It is especially suited@@ -50,8 +50,8 @@     parallel,     containers,     extensible-exceptions >= 0.1 && < 0.2,-    iteratee >= 0.3,-    hexpat >= 0.16,+    iteratee == 0.3.*,+    hexpat >= 0.17,     List >= 0.4   Exposed-Modules:     Text.XML.Expat.Chunked

@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+import Control.Applicative import Control.Concurrent import Control.Exception import Control.Monad@@ -9,7 +10,8 @@ import Data.Iteratee import Data.Iteratee.IO.Fd import Data.Iteratee.WrappedByteString-import Data.List.Class+import Data.List.Class as List+import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import Network@@ -17,6 +19,7 @@ import System.Posix.IO (handleToFd, fdWriteBuf, closeFd) import System.Posix.Types (Fd) import Text.XML.Expat.Chunked+import qualified Text.XML.Expat.Chunked as Tree import Text.XML.Expat.Format import Foreign.Ptr @@ -29,7 +32,7 @@     forever $ do         (h, _, _) <- accept ls         forkIO $ handleToFd h >>= \fd -> do-            iter <- parse defaultParserOptions (session fd)+            iter <- parse defaultParseOptions (session (fdPutStrBS fd))             result <- enumFd fd iter >>= run             print result           `finally`@@ -46,25 +49,45 @@             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+session :: (B.ByteString -> IO ())  -- ^ Write output data to socket+        -> ListOf (UNode s IO Text)   -- ^ Input XML document+        -> XMLT s IO ()+session writeOut inputXML = do     let outputXML = formatG $ indent 2 $ Element "server" [] (processRoot inputXML)-    execute $ liftIO . fdPutStrBS fd =<< outputXML+    execute $ liftIO . writeOut =<< outputXML     return () -processRoot :: ListOf (UNode IO Text) -> ListOf (UNode IO Text)+processRoot :: ListOf (UNode s IO Text) -> ListOf (UNode s IO Text) processRoot root = do     Element _ _ children <- root     child <- children     extractElements child   where-    extractElements :: UNode IO Text -> UNodes IO Text+    extractElements :: UNode s IO Text -> ListOf (UNode s 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 :: UNode s IO Text -> UNode s IO Text+processCommand elt@(Element "title" _ _) = Element "title" [] $ joinL $ do+    txt <- textContentM elt+    return $ search txt processCommand (Element cmd _ _) = Element "unknown" [("command", cmd)] mzero++list2list :: (List l, List l') => l a -> ItemM l (l' a)+list2list l = fromList `liftM` toList l++search :: forall s . Text -> ListOf (UNode s IO Text)+search key = joinL $ do+    iter <- liftIO $ parse defaultParseOptions $ \root -> do+        let l = do+                elt@(Element _ _ children) <- root+                movie <- List.filter isElement children+                return movie+        fromNodeListContainer l+    eMovies <- liftIO $ fileDriver iter "movies.xml"+    case eMovies of+        Left err -> fail $ "failed to read 'movies.xml': "++show err+        Right movies -> return $ List.filter matches movies+  where+    matches elt = key `T.isInfixOf` fromMaybe "" (getAttribute elt "title") 

@@ -1,3 +1,4 @@+-- Make sure monads-fd package is installed. import Text.XML.Expat.Chunked import Text.XML.Expat.Format @@ -13,19 +14,17 @@  main :: IO () main = do-    eErr <- fileDriver (parse defaultParserOptions dump) "sudoku.xml"+    iter <- parse defaultParseOptions dump+    eErr <- fileDriver iter "sudoku.xml"     case eErr of         Left err -> putStrLn $ "failed: "++show err         Right () -> putStrLn "" -dump :: UNode IO Text -> XMLT IO ()+dump :: ListOf (UNode s IO Text) -> XMLT s IO () dump doc = do-    let txt = formatG doc+    (elt:_) <- toList doc+    let txt = formatG elt     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,3 +1,4 @@+-- Make sure monads-fd package is installed. import Text.XML.Expat.Chunked import Text.XML.Expat.Format @@ -13,12 +14,14 @@  main :: IO () main = do-    eErr <- fileDriver (parse defaultParserOptions dump) "sudoku.xml"+    putStrLn $ "test the handler failing"+    iter <- parse defaultParseOptions dump+    eErr <- fileDriver iter "sudoku.xml"     case eErr of         Left err -> putStrLn $ "failed: "++show err         Right () -> putStrLn "" -dump :: UNode IO Text -> XMLT IO ()+dump :: ListOf (UNode s IO Text) -> XMLT s IO () dump doc = do     fail "die!" 

@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+-- Make sure monads-fd package is installed. import Text.XML.Expat.Chunked import Text.XML.Expat.Format @@ -19,14 +20,17 @@  main :: IO () main = do-    eErr <- myFileDriver (parse defaultParserOptions dump) "sudoku.xml"+    putStrLn $ "Check for lazy behaviour by | indicating where blocks are passed to the parser"+    iter <- parse defaultParseOptions dump+    eErr <- myFileDriver iter "sudoku.xml"     case eErr of         Left err -> putStrLn $ "failed: "++show err         Right () -> putStrLn "" -dump :: UNode IO Text -> XMLT IO ()+dump :: ListOf (UNode s IO Text) -> XMLT s IO () dump doc = do-    let txt = formatG doc+    (elt:_) <- toList doc+    let txt = formatG elt     forIter txt $ liftIO . B.hPutStr stdout     return () 

@@ -1,3 +1,4 @@+-- Make sure monads-fd package is installed. import Text.XML.Expat.Chunked import Text.XML.Expat.Format @@ -13,14 +14,17 @@  main :: IO () main = do-    eErr <- fileDriver (parse defaultParserOptions dump) "broken.xml"+    putStrLn $ "Test handling of parse error"+    iter <- parse defaultParseOptions dump+    eErr <- fileDriver iter "broken.xml"     case eErr of         Left err -> putStrLn $ "failed: "++show err         Right () -> putStrLn "" -dump :: UNode IO Text -> XMLT IO ()+dump :: ListOf (UNode s IO Text) -> XMLT s IO () dump doc = do-    let txt = formatG doc+    (elt:_) <- toList doc+    let txt = formatG elt     execute $ forL txt $ liftIO . B.hPutStr stdout   where     mapL :: List c => (a -> ItemM c b) -> c a -> c b