module Descriptive.JSON
(
parse
,object
,key
,keyMaybe
,array
,string
,integer
,double
,bool
,null
,label
,Doc(..)
)
where
import Descriptive
import Descriptive.Internal
import Control.Monad.State.Strict
import Data.Scientific
import Data.Function
import Data.Aeson hiding (Value(Object,Null,Array),object)
import Data.Aeson.Types (Value,parseMaybe)
import qualified Data.Aeson.Types as Aeson
import Data.Bifunctor
import Data.Data
import Data.Monoid
import Data.Text (Text)
import Data.Vector ((!))
import Data.Vector (Vector)
import qualified Data.Vector as V
import Prelude hiding (null)
data Doc a
= Integer !Text
| Double !Text
| Text !Text
| Boolean !Text
| Null !Text
| Object !Text
| Key !Text
| Array !Text
| Label !a
deriving (Eq,Show,Typeable,Data)
object :: Monad m
=> Text
-> Consumer Object (Doc d) m a
-> Consumer Value (Doc d) m a
object desc =
wrap (\d ->
do s <- get
runSubStateT (const mempty)
(const s)
(liftM (Wrap doc) d))
(\_ p ->
do v <- get
case fromJSON v of
Error{} ->
return (Continued (Unit doc))
Success (o :: Object) ->
do s <- get
runSubStateT
(const o)
(const s)
(do r <- p
case r of
Failed e ->
return (Continued (Wrap doc e))
Continued e ->
return (Continued (Wrap doc e))
Succeeded a ->
return (Succeeded a)))
where doc = Object desc
key :: Monad m
=> Text
-> Consumer Value (Doc d) m a
-> Consumer Object (Doc d) m a
key k =
wrap (\d ->
do s <- get
runSubStateT toJSON
(const s)
(liftM (Wrap doc) d))
(\_ p ->
do s <- get
case parseMaybe (const (s .: k))
() of
Nothing ->
return (Continued (Unit doc))
Just (v :: Value) ->
do r <-
runSubStateT (const v)
(const s)
p
return (bimap (Wrap doc) id r))
where doc = Key k
keyMaybe :: Monad m
=> Text
-> Consumer Value (Doc d) m a
-> Consumer Object (Doc d) m (Maybe a)
keyMaybe k =
wrap (\d ->
do s <- get
runSubStateT toJSON
(const s)
(liftM (Wrap doc) d))
(\_ p ->
do s <- get
case parseMaybe (const (s .: k))
() of
Nothing ->
return (Succeeded Nothing)
Just (v :: Value) ->
do r <-
runSubStateT (const v)
(const s)
p
return (bimap (Wrap doc) Just r))
where doc = Key k
array :: Monad m
=> Text
-> Consumer Value (Doc d) m a
-> Consumer Value (Doc d) m (Vector a)
array desc =
wrap (\d -> liftM (Wrap doc) d)
(\_ p ->
do s <- get
case fromJSON s of
Error{} ->
return (Continued (Unit doc))
Success (o :: Vector Value) ->
fix (\loop i acc ->
if i < V.length o
then do r <-
runSubStateT (const (o ! i))
(const s)
p
case r of
Failed e ->
return (Continued (Wrap doc e))
Continued e ->
return (Continued (Wrap doc e))
Succeeded a ->
loop (i + 1)
(a : acc)
else return (Succeeded (V.fromList (reverse acc))))
0
[])
where doc = Array desc
string :: Monad m
=> Text
-> Consumer Value (Doc d) m Text
string doc =
consumer (return d)
(do s <- get
case fromJSON s of
Error{} -> return (Continued d)
Success a ->
return (Succeeded a))
where d = Unit (Text doc)
integer :: Monad m
=> Text
-> Consumer Value (Doc d) m Integer
integer doc =
consumer (return d)
(do s <- get
case s of
Number a
| Right i <- floatingOrInteger a ->
return (Succeeded i)
_ -> return (Continued d))
where d = Unit (Integer doc)
double :: Monad m
=> Text
-> Consumer Value (Doc d) m Double
double doc =
consumer (return d)
(do s <- get
case s of
Number a ->
return (Succeeded (toRealFloat a))
_ -> return (Continued d))
where d = Unit (Double doc)
bool :: Monad m
=> Text
-> Consumer Value (Doc d) m Bool
bool doc =
consumer (return d)
(do s <- get
case fromJSON s of
Error{} -> return (Continued d)
Success a ->
return (Succeeded a))
where d = Unit (Boolean doc)
null :: Monad m
=> Text
-> Consumer Value (Doc d) m ()
null doc =
consumer (return d)
(do s <- get
case fromJSON s of
Success Aeson.Null ->
return (Succeeded ())
_ -> return (Continued d))
where d = Unit (Null doc)
label :: Monad m
=> d
-> Consumer s (Doc d) m a
-> Consumer s (Doc d) m a
label desc =
wrap (liftM (Wrap doc))
(\_ p ->
do r <- p
case r of
Failed e ->
return (Failed (Wrap doc e))
Continued e ->
return (Continued (Wrap doc e))
k -> return k)
where doc = Label desc
parse :: Monad m
=> d
-> (a -> StateT s m (Maybe b))
-> Consumer s d m a
-> Consumer s d m b
parse d' check =
wrap (liftM wrapper)
(\d p ->
do s <- get
r <- p
case r of
(Failed e) -> return (Failed e)
(Continued e) ->
return (Continued (wrapper e))
(Succeeded a) ->
do r' <- check a
case r' of
Nothing ->
do doc <- withStateT (const s) d
return (Continued (wrapper doc))
Just a' -> return (Succeeded a'))
where wrapper = Wrap d'