module Data.JSON.ToGo.Parser where
import Prelude hiding (sequence)
import Data.Aeson (FromJSON, parseJSON)
import Data.Aeson.Parser (jstring, value)
import Data.Aeson.Types (Value, parseEither)
import Data.Attoparsec.ByteString.Char8 (skipSpace, char, string, scientific)
import qualified Data.Attoparsec.ByteString.Char8 as Atto
import Data.ByteString (ByteString)
import Data.Monoid (Monoid, mempty, (<>))
import Data.Scientific (Scientific)
import Data.Text (Text)
import Control.Applicative ((<$), (<*), (<|>))
import Control.Monad (join)
import Control.Monad.Trans.Parser (ParserT, liftP)
type ParserM = ParserT ByteString
rP p = liftP . Atto.parse $ skipSpace >> p
parray :: (Monad m, Monoid r) => (Int -> ParserM m r) -> ParserM m r
parray f = rP (char '[') >> go 0 mempty
where
go idx r = do
r' <- f idx
join $ rP $
(go (succ idx) (r <> r') <$ char ',') <|> (return (r <> r') <$ char ']')
pobject :: (Monad m, Monoid r) => (Text -> ParserM m r) -> ParserM m r
pobject f = rP (char '{') >> go mempty
where
go r = do
key <- rP $ jstring <* (skipSpace >> char ':')
r' <- f key
join $ rP $
(go (r <> r') <$ char ',') <|> (return (r <> r') <$ char '}')
parrayL :: Monad m => (Int -> ParserM m r) -> ParserM m [r]
parrayL = parray . fmap (fmap (:[]))
pobjectL :: Monad m => (Text -> ParserM m r) -> ParserM m [r]
pobjectL = pobject . fmap (fmap (:[]))
parray_ :: Monad m => (Int -> ParserM m r) -> ParserM m ()
parray_ = parray . fmap (fmap (const ()))
pobject_ :: Monad m => (Text -> ParserM m r) -> ParserM m ()
pobject_ = pobject . fmap (fmap (const ()))
pnull :: Monad m => ParserM m ()
pnull = rP $ () <$ string "null"
pbool :: Monad m => ParserM m Bool
pbool = rP $ False <$ string "false" <|> True <$ string "true"
pnumber :: Monad m => ParserM m Scientific
pnumber = rP scientific
pstring :: Monad m => ParserM m Text
pstring = rP jstring
pvalue :: Monad m => ParserM m Value
pvalue = rP value
parse :: (Monad m, FromJSON a) => ParserM m a
parse = fmap (parseEither parseJSON) pvalue >>= unwrap
where unwrap (Left s) = fail s
unwrap (Right r) = return r