{-# 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`))