module Data.Json.Parser
(
parseJsonBs, parseJsonBsl, parseJsonT
, JsonReadable(..)
, runParseSpec, ObjSpec(..), ParseSpec(..), KeyedConstr, (.->), (<||>)
, ConstrTagger, ResultType
, TypedKey, reqKey, optKey, typedKeyKey
, readObject, Parser, WrappedValue(..), getValueByKey, getOptValueByKey
)
where
import Control.Applicative
import Control.Monad
import Data.Attoparsec.ByteString.Char8
import Data.HVect
import Data.Int
import Data.Maybe
import Data.Scientific hiding (scientific)
import Data.String
import Data.Typeable
import Data.Word
import Prelude hiding (uncurry, take)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vector as V
parseJsonBs :: JsonReadable t => BS.ByteString -> Either String t
parseJsonBs = parseOnly (readJson <* skipSpace <* endOfInput)
parseJsonBsl :: JsonReadable t => BSL.ByteString -> Either String t
parseJsonBsl = parseJsonBs . BSL.toStrict
parseJsonT :: JsonReadable t => T.Text -> Either String t
parseJsonT = parseJsonBs . T.encodeUtf8
class JsonReadable t where
readJson :: Parser t
instance JsonReadable t => JsonReadable [t] where
readJson = readJList readJson
instance JsonReadable t => JsonReadable (V.Vector t) where
readJson = liftM V.fromList readJson
readJList :: Parser t -> Parser [t]
readJList parseEl =
do skipSpace
char '['
vals <- parseEl `sepBy'` (skipSpace >> char ',')
skipSpace
char ']'
return vals
readTuple :: JsonReadable t => Parser (t, t)
readTuple =
do xs <- readJson
case xs of
(a : b : _) -> return (a, b)
_ -> fail "Not a tuple!"
instance JsonReadable t => JsonReadable (t, t) where
readJson = readTuple
instance JsonReadable Bool where
readJson = readBool
readBool :: Parser Bool
readBool =
do skipSpace
True <$ string "true" <|> False <$ string "false"
instance JsonReadable Scientific where
readJson = skipSpace >> scientific
instance JsonReadable Double where
readJson = readDouble
readDouble :: Parser Double
readDouble = liftM toRealFloat readJson
instance JsonReadable Int where
readJson = readBoundedInteger
instance JsonReadable Int8 where
readJson = readBoundedInteger
instance JsonReadable Int16 where
readJson = readBoundedInteger
instance JsonReadable Int32 where
readJson = readBoundedInteger
instance JsonReadable Int64 where
readJson = readBoundedInteger
instance JsonReadable Word where
readJson = readBoundedInteger
instance JsonReadable Word8 where
readJson = readBoundedInteger
instance JsonReadable Word16 where
readJson = readBoundedInteger
instance JsonReadable Word32 where
readJson = readBoundedInteger
instance JsonReadable Word64 where
readJson = readBoundedInteger
readBoundedInteger :: (Integral i, Bounded i) => Parser i
readBoundedInteger =
do mRes <- liftM toBoundedInteger readJson
case mRes of
Nothing -> fail "input is not a bounded integer"
Just val -> return val
instance JsonReadable T.Text where
readJson = readText
readText :: Parser T.Text
readText =
do skipSpace
char '"'
txt <-
scan False $ \s c ->
if s
then Just False
else if c == '"'
then Nothing
else Just (c == '\\')
char '"'
case T.decodeUtf8' txt of
Right r -> return r
Left msg -> fail $ show msg
instance JsonReadable t => JsonReadable (Maybe t) where
readJson = readMaybe
readNull :: Parser ()
readNull = () <$ string "null"
readMaybe :: JsonReadable t => Parser (Maybe t)
readMaybe =
do skipSpace
Nothing <$ readNull <|> Just <$> readJson
instance (JsonReadable a, JsonReadable b) => JsonReadable (Either a b) where
readJson = readEither
readEither :: (JsonReadable a, JsonReadable b) => Parser (Either a b)
readEither =
Left <$> readJson <|> Right <$> readJson
data WrappedValue
= forall t. (Typeable t, JsonReadable t) => WrappedValue !t
readAnyJsonVal :: Parser ()
readAnyJsonVal =
() <$ readObject (const Nothing)
<|> () <$ readBool
<|> () <$ readText
<|> () <$ readNull
<|> () <$ (skipSpace >> scientific)
<|> () <$ readJList readAnyJsonVal
instance JsonReadable a => JsonReadable (HVect '[a]) where
readJson = liftM singleton readJson
readObject :: (T.Text -> Maybe (Parser a)) -> Parser (HM.HashMap T.Text a)
readObject getKeyParser =
do skipSpace
char '{'
vals <- kvLoop
skipSpace
char '}'
skipSpace
return $! vals
where
kvLoop =
do skipSpace
val <- parseKv
skipSpace
ch <- peekChar'
hm <-
if ch == ','
then do char ','
kvLoop
else return HM.empty
return $
case val of
Just (k, v) -> HM.insert k v hm
Nothing -> hm
parseKv =
do k <- readText
skipSpace
char ':'
case getKeyParser k of
Nothing ->
do readAnyJsonVal
return Nothing
Just parser -> Just <$> ((,) <$> pure k <*> parser)
getValueByKey :: (Monad m, Typeable t) => T.Text -> HM.HashMap T.Text WrappedValue -> m t
getValueByKey key hm =
do optVal <- getOptValueByKey key hm
case optVal of
Nothing -> fail ("Key " ++ show key ++ " not present")
Just val -> return val
getOptValueByKey :: (Monad m, Typeable t) => T.Text -> HM.HashMap T.Text WrappedValue -> m (Maybe t)
getOptValueByKey key hm =
case HM.lookup key hm of
Just (WrappedValue x) ->
case cast x of
Just val -> return (Just val)
Nothing -> fail "Invalid wrapped type"
Nothing -> return Nothing
type KeyReader t =
Monad m => T.Text -> HM.HashMap T.Text WrappedValue -> m t
data TypedKey t =
TypedKey !(KeyReader t) !T.Text
typedKeyKey :: TypedKey t -> T.Text
typedKeyKey (TypedKey _ t) = t
reqKey :: Typeable t => T.Text -> TypedKey t
reqKey = TypedKey getValueByKey
optKey :: Typeable t => T.Text -> TypedKey (Maybe t)
optKey =
TypedKey optGetter
where
optGetter k hm =
do mOpt <- getOptValueByKey k hm
return $ join mOpt
instance Typeable t => IsString (TypedKey (Maybe t)) where
fromString = optKey . T.pack
instance Typeable t => IsString (TypedKey t) where
fromString = reqKey . T.pack
data KeyedConstr k
= KeyedConstr
{ kc_key :: !T.Text
, kc_parser :: !(Parser k)
}
class ConstrTagger r where
type ResultType r :: *
(.->) :: T.Text -> Parser (ResultType r) -> r
instance ConstrTagger (KeyedConstr k) where
type ResultType (KeyedConstr k) = k
key .-> parser = KeyedConstr key parser
instance ConstrTagger (ParseSpec k) where
type ResultType (ParseSpec k) = k
key .-> parser = FirstConstr (KeyedConstr key parser)
data ParseSpec k where
(:$:) :: HVectElim ts k -> ObjSpec ts -> ParseSpec k
FirstConstr :: KeyedConstr k -> ParseSpec k
(:|:) :: KeyedConstr k -> ParseSpec k -> ParseSpec k
infixr 4 :$:
infixr 3 <||>
(<||>) :: KeyedConstr k -> ParseSpec k -> ParseSpec k
(<||>) = (:|:)
runParseSpec :: ParseSpec k -> Parser k
runParseSpec x =
case x of
constr :$: spec ->
runSpec constr spec
FirstConstr (KeyedConstr key parser) ->
let keyGetter reqKey =
if reqKey == key
then Just parser
else Nothing
in do hm <- readObject keyGetter
case HM.lookup key hm of
Nothing -> fail ("Missing key " ++ show key)
Just x -> return x
constr :|: next ->
runParseSpec (FirstConstr constr) <|> runParseSpec next
data ObjSpec (ts :: [*]) where
ObjSpecNil :: ObjSpec '[]
(:&&:) :: (JsonReadable t, Typeable t) => !(TypedKey t) -> !(ObjSpec ts) -> ObjSpec (t ': ts)
infixr 5 :&&:
type CompiledSpec m ts =
(HM.HashMap T.Text WrappedValue -> m (HVect ts), T.Text -> Maybe (Parser WrappedValue))
compileSpec :: Monad m => ObjSpec ts -> CompiledSpec m ts
compileSpec ObjSpecNil = (const (return HNil), const Nothing)
compileSpec ((TypedKey keyReader key :: TypedKey t) :&&: xs) =
let (nextHmFun, nextParserFun) = compileSpec xs
in ( \hm ->
do el <- keyReader key hm
xs <- nextHmFun hm
return (el :&: xs)
, \lookupKey ->
if lookupKey == key
then Just $! liftM WrappedValue (readJson :: Parser t)
else nextParserFun lookupKey
)
runSpec :: HVectElim ts x -> ObjSpec ts -> Parser x
runSpec mkVal spec =
do let (mkTyVect, kv) = compileSpec spec
!hm <- readObject kv
!vect <- mkTyVect hm
return $! uncurry mkVal vect