blob: b15ab34abe03661f4aa347912743c98c1d85b018 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
|
{-# LANGUAGE CPP #-}
module XMLToByteStrings
( xmlToByteStrings
, prettyPrint ) where
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Fix
import Control.Monad (when)
import Data.Conduit
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Binary as CB
import Data.XML.Types as XML (Event)
import qualified Data.ByteString as S (ByteString,append)
import Logging
#ifdef RENDERFLUSH
import Data.Conduit.Blaze (builderToByteStringFlush)
import Text.XML.Stream.Render (def,renderBuilderFlush,renderBytes,rsPretty)
#else
import Text.XML.Stream.Render (def,renderBytes,rsPretty)
#endif
fixMaybeT f = (>> return ()) . runMaybeT . fix $ f
mawait :: Monad m => MaybeT (ConduitM i o m) i
mawait = MaybeT await
xmlToByteStrings ::
( MonadUnsafeIO m
, MonadIO m) =>
Source m [XML.Event] -> Sink S.ByteString m b -> m b
xmlToByteStrings xmlSource snk
#ifdef RENDERFLUSH
= xmlSource
$$ flushList
=$= renderBuilderFlush def
=$= builderToByteStringFlush
=$= discardFlush
=$ snk
#else
= xmlSource $$ renderChunks =$ snk
#endif
#ifdef RENDERFLUSH
flushList :: Monad m => ConduitM [a] (Flush a) m ()
flushList = fixMaybeT $ \loop -> do
xs <- mawait
lift ( CL.sourceList xs $$ CL.mapM_ (yield . Chunk) )
lift ( yield Flush )
loop
discardFlush :: Monad m => ConduitM (Flush a) a m ()
discardFlush = fixMaybeT $ \loop -> do
x <- mawait
let unchunk (Chunk a) = a
ischunk (Chunk _) = True
ischunk _ = False
lift . when (ischunk x) $ yield (unchunk x)
loop
#else
renderChunks :: (MonadUnsafeIO m, MonadIO m) => ConduitM [Event] S.ByteString m ()
renderChunks = fixMaybeT $ \loop -> do
xs <- mawait
lift . when (not . null $ xs) $ ( CL.sourceList xs $= renderBytes def $$ CL.mapM_ yield )
loop
#endif
prettyPrint prefix xs =
liftIO $ do
CL.sourceList xs $= renderBytes (def { rsPretty=True }) =$= CB.lines $$ CL.mapM_ (debugS . (prefix `S.append`))
|
