{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif
module Text.JSON.Canonical.Class (
ToJSON(..)
, FromJSON(..)
, ToObjectKey(..)
, FromObjectKey(..)
, ReportSchemaErrors(..)
, Expected
, Got
, expectedButGotValue
, fromJSObject
, fromJSField
, fromJSOptField
, mkObject
) where
import Text.JSON.Canonical.Types
import Control.Monad (foldM, liftM)
import Data.Maybe (catMaybes)
import Data.Map (Map)
import qualified Data.Map as Map
#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative (Applicative, (<$>), (<*>))
#endif
class ToJSON m a where
toJSON :: a -> m JSValue
class FromJSON m a where
fromJSON :: JSValue -> m a
class ToObjectKey m a where
toObjectKey :: a -> m JSString
class FromObjectKey m a where
fromObjectKey :: JSString -> m (Maybe a)
class (Applicative m, Monad m) => ReportSchemaErrors m where
expected :: Expected -> Maybe Got -> m a
type Expected = String
type Got = String
expectedButGotValue :: ReportSchemaErrors m => Expected -> JSValue -> m a
expectedButGotValue :: forall (m :: * -> *) a.
ReportSchemaErrors m =>
Expected -> JSValue -> m a
expectedButGotValue Expected
descr JSValue
val = forall (m :: * -> *) a.
ReportSchemaErrors m =>
Expected -> Maybe Expected -> m a
expected Expected
descr (forall a. a -> Maybe a
Just (JSValue -> Expected
describeValue JSValue
val))
where
describeValue :: JSValue -> String
describeValue :: JSValue -> Expected
describeValue (JSValue
JSNull ) = Expected
"null"
describeValue (JSBool Bool
_) = Expected
"bool"
describeValue (JSNum Int54
_) = Expected
"num"
describeValue (JSString JSString
_) = Expected
"string"
describeValue (JSArray [JSValue]
_) = Expected
"array"
describeValue (JSObject [(JSString, JSValue)]
_) = Expected
"object"
unknownField :: ReportSchemaErrors m => JSString -> m a
unknownField :: forall (m :: * -> *) a. ReportSchemaErrors m => JSString -> m a
unknownField JSString
field = forall (m :: * -> *) a.
ReportSchemaErrors m =>
Expected -> Maybe Expected -> m a
expected (Expected
"field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Expected
show JSString
field) forall a. Maybe a
Nothing
instance Monad m => ToObjectKey m JSString where
toObjectKey :: JSString -> m JSString
toObjectKey = forall (m :: * -> *) a. Monad m => a -> m a
return
instance Monad m => FromObjectKey m JSString where
fromObjectKey :: JSString -> m (Maybe JSString)
fromObjectKey = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
instance Monad m => ToObjectKey m String where
toObjectKey :: Expected -> m JSString
toObjectKey = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expected -> JSString
toJSString
instance Monad m => FromObjectKey m String where
fromObjectKey :: JSString -> m (Maybe Expected)
fromObjectKey = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> Expected
fromJSString
instance Monad m => ToJSON m JSValue where
toJSON :: JSValue -> m JSValue
toJSON = forall (m :: * -> *) a. Monad m => a -> m a
return
instance Monad m => FromJSON m JSValue where
fromJSON :: JSValue -> m JSValue
fromJSON = forall (m :: * -> *) a. Monad m => a -> m a
return
instance Monad m => ToJSON m JSString where
toJSON :: JSString -> m JSValue
toJSON = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> JSValue
JSString
instance ReportSchemaErrors m => FromJSON m JSString where
fromJSON :: JSValue -> m JSString
fromJSON (JSString JSString
str) = forall (m :: * -> *) a. Monad m => a -> m a
return JSString
str
fromJSON JSValue
val = forall (m :: * -> *) a.
ReportSchemaErrors m =>
Expected -> JSValue -> m a
expectedButGotValue Expected
"string" JSValue
val
instance Monad m => ToJSON m String where
toJSON :: Expected -> m JSValue
toJSON = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> JSValue
JSString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expected -> JSString
toJSString
instance ReportSchemaErrors m => FromJSON m String where
fromJSON :: JSValue -> m Expected
fromJSON (JSString JSString
str) = forall (m :: * -> *) a. Monad m => a -> m a
return (JSString -> Expected
fromJSString JSString
str)
fromJSON JSValue
val = forall (m :: * -> *) a.
ReportSchemaErrors m =>
Expected -> JSValue -> m a
expectedButGotValue Expected
"string" JSValue
val
instance Monad m => ToJSON m Int54 where
toJSON :: Int54 -> m JSValue
toJSON = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int54 -> JSValue
JSNum
instance ReportSchemaErrors m => FromJSON m Int54 where
fromJSON :: JSValue -> m Int54
fromJSON (JSNum Int54
i) = forall (m :: * -> *) a. Monad m => a -> m a
return Int54
i
fromJSON JSValue
val = forall (m :: * -> *) a.
ReportSchemaErrors m =>
Expected -> JSValue -> m a
expectedButGotValue Expected
"int" JSValue
val
instance
#if __GLASGOW_HASKELL__ >= 710
{-# OVERLAPPABLE #-}
#endif
(Monad m, ToJSON m a) => ToJSON m [a] where
toJSON :: [a] -> m JSValue
toJSON = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [JSValue] -> JSValue
JSArray forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM' forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON
instance
#if __GLASGOW_HASKELL__ >= 710
{-# OVERLAPPABLE #-}
#endif
(ReportSchemaErrors m, FromJSON m a) => FromJSON m [a] where
fromJSON :: JSValue -> m [a]
fromJSON (JSArray [JSValue]
as) = forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM' forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON [JSValue]
as
fromJSON JSValue
val = forall (m :: * -> *) a.
ReportSchemaErrors m =>
Expected -> JSValue -> m a
expectedButGotValue Expected
"array" JSValue
val
instance ( Monad m
, ToObjectKey m k
, ToJSON m a
) => ToJSON m (Map k a) where
toJSON :: Map k a -> m JSValue
toJSON = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(JSString, JSValue)] -> JSValue
JSObject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM' (k, a) -> m (JSString, JSValue)
aux forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
where
aux :: (k, a) -> m (JSString, JSValue)
aux :: (k, a) -> m (JSString, JSValue)
aux (k
k, a
a) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. ToObjectKey m a => a -> m JSString
toObjectKey k
k forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON a
a
instance ( ReportSchemaErrors m
, Ord k
, FromObjectKey m k
, FromJSON m a
) => FromJSON m (Map k a) where
fromJSON :: JSValue -> m (Map k a)
fromJSON JSValue
enc = do
[(JSString, JSValue)]
obj <- forall (m :: * -> *).
ReportSchemaErrors m =>
JSValue -> m [(JSString, JSValue)]
fromJSObject JSValue
enc
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM_reverse (JSString, JSValue) -> m (Maybe (k, a))
aux [(JSString, JSValue)]
obj
where
aux :: (JSString, JSValue) -> m (Maybe (k, a))
aux :: (JSString, JSValue) -> m (Maybe (k, a))
aux (JSString
k, JSValue
a) = Maybe k -> a -> Maybe (k, a)
knownKeys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
FromObjectKey m a =>
JSString -> m (Maybe a)
fromObjectKey JSString
k forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
a
knownKeys :: Maybe k -> a -> Maybe (k, a)
knownKeys :: Maybe k -> a -> Maybe (k, a)
knownKeys Maybe k
Nothing a
_ = forall a. Maybe a
Nothing
knownKeys (Just k
k) a
a = forall a. a -> Maybe a
Just (k
k, a
a)
fromJSObject :: ReportSchemaErrors m => JSValue -> m [(JSString, JSValue)]
fromJSObject :: forall (m :: * -> *).
ReportSchemaErrors m =>
JSValue -> m [(JSString, JSValue)]
fromJSObject (JSObject [(JSString, JSValue)]
obj) = forall (m :: * -> *) a. Monad m => a -> m a
return [(JSString, JSValue)]
obj
fromJSObject JSValue
val = forall (m :: * -> *) a.
ReportSchemaErrors m =>
Expected -> JSValue -> m a
expectedButGotValue Expected
"object" JSValue
val
fromJSField :: (ReportSchemaErrors m, FromJSON m a)
=> JSValue -> JSString -> m a
fromJSField :: forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
val JSString
nm = do
[(JSString, JSValue)]
obj <- forall (m :: * -> *).
ReportSchemaErrors m =>
JSValue -> m [(JSString, JSValue)]
fromJSObject JSValue
val
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup JSString
nm [(JSString, JSValue)]
obj of
Just JSValue
fld -> forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
fld
Maybe JSValue
Nothing -> forall (m :: * -> *) a. ReportSchemaErrors m => JSString -> m a
unknownField JSString
nm
fromJSOptField :: (ReportSchemaErrors m, FromJSON m a)
=> JSValue -> JSString -> m (Maybe a)
fromJSOptField :: forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m (Maybe a)
fromJSOptField JSValue
val JSString
nm = do
[(JSString, JSValue)]
obj <- forall (m :: * -> *).
ReportSchemaErrors m =>
JSValue -> m [(JSString, JSValue)]
fromJSObject JSValue
val
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup JSString
nm [(JSString, JSValue)]
obj of
Just JSValue
fld -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
fld
Maybe JSValue
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
mkObject :: forall m. Monad m => [(JSString, m JSValue)] -> m JSValue
mkObject :: forall (m :: * -> *).
Monad m =>
[(JSString, m JSValue)] -> m JSValue
mkObject = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(JSString, JSValue)] -> JSValue
JSObject forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(JSString, m JSValue)] -> m [(JSString, JSValue)]
sequenceFields
where
sequenceFields :: [(JSString, m JSValue)] -> m [(JSString, JSValue)]
sequenceFields :: [(JSString, m JSValue)] -> m [(JSString, JSValue)]
sequenceFields [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
sequenceFields ((JSString
fld,m JSValue
val):[(JSString, m JSValue)]
flds) = do JSValue
val' <- m JSValue
val
[(JSString, JSValue)]
flds' <- [(JSString, m JSValue)] -> m [(JSString, JSValue)]
sequenceFields [(JSString, m JSValue)]
flds
forall (m :: * -> *) a. Monad m => a -> m a
return ((JSString
fld,JSValue
val')forall a. a -> [a] -> [a]
:[(JSString, JSValue)]
flds')
mapM' :: Monad m => (a -> m b) -> [a] -> m [b]
mapM' :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM' a -> m b
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM_reverse a -> m b
f
mapM_reverse :: Monad m => (a -> m b) -> [a] -> m [b]
mapM_reverse :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM_reverse a -> m b
f = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\[b]
xs a
a -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[b]
xs) (a -> m b
f a
a)) []