streamJSONList.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Main where 

import qualified Data.ByteString as B
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Char8 as A
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Maybe
import Pipes
import qualified Pipes.Prelude as P
import qualified Pipes.Parse as P
import qualified Pipes.Attoparsec as P
import qualified Pipes.Aeson.Unchecked as A
import Data.Aeson
import System.IO


example :: Producer Int IO (Producer B.ByteString IO ())
example = streamJSONList $ yield "[ 1, 2, 3 ]"

-- main = defaultMain tests
main :: IO ()
main = do
    r <- runEffect $ example >-> P.print
    System.IO.putStrLn "Leftofvers:"
    runEffect $ r >-> P.print
    return ()

type ParserZ a t m r = forall x. StateT (Producer a m x) (t m) r

-- transform attoparsec parser into pipes-parser parser
parse' :: Monad m => A.Parser r -> P.Parser B.ByteString m (Maybe r)
parse' p = do
    r <- P.parse p
    return $ case r of
        Just (Right r') -> Just r'
        _ -> Nothing

lbracket :: Monad m => P.Parser B.ByteString m (Maybe Char) 
lbracket = parse' $ many A.space *> A.char '[' <* many A.space
        
comma :: Monad m => P.Parser B.ByteString m (Maybe Char) 
comma = parse' $ many A.space *> A.char ',' <* many A.space

rbracket :: Monad m => P.Parser B.ByteString m (Maybe Char)
rbracket = parse' $ many A.space *> A.char ']' <* many A.space

streamJSONList :: (Monad m, FromJSON a, ToJSON a) 
               => Producer B.ByteString m () 
               -> Producer a m (Producer B.ByteString m ())
streamJSONList =  P.execStateT streamingParser
  where
    streamingParser :: (Monad m, FromJSON a, ToJSON a) => ParserZ B.ByteString (Producer a) m ()
    streamingParser = do
            runMaybeT $ MaybeT (hoist lift lbracket) >> lift go >> MaybeT (hoist lift rbracket)
            return ()
    go :: (Monad m, FromJSON a, ToJSON a) => ParserZ B.ByteString (Producer a) m ()
    go = do 
      o <- hoist lift $ A.decode
      case o of
          Just (Right a) -> do
              lift $ yield a
              c <- hoist lift $ comma
              case c of
                  Just _ -> go
                  _ -> return ()
          _ -> return ()