hexpat-iteratee (empty) → 0.1

raw patch · 5 files changed

+349/−0 lines, 5 filesdep +Listdep +basedep +bytestringsetup-changed

Dependencies added: List, base, bytestring, containers, extensible-exceptions, hexpat, iteratee, mtl, parallel

Files

LICENSE +23/−0
Setup.lhs +4/−0
Text/XML/Expat/Chunked.hs +185/−0
Text/XML/Expat/Chunked/Iterator.hs +101/−0
hexpat-iteratee.cabal +36/−0

+ LICENSE view

@@ -0,0 +1,23 @@+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:+* Redistributions of source code must retain the above copyright notice,+  this list of conditions and the following disclaimer.+* Redistributions in binary form must reproduce the above copyright+  notice, this list of conditions and the following disclaimer in the+  documentation and/or other materials provided with the distribution.+* Neither the name of the author nor the names of contributors may be+  used to endorse or promote products derived from this software without+  specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.lhs view

@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain

+ Text/XML/Expat/Chunked.hs view

@@ -0,0 +1,185 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Text.XML.Expat.Chunked where++import Text.XML.Expat.Chunked.Iterator+import qualified Text.XML.Expat.IO as IO+import Text.XML.Expat.SAX+import Text.XML.Expat.Tree++import Control.Monad+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.WrappedByteString+import Data.List.Class+import Data.Sequence (Seq, (|>), index)+import qualified Data.Sequence as Seq+import Data.Word+++------ Queue ------------------------------------------------------------------++newtype Queue a = Queue (Seq (Maybe a))++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)++data QueueValue a+    = Value 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]++emptyStack :: Stack a+emptyStack = Stack []++stackTop :: Stack a -> a+stackTop (Stack s) = head s++stackPop :: Stack a -> Stack a+stackPop (Stack s) = Stack (tail s)++stackPush :: a -> Stack a -> Stack a+stackPush it (Stack s) = Stack (it:s)+++------ Handler ----------------------------------------------------------------++data Result m a = Yield (HandlerT m a) | Result a++data HandlerT m a = HandlerT {+        runHandlerT :: m (Result m a)+    }++instance Monad m => Functor (HandlerT m) where+    fmap = liftM++instance Monad m => Monad (HandlerT m) where+    return a = HandlerT $ return $ Result a+    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++instance MonadTrans HandlerT where+    lift m = HandlerT $ do+        r <- m+        return $ Result r++instance MonadIO m => MonadIO (HandlerT m) where+    liftIO m = HandlerT $ do+        r <- liftIO m+        return $ Result r++yield :: Monad m => HandlerT m ()+yield = HandlerT $ return $ Yield (HandlerT $ return $ Result ())++-------------------------------------------------------------------------------++type CNode m tag text = NodeG (Iterator (HandlerT m)) tag text++parse :: forall m a tag text . (+             MonadIO m,+             GenericXMLString tag,+             GenericXMLString text+         ) =>+         ParserOptions tag text+      -> (Maybe (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++    liftIO $ IO.setStartElementHandler parser $ \cName cAttrs -> do+        name <- mkText cName+        attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do+            attrName <- mkText cAttrName+            attrValue <- mkText 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`)+        return True+    liftIO $ IO.setEndElementHandler parser $ \_ -> do+        --name <- mkText cName+        --loc <- getParseLocation parser+        stack <- readIORef stackRef+        modifyIORef (stackTop stack) queueEnd+        writeIORef stackRef (stackPop stack)+        return True+    liftIO $ IO.setCharacterDataHandler parser $ \cText -> do+        txt <- gxFromCStringLen cText+        --loc <- getParseLocation parser+        stack <- readIORef stackRef+        modifyIORef (stackTop stack) (Text txt `queuePush`)+        return True++    let nextIter :: HandlerT m a+                 -> IterateeG WrappedByteString Word8 m (Either ErrMsg a)+        nextIter c = IterateeG $ \str -> do+            case str of+                EOF (Just err) -> return $ Done (Left err) str+                _ -> do+                    mErr <- case str of+                        Chunk (WrapBS blk) -> liftIO $ IO.parseChunk parser blk False+                        EOF _              -> liftIO $ IO.parseChunk parser B.empty True++                    res <- runHandlerT c++                    return $ case res of+                        Yield c' -> do+                            case (str, mErr) of+                                (Chunk _, Just err) -> Cont (nextIter c') (Just $ Err $ show err)+                                (Chunk _, Nothing)  -> Cont (nextIter c') 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++    let process = do+            elt <- iter rootRef 0+            case elt of+                Nil         -> code Nothing+                Cons node _ -> code (Just 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')

+ Text/XML/Expat/Chunked/Iterator.hs view

@@ -0,0 +1,101 @@+{-# 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++

+ hexpat-iteratee.cabal view

@@ -0,0 +1,36 @@+Cabal-Version: >= 1.6+Name: hexpat-iteratee+Version: 0.1+Synopsis: chunked XML parsing using iteratees+Description:+  Provides chunked XML parsing using iteratees+Category: XML+License: BSD3+License-File: LICENSE+Author:+  Stephen Blackheath (blackh)+Maintainer: http://blacksapphire.com/antispam/+Copyright:+  (c) 2010 Stephen Blackheath <http://blacksapphire.com/antispam/>+Homepage: http://haskell.org/haskellwiki/Hexpat/+Build-Type: Simple+Stability: prototype+source-repository head+    type:     darcs+    location: http://code.haskell.org/hexpat-iteratee/++Library+  Build-Depends:+    base >= 3 && < 5,+    bytestring,+    mtl,+    parallel,+    containers,+    extensible-exceptions >= 0.1 && < 0.2,+    iteratee >= 0.3,+    hexpat >= 0.13,+    List >= 0.2+  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