hexpat-iteratee 0.1 → 0.2

raw patch · 9 files changed

+312/−175 lines, 9 filesdep ~ListPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: List

API changes (from Hackage documentation)

Files

• Text/XML/Expat/Chunked.hs +88/−68
• Text/XML/Expat/Chunked/Iterator.hs +0/−101
• hexpat-iteratee.cabal +25/−6
• test/broken.xml +0/−0
• test/sudoku.xml +27/−0
• test/test1.hs +30/−0
• test/test2.hs +25/−0
• test/test3.hs +87/−0
• test/test4.hs +30/−0

@@ -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')+

@@ -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--

@@ -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 <http://blacksapphire.com/antispam/> 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

@@ -0,0 +1,27 @@+<?xml version="1.0"?>+<gconf>+	<entry name="bg_color" mtime="1258334129" type="string">+		<stringvalue>black</stringvalue>+	</entry>+	<entry name="show_toolbar" mtime="1241553324" type="int" value="1"/>+	<entry name="generate_puzzles_in_background" mtime="1241553324" type="int" value="1"/>+	<entry name="show_impossible_implications" mtime="1241553324" type="int" value="0"/>+	<entry name="highlight" mtime="1241553450" type="int" value="0"/>+	<entry name="bg_custom_color" mtime="1241553323" type="string">+		<stringvalue></stringvalue>+	</entry>+	<entry name="width" mtime="1258334132" type="int" value="700"/>+	<entry name="difficulty" mtime="1241553323" type="float" value="0"/>+	<entry name="bg_black" mtime="1241553323" type="int" value="1"/>+	<entry name="show_tracker" mtime="1241553323" type="bool" value="false"/>+	<entry name="font_zoom" mtime="1241553323" type="int" value="0"/>+	<entry name="auto_save_interval" mtime="1241553323" type="int" value="60"/>+	<entry name="zoom_on_resize" mtime="1241553323" type="int" value="1"/>+	<entry name="always_show_hints" mtime="1241553323" type="int" value="0"/>+	<entry name="minimum_number_of_new_puzzles" mtime="1241553323" type="int" value="90"/>+	<entry name="player" mtime="1241553323" type="string">+		<stringvalue>blackh</stringvalue>+	</entry>+	<entry name="height" mtime="1258334132" type="int" value="675"/>+	<entry name="group_size" mtime="1241553323" type="int" value="9"/>+</gconf>

@@ -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+

@@ -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!"+

@@ -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+

@@ -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+