{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.JsonSpec.Decode (
StructureFromJSON(..),
HasJsonDecodingSpec(..),
eitherDecode,
) where
import Control.Applicative (Alternative((<|>)))
import Data.Aeson.Types (FromJSON(parseJSON), Value(Null, Object),
Parser, parseEither, withArray, withObject, withScientific, withText)
import Data.JsonSpec.Spec (Field(Field), Rec(Rec), Tag(Tag),
JSONStructure, JStruct, Specification, sym)
import Data.Proxy (Proxy)
import Data.Scientific (Scientific)
import Data.Text (Text)
import Data.Time (UTCTime)
import GHC.TypeLits (KnownSymbol)
import Prelude (Applicative(pure), Either(Left, Right), Eq((==)),
Functor(fmap), Maybe(Just, Nothing), MonadFail(fail), Semigroup((<>)),
Traversable(traverse), ($), (.), (<$>), Bool, Int, String)
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Vector as Vector
class HasJsonDecodingSpec a where
type DecodingSpec a :: Specification
fromJSONStructure :: JSONStructure (DecodingSpec a) -> Parser a
class StructureFromJSON a where
reprParseJSON :: Value -> Parser a
instance StructureFromJSON Text where
reprParseJSON :: Value -> Parser Text
reprParseJSON = String -> (Text -> Parser Text) -> Value -> Parser Text
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"string" Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance StructureFromJSON Scientific where
reprParseJSON :: Value -> Parser Scientific
reprParseJSON = String
-> (Scientific -> Parser Scientific) -> Value -> Parser Scientific
forall a. String -> (Scientific -> Parser a) -> Value -> Parser a
withScientific String
"number" Scientific -> Parser Scientific
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance StructureFromJSON Int where
reprParseJSON :: Value -> Parser Int
reprParseJSON = Value -> Parser Int
forall a. FromJSON a => Value -> Parser a
parseJSON
instance StructureFromJSON () where
reprParseJSON :: Value -> Parser ()
reprParseJSON =
String -> (Object -> Parser ()) -> Value -> Parser ()
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"empty object" ((Object -> Parser ()) -> Value -> Parser ())
-> (Object -> Parser ()) -> Value -> Parser ()
forall a b. (a -> b) -> a -> b
$ \Object
_ -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
instance StructureFromJSON Bool where
reprParseJSON :: Value -> Parser Bool
reprParseJSON = Value -> Parser Bool
forall a. FromJSON a => Value -> Parser a
parseJSON
instance (KnownSymbol key, StructureFromJSON val, StructureFromJSON more) => StructureFromJSON (Field key val, more) where
reprParseJSON :: Value -> Parser (Field key val, more)
reprParseJSON =
String
-> (Object -> Parser (Field key val, more))
-> Value
-> Parser (Field key val, more)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"object" ((Object -> Parser (Field key val, more))
-> Value -> Parser (Field key val, more))
-> (Object -> Parser (Field key val, more))
-> Value
-> Parser (Field key val, more)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
more
more <- Value -> Parser more
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON (Object -> Value
Object Object
o)
case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @key) Object
o of
Maybe Value
Nothing -> String -> Parser (Field key val, more)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Field key val, more))
-> String -> Parser (Field key val, more)
forall a b. (a -> b) -> a -> b
$ String
"could not find key: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @key
Just Value
rawVal -> do
val
val <- Value -> Parser val
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON Value
rawVal
(Field key val, more) -> Parser (Field key val, more)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (val -> Field key val
forall (key :: Symbol) t. t -> Field key t
Field val
val, more
more)
instance (KnownSymbol key, StructureFromJSON val, StructureFromJSON more) => StructureFromJSON (Maybe (Field key val), more) where
reprParseJSON :: Value -> Parser (Maybe (Field key val), more)
reprParseJSON =
String
-> (Object -> Parser (Maybe (Field key val), more))
-> Value
-> Parser (Maybe (Field key val), more)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"object" ((Object -> Parser (Maybe (Field key val), more))
-> Value -> Parser (Maybe (Field key val), more))
-> (Object -> Parser (Maybe (Field key val), more))
-> Value
-> Parser (Maybe (Field key val), more)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
more
more <- Value -> Parser more
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON (Object -> Value
Object Object
o)
case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @key) Object
o of
Maybe Value
Nothing ->
(Maybe (Field key val), more)
-> Parser (Maybe (Field key val), more)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Field key val)
forall a. Maybe a
Nothing, more
more)
Just Value
rawVal -> do
val
val <- Value -> Parser val
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON Value
rawVal
(Maybe (Field key val), more)
-> Parser (Maybe (Field key val), more)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field key val -> Maybe (Field key val)
forall a. a -> Maybe a
Just (val -> Field key val
forall (key :: Symbol) t. t -> Field key t
Field val
val), more
more)
instance (StructureFromJSON left, StructureFromJSON right) => StructureFromJSON (Either left right) where
reprParseJSON :: Value -> Parser (Either left right)
reprParseJSON Value
v =
(left -> Either left right
forall a b. a -> Either a b
Left (left -> Either left right)
-> Parser left -> Parser (Either left right)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser left
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON Value
v)
Parser (Either left right)
-> Parser (Either left right) -> Parser (Either left right)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (right -> Either left right
forall a b. b -> Either a b
Right (right -> Either left right)
-> Parser right -> Parser (Either left right)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser right
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON Value
v)
instance (KnownSymbol const) => StructureFromJSON (Tag const) where
reprParseJSON :: Value -> Parser (Tag const)
reprParseJSON =
String
-> (Text -> Parser (Tag const)) -> Value -> Parser (Tag const)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"constant" ((Text -> Parser (Tag const)) -> Value -> Parser (Tag const))
-> (Text -> Parser (Tag const)) -> Value -> Parser (Tag const)
forall a b. (a -> b) -> a -> b
$ \Text
c ->
if Text
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @const then Tag const -> Parser (Tag const)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tag const
forall (a :: Symbol). Tag a
Tag
else String -> Parser (Tag const)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected constant value"
instance (StructureFromJSON a) => StructureFromJSON [a] where
reprParseJSON :: Value -> Parser [a]
reprParseJSON =
String -> (Array -> Parser [a]) -> Value -> Parser [a]
forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray
String
"list"
((Vector a -> [a]) -> Parser (Vector a) -> Parser [a]
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector a -> [a]
forall a. Vector a -> [a]
Vector.toList (Parser (Vector a) -> Parser [a])
-> (Array -> Parser (Vector a)) -> Array -> Parser [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser a) -> Array -> Parser (Vector a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Vector a -> f (Vector b)
traverse Value -> Parser a
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON)
instance StructureFromJSON UTCTime where
reprParseJSON :: Value -> Parser UTCTime
reprParseJSON = Value -> Parser UTCTime
forall a. FromJSON a => Value -> Parser a
parseJSON
instance (StructureFromJSON a) => StructureFromJSON (Maybe a) where
reprParseJSON :: Value -> Parser (Maybe a)
reprParseJSON Value
val = do
case Value
val of
Value
Null -> Maybe a -> Parser (Maybe a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
Value
_ -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser a -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON Value
val
instance
(StructureFromJSON (JStruct ('(name, Rec env name spec) : env) spec))
=>
StructureFromJSON (Rec env name spec)
where
reprParseJSON :: Value -> Parser (Rec env name spec)
reprParseJSON Value
val =
JStruct ('(name, Rec env name spec) : env) spec
-> Rec env name spec
forall (env :: [(Symbol, *)]) (name :: Symbol)
(spec :: Specification).
JStruct ('(name, Rec env name spec) : env) spec
-> Rec env name spec
Rec (JStruct ('(name, Rec env name spec) : env) spec
-> Rec env name spec)
-> Parser (JStruct ('(name, Rec env name spec) : env) spec)
-> Parser (Rec env name spec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (JStruct ('(name, Rec env name spec) : env) spec)
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON Value
val
eitherDecode
:: forall spec.
(StructureFromJSON (JSONStructure spec))
=> Proxy (spec :: Specification)
-> Value
-> Either String (JSONStructure spec)
eitherDecode :: forall (spec :: Specification).
StructureFromJSON (JSONStructure spec) =>
Proxy spec -> Value -> Either String (JSONStructure spec)
eitherDecode Proxy spec
_spec =
(Value -> Parser (JStruct '[] spec))
-> Value -> Either String (JStruct '[] spec)
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser (JStruct '[] spec)
forall a. StructureFromJSON a => Value -> Parser a
reprParseJSON