{-# LANGUAGE OverloadedStrings, RankNTypes #-} module Data.JSON.ToGo.Parser where import Prelude hiding (sequence) import Data.Aeson.Parser (jstring, value) import Data.Aeson.Types (Value) import Data.Attoparsec.ByteString.Char8 (skipSpace, char, string, scientific, parse) 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 . 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