{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Aeson.Schema.Internal where
import Control.Applicative (Alternative (..))
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif
import Data.Aeson (FromJSON (..), ToJSON (..), Value (..))
import qualified Data.Aeson as Aeson
import Data.Aeson.Types (Parser)
import Data.Dynamic (Dynamic, fromDynamic, toDyn)
import Data.HashMap.Strict (HashMap, (!))
import qualified Data.HashMap.Strict as HashMap
import Data.List (intersperse)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable (Typeable)
import Fcf (type (<=<), type (=<<))
import qualified Fcf
import GHC.Exts (toList)
import GHC.TypeLits (
ErrorMessage (..),
KnownSymbol,
Symbol,
TypeError,
symbolVal,
)
import Data.Aeson.Schema.Key (
IsSchemaKey (..),
SchemaKey,
SchemaKey' (..),
fromSchemaKeyV,
getContext,
showSchemaKey,
toContext,
)
import Data.Aeson.Schema.Type (
FromSchema,
IsSchemaObjectMap,
IsSchemaType (..),
Schema,
Schema' (..),
SchemaType,
SchemaType' (..),
ToSchemaObject,
showSchemaTypeV,
showSchemaV,
toSchemaV,
)
import Data.Aeson.Schema.Utils.All (All (..))
import Data.Aeson.Schema.Utils.Invariant (unreachable)
import Data.Aeson.Schema.Utils.Sum (SumType (..))
newtype Object (schema :: Schema) = UnsafeObject (HashMap Text Dynamic)
instance IsSchema schema => Show (Object schema) where
showsPrec :: Int -> Object schema -> ShowS
showsPrec Int
_ = HasSchemaResult (ToSchemaObject schema) =>
SchemaResult (ToSchemaObject schema) -> ShowS
forall (schema :: SchemaType).
HasSchemaResult schema =>
SchemaResult schema -> ShowS
showValue @(ToSchemaObject schema)
instance IsSchema schema => Eq (Object schema) where
Object schema
a == :: Object schema -> Object schema -> Bool
== Object schema
b = Object schema -> Value
forall a. ToJSON a => a -> Value
toJSON Object schema
a Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Object schema -> Value
forall a. ToJSON a => a -> Value
toJSON Object schema
b
instance IsSchema schema => FromJSON (Object schema) where
parseJSON :: Value -> Parser (Object schema)
parseJSON = [Text] -> Value -> Parser (SchemaResult (ToSchemaObject schema))
forall (schema :: SchemaType).
HasSchemaResult schema =>
[Text] -> Value -> Parser (SchemaResult schema)
parseValue @(ToSchemaObject schema) []
instance IsSchema schema => ToJSON (Object schema) where
toJSON :: Object schema -> Value
toJSON = HasSchemaResult (ToSchemaObject schema) =>
SchemaResult (ToSchemaObject schema) -> Value
forall (schema :: SchemaType).
HasSchemaResult schema =>
SchemaResult schema -> Value
toValue @(ToSchemaObject schema)
toMap :: IsSchema ( 'Schema schema) => Object ( 'Schema schema) -> Aeson.Object
toMap :: Object ('Schema schema) -> Object
toMap = Object ('Schema schema) -> Object
forall (pairs :: SchemaObjectMap' Symbol *).
All HasSchemaResultPair pairs =>
Object ('Schema pairs) -> Object
toValueMap
type IsSchema (schema :: Schema) =
( HasSchemaResult (ToSchemaObject schema)
, All HasSchemaResultPair (FromSchema schema)
, IsSchemaObjectMap (FromSchema schema)
, SchemaResult (ToSchemaObject schema) ~ Object schema
)
showSchema :: forall (schema :: Schema). IsSchema schema => String
showSchema :: String
showSchema = String
"SchemaObject " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaV -> String
showSchemaV SchemaV
schema
where
schema :: SchemaV
schema = Proxy schema -> SchemaV
forall (schema :: Schema).
IsSchemaObjectMap (FromSchema schema) =>
Proxy schema -> SchemaV
toSchemaV (Proxy schema -> SchemaV) -> Proxy schema -> SchemaV
forall a b. (a -> b) -> a -> b
$ Proxy schema
forall k (t :: k). Proxy t
Proxy @schema
showSchemaType :: forall (schemaType :: SchemaType). HasSchemaResult schemaType => String
showSchemaType :: String
showSchemaType = SchemaTypeV -> String
showSchemaTypeV SchemaTypeV
schemaType
where
schemaType :: SchemaTypeV
schemaType = Proxy schemaType -> SchemaTypeV
forall (schemaType :: SchemaType).
IsSchemaType schemaType =>
Proxy schemaType -> SchemaTypeV
toSchemaTypeV (Proxy schemaType -> SchemaTypeV)
-> Proxy schemaType -> SchemaTypeV
forall a b. (a -> b) -> a -> b
$ Proxy schemaType
forall k (t :: k). Proxy t
Proxy @schemaType
type family SchemaResult (schema :: SchemaType) where
SchemaResult ( 'SchemaScalar inner) = inner
SchemaResult ( 'SchemaMaybe inner) = Maybe (SchemaResult inner)
SchemaResult ( 'SchemaTry inner) = Maybe (SchemaResult inner)
SchemaResult ( 'SchemaList inner) = [SchemaResult inner]
SchemaResult ( 'SchemaUnion schemas) = SumType (SchemaResultList schemas)
SchemaResult ( 'SchemaObject inner) = Object ( 'Schema inner)
SchemaResult ( 'SchemaInclude ( 'Right schema)) = SchemaResult (ToSchemaObject schema)
type family SchemaResultList (xs :: [SchemaType]) where
SchemaResultList '[] = '[]
SchemaResultList (x ': xs) = SchemaResult x ': SchemaResultList xs
class IsSchemaType schema => HasSchemaResult (schema :: SchemaType) where
parseValue :: [Text] -> Value -> Parser (SchemaResult schema)
default parseValue :: FromJSON (SchemaResult schema) => [Text] -> Value -> Parser (SchemaResult schema)
parseValue [Text]
path Value
value = Value -> Parser (SchemaResult schema)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
value Parser (SchemaResult schema)
-> Parser (SchemaResult schema) -> Parser (SchemaResult schema)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Text] -> Value -> Parser (SchemaResult schema)
forall (schema :: SchemaType) (m :: * -> *) a.
(MonadFail m, HasSchemaResult schema) =>
[Text] -> Value -> m a
parseFail @schema [Text]
path Value
value
toValue :: SchemaResult schema -> Value
default toValue :: ToJSON (SchemaResult schema) => SchemaResult schema -> Value
toValue = SchemaResult schema -> Value
forall a. ToJSON a => a -> Value
toJSON
showValue :: SchemaResult schema -> ShowS
default showValue :: Show (SchemaResult schema) => SchemaResult schema -> ShowS
showValue = SchemaResult schema -> ShowS
forall a. Show a => a -> ShowS
shows
instance (Show inner, Typeable inner, FromJSON inner, ToJSON inner) => HasSchemaResult ( 'SchemaScalar inner)
instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ( 'SchemaMaybe inner) where
parseValue :: [Text] -> Value -> Parser (SchemaResult ('SchemaMaybe inner))
parseValue [Text]
path = \case
Value
Null -> Maybe (SchemaResult inner) -> Parser (Maybe (SchemaResult inner))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (SchemaResult inner)
forall a. Maybe a
Nothing
Value
value -> (SchemaResult inner -> Maybe (SchemaResult inner)
forall a. a -> Maybe a
Just (SchemaResult inner -> Maybe (SchemaResult inner))
-> Parser (SchemaResult inner)
-> Parser (Maybe (SchemaResult inner))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Value -> Parser (SchemaResult inner)
forall (schema :: SchemaType).
HasSchemaResult schema =>
[Text] -> Value -> Parser (SchemaResult schema)
parseValue @inner [Text]
path Value
value)
instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ( 'SchemaTry inner) where
parseValue :: [Text] -> Value -> Parser (SchemaResult ('SchemaTry inner))
parseValue [Text]
path = Parser (SchemaResult inner) -> Parser (Maybe (SchemaResult inner))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
wrapTry (Parser (SchemaResult inner)
-> Parser (Maybe (SchemaResult inner)))
-> (Value -> Parser (SchemaResult inner))
-> Value
-> Parser (Maybe (SchemaResult inner))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Value -> Parser (SchemaResult inner)
forall (schema :: SchemaType).
HasSchemaResult schema =>
[Text] -> Value -> Parser (SchemaResult schema)
parseValue @inner [Text]
path
where
wrapTry :: f a -> f (Maybe a)
wrapTry f a
parser = (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> f a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
parser) f (Maybe a) -> f (Maybe a) -> f (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a -> f (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ( 'SchemaList inner) where
parseValue :: [Text] -> Value -> Parser (SchemaResult ('SchemaList inner))
parseValue [Text]
path = \case
Array Array
a -> (Value -> Parser (SchemaResult inner))
-> [Value] -> Parser [SchemaResult inner]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Text] -> Value -> Parser (SchemaResult inner)
forall (schema :: SchemaType).
HasSchemaResult schema =>
[Text] -> Value -> Parser (SchemaResult schema)
parseValue @inner [Text]
path) (Array -> [Item Array]
forall l. IsList l => l -> [Item l]
toList Array
a)
Value
value -> [Text] -> Value -> Parser [SchemaResult inner]
forall (schema :: SchemaType) (m :: * -> *) a.
(MonadFail m, HasSchemaResult schema) =>
[Text] -> Value -> m a
parseFail @( 'SchemaList inner) [Text]
path Value
value
instance
( All HasSchemaResult schemas
, All IsSchemaType schemas
, Show (SchemaResult ( 'SchemaUnion schemas))
, FromJSON (SchemaResult ( 'SchemaUnion schemas))
, ToJSON (SchemaResult ( 'SchemaUnion schemas))
, ParseSumType schemas
) =>
HasSchemaResult ( 'SchemaUnion (schemas :: [SchemaType]))
where
parseValue :: [Text] -> Value -> Parser (SchemaResult ('SchemaUnion schemas))
parseValue [Text]
path Value
value = [Text] -> Value -> Parser (SumType (SchemaResultList schemas))
forall (xs :: [SchemaType]).
ParseSumType xs =>
[Text] -> Value -> Parser (SumType (SchemaResultList xs))
parseSumType @schemas [Text]
path Value
value Parser (SumType (SchemaResultList schemas))
-> Parser (SumType (SchemaResultList schemas))
-> Parser (SumType (SchemaResultList schemas))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Text] -> Value -> Parser (SumType (SchemaResultList schemas))
forall (schema :: SchemaType) (m :: * -> *) a.
(MonadFail m, HasSchemaResult schema) =>
[Text] -> Value -> m a
parseFail @( 'SchemaUnion schemas) [Text]
path Value
value
class ParseSumType xs where
parseSumType :: [Text] -> Value -> Parser (SumType (SchemaResultList xs))
instance ParseSumType '[] where
parseSumType :: [Text] -> Value -> Parser (SumType (SchemaResultList '[]))
parseSumType [Text]
_ Value
_ = Parser (SumType (SchemaResultList '[]))
forall (f :: * -> *) a. Alternative f => f a
empty
instance (HasSchemaResult schema, ParseSumType schemas) => ParseSumType (schema ': schemas) where
parseSumType :: [Text]
-> Value -> Parser (SumType (SchemaResultList (schema : schemas)))
parseSumType [Text]
path Value
value = Parser (SumType (SchemaResult schema : SchemaResultList schemas))
parseHere Parser (SumType (SchemaResult schema : SchemaResultList schemas))
-> Parser
(SumType (SchemaResult schema : SchemaResultList schemas))
-> Parser
(SumType (SchemaResult schema : SchemaResultList schemas))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (SumType (SchemaResult schema : SchemaResultList schemas))
parseThere
where
parseHere :: Parser (SumType (SchemaResult schema : SchemaResultList schemas))
parseHere = SchemaResult schema
-> SumType (SchemaResult schema : SchemaResultList schemas)
forall x (x :: [*]). x -> SumType (x : x)
Here (SchemaResult schema
-> SumType (SchemaResult schema : SchemaResultList schemas))
-> Parser (SchemaResult schema)
-> Parser
(SumType (SchemaResult schema : SchemaResultList schemas))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Value -> Parser (SchemaResult schema)
forall (schema :: SchemaType).
HasSchemaResult schema =>
[Text] -> Value -> Parser (SchemaResult schema)
parseValue @schema [Text]
path Value
value
parseThere :: Parser (SumType (SchemaResult schema : SchemaResultList schemas))
parseThere = SumType (SchemaResultList schemas)
-> SumType (SchemaResult schema : SchemaResultList schemas)
forall x (xs :: [*]). SumType xs -> SumType (x : xs)
There (SumType (SchemaResultList schemas)
-> SumType (SchemaResult schema : SchemaResultList schemas))
-> Parser (SumType (SchemaResultList schemas))
-> Parser
(SumType (SchemaResult schema : SchemaResultList schemas))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Value -> Parser (SumType (SchemaResultList schemas))
forall (xs :: [SchemaType]).
ParseSumType xs =>
[Text] -> Value -> Parser (SumType (SchemaResultList xs))
parseSumType @schemas [Text]
path Value
value
instance (All HasSchemaResultPair pairs, IsSchemaObjectMap pairs) => HasSchemaResult ( 'SchemaObject pairs) where
parseValue :: [Text] -> Value -> Parser (SchemaResult ('SchemaObject pairs))
parseValue [Text]
path = \case
Aeson.Object Object
o -> HashMap Text Dynamic -> Object ('Schema pairs)
forall (schema :: Schema). HashMap Text Dynamic -> Object schema
UnsafeObject (HashMap Text Dynamic -> Object ('Schema pairs))
-> ([(Text, Dynamic)] -> HashMap Text Dynamic)
-> [(Text, Dynamic)]
-> Object ('Schema pairs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Dynamic)] -> HashMap Text Dynamic
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Text, Dynamic)] -> Object ('Schema pairs))
-> Parser [(Text, Dynamic)] -> Parser (Object ('Schema pairs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser [(Text, Dynamic)]
parseValueMap Object
o
Value
value -> [Text] -> Value -> Parser (Object ('Schema pairs))
forall (schema :: SchemaType) (m :: * -> *) a.
(MonadFail m, HasSchemaResult schema) =>
[Text] -> Value -> m a
parseFail @( 'SchemaObject pairs) [Text]
path Value
value
where
parseValueMap :: Aeson.Object -> Parser [(Text, Dynamic)]
parseValueMap :: Object -> Parser [(Text, Dynamic)]
parseValueMap Object
o = [Parser (Text, Dynamic)] -> Parser [(Text, Dynamic)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Parser (Text, Dynamic)] -> Parser [(Text, Dynamic)])
-> [Parser (Text, Dynamic)] -> Parser [(Text, Dynamic)]
forall a b. (a -> b) -> a -> b
$ forall a.
All HasSchemaResultPair pairs =>
(forall (x :: (SchemaKey, SchemaType)).
HasSchemaResultPair x =>
Proxy x -> a)
-> [a]
forall k k (f :: k -> Constraint) (xs :: k) a.
All f xs =>
(forall (x :: k). f x => Proxy x -> a) -> [a]
mapAll @HasSchemaResultPair @pairs ((forall (x :: (SchemaKey, SchemaType)).
HasSchemaResultPair x =>
Proxy x -> Parser (Text, Dynamic))
-> [Parser (Text, Dynamic)])
-> (forall (x :: (SchemaKey, SchemaType)).
HasSchemaResultPair x =>
Proxy x -> Parser (Text, Dynamic))
-> [Parser (Text, Dynamic)]
forall a b. (a -> b) -> a -> b
$ \Proxy x
proxy -> Proxy x -> [Text] -> Object -> Parser (Text, Dynamic)
forall (a :: (SchemaKey, SchemaType)).
HasSchemaResultPair a =>
Proxy a -> [Text] -> Object -> Parser (Text, Dynamic)
parseValuePair Proxy x
proxy [Text]
path Object
o
toValue :: SchemaResult ('SchemaObject pairs) -> Value
toValue = Object -> Value
Aeson.Object (Object -> Value)
-> (Object ('Schema pairs) -> Object)
-> Object ('Schema pairs)
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object ('Schema pairs) -> Object
forall (pairs :: SchemaObjectMap' Symbol *).
All HasSchemaResultPair pairs =>
Object ('Schema pairs) -> Object
toValueMap
showValue :: SchemaResult ('SchemaObject pairs) -> ShowS
showValue SchemaResult ('SchemaObject pairs)
o = String -> ShowS
showString String
"{ " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [ShowS] -> ShowS
intercalateShowS String
", " (((String, ShowS) -> ShowS) -> [(String, ShowS)] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (String, ShowS) -> ShowS
forall a. (String, a -> String) -> a -> String
fromPair [(String, ShowS)]
pairs) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" }"
where
fromPair :: (String, a -> String) -> a -> String
fromPair (String
k, a -> String
v) = String -> ShowS
showString String
k ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
": " ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
v
pairs :: [(String, ShowS)]
pairs = forall a.
All HasSchemaResultPair pairs =>
(forall (x :: (SchemaKey, SchemaType)).
HasSchemaResultPair x =>
Proxy x -> a)
-> [a]
forall k k (f :: k -> Constraint) (xs :: k) a.
All f xs =>
(forall (x :: k). f x => Proxy x -> a) -> [a]
mapAll @HasSchemaResultPair @pairs ((forall (x :: (SchemaKey, SchemaType)).
HasSchemaResultPair x =>
Proxy x -> (String, ShowS))
-> [(String, ShowS)])
-> (forall (x :: (SchemaKey, SchemaType)).
HasSchemaResultPair x =>
Proxy x -> (String, ShowS))
-> [(String, ShowS)]
forall a b. (a -> b) -> a -> b
$ \Proxy x
proxy -> Proxy x -> Object ('Schema pairs) -> (String, ShowS)
forall (a :: (SchemaKey, SchemaType)) (schema :: Schema).
HasSchemaResultPair a =>
Proxy a -> Object schema -> (String, ShowS)
showValuePair Proxy x
proxy SchemaResult ('SchemaObject pairs)
Object ('Schema pairs)
o
intercalateShowS :: String -> [ShowS] -> ShowS
intercalateShowS :: String -> [ShowS] -> ShowS
intercalateShowS String
s = [ShowS] -> ShowS
concatShowS ([ShowS] -> ShowS) -> ([ShowS] -> [ShowS]) -> [ShowS] -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse (String -> ShowS
showString String
s)
concatShowS :: [ShowS] -> ShowS
concatShowS :: [ShowS] -> ShowS
concatShowS = (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id
toValueMap :: forall pairs. All HasSchemaResultPair pairs => Object ( 'Schema pairs) -> Aeson.Object
toValueMap :: Object ('Schema pairs) -> Object
toValueMap Object ('Schema pairs)
o = [Object] -> Object
forall k v. (Eq k, Hashable k) => [HashMap k v] -> HashMap k v
HashMap.unions ([Object] -> Object) -> [Object] -> Object
forall a b. (a -> b) -> a -> b
$ (forall (x :: (SchemaKey, SchemaType)).
HasSchemaResultPair x =>
Proxy x -> Object)
-> [Object]
forall k k (f :: k -> Constraint) (xs :: k) a.
All f xs =>
(forall (x :: k). f x => Proxy x -> a) -> [a]
mapAll @HasSchemaResultPair @pairs (\Proxy x
proxy -> Proxy x -> Object ('Schema pairs) -> Object
forall (a :: (SchemaKey, SchemaType)) (schema :: Schema).
HasSchemaResultPair a =>
Proxy a -> Object schema -> Object
toValuePair Proxy x
proxy Object ('Schema pairs)
o)
class HasSchemaResultPair (a :: (SchemaKey, SchemaType)) where
parseValuePair :: Proxy a -> [Text] -> Aeson.Object -> Parser (Text, Dynamic)
toValuePair :: Proxy a -> Object schema -> Aeson.Object
showValuePair :: Proxy a -> Object schema -> (String, ShowS)
instance
( IsSchemaKey key
, HasSchemaResult inner
, Typeable (SchemaResult inner)
) =>
HasSchemaResultPair '(key, inner)
where
parseValuePair :: Proxy '(key, inner) -> [Text] -> Object -> Parser (Text, Dynamic)
parseValuePair Proxy '(key, inner)
_ [Text]
path Object
o = do
SchemaResult inner
inner <- [Text] -> Value -> Parser (SchemaResult inner)
forall (schema :: SchemaType).
HasSchemaResult schema =>
[Text] -> Value -> Parser (SchemaResult schema)
parseValue @inner (Text
key Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
path) (Value -> Parser (SchemaResult inner))
-> Value -> Parser (SchemaResult inner)
forall a b. (a -> b) -> a -> b
$ SchemaKeyV -> Object -> Value
getContext SchemaKeyV
schemaKey Object
o
(Text, Dynamic) -> Parser (Text, Dynamic)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
key, SchemaResult inner -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn SchemaResult inner
inner)
where
schemaKey :: SchemaKeyV
schemaKey = Proxy key -> SchemaKeyV
forall (key :: SchemaKey).
IsSchemaKey key =>
Proxy key -> SchemaKeyV
toSchemaKeyV (Proxy key -> SchemaKeyV) -> Proxy key -> SchemaKeyV
forall a b. (a -> b) -> a -> b
$ Proxy key
forall k (t :: k). Proxy t
Proxy @key
key :: Text
key = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SchemaKeyV -> String
fromSchemaKeyV SchemaKeyV
schemaKey
toValuePair :: Proxy '(key, inner) -> Object schema -> Object
toValuePair Proxy '(key, inner)
_ Object schema
o = SchemaKeyV -> Value -> Object
toContext SchemaKeyV
schemaKey (SchemaResult inner -> Value
forall (schema :: SchemaType).
HasSchemaResult schema =>
SchemaResult schema -> Value
toValue @inner SchemaResult inner
val)
where
schemaKey :: SchemaKeyV
schemaKey = Proxy key -> SchemaKeyV
forall (key :: SchemaKey).
IsSchemaKey key =>
Proxy key -> SchemaKeyV
toSchemaKeyV (Proxy key -> SchemaKeyV) -> Proxy key -> SchemaKeyV
forall a b. (a -> b) -> a -> b
$ Proxy key
forall k (t :: k). Proxy t
Proxy @key
val :: SchemaResult inner
val = Proxy (FromSchemaKey key) -> Object schema -> SchemaResult inner
forall (endSchema :: SchemaType) (key :: Symbol)
(schema :: Schema).
(KnownSymbol key, Typeable (SchemaResult endSchema)) =>
Proxy key -> Object schema -> SchemaResult endSchema
unsafeGetKey @inner (Proxy (FromSchemaKey key)
forall k (t :: k). Proxy t
Proxy @(FromSchemaKey key)) Object schema
o
showValuePair :: Proxy '(key, inner) -> Object schema -> (String, ShowS)
showValuePair Proxy '(key, inner)
_ Object schema
o = (IsSchemaKey key => String
forall (key :: SchemaKey). IsSchemaKey key => String
showSchemaKey @key, SchemaResult inner -> ShowS
forall (schema :: SchemaType).
HasSchemaResult schema =>
SchemaResult schema -> ShowS
showValue @inner SchemaResult inner
val)
where
val :: SchemaResult inner
val = Proxy (FromSchemaKey key) -> Object schema -> SchemaResult inner
forall (endSchema :: SchemaType) (key :: Symbol)
(schema :: Schema).
(KnownSymbol key, Typeable (SchemaResult endSchema)) =>
Proxy key -> Object schema -> SchemaResult endSchema
unsafeGetKey @inner (Proxy (FromSchemaKey key)
forall k (t :: k). Proxy t
Proxy @(FromSchemaKey key)) Object schema
o
instance IsSchema schema => HasSchemaResult ( 'SchemaInclude ( 'Right schema)) where
parseValue :: [Text]
-> Value -> Parser (SchemaResult ('SchemaInclude ('Right schema)))
parseValue = HasSchemaResult (ToSchemaObject schema) =>
[Text] -> Value -> Parser (SchemaResult (ToSchemaObject schema))
forall (schema :: SchemaType).
HasSchemaResult schema =>
[Text] -> Value -> Parser (SchemaResult schema)
parseValue @(ToSchemaObject schema)
toValue :: SchemaResult ('SchemaInclude ('Right schema)) -> Value
toValue = HasSchemaResult (ToSchemaObject schema) =>
SchemaResult (ToSchemaObject schema) -> Value
forall (schema :: SchemaType).
HasSchemaResult schema =>
SchemaResult schema -> Value
toValue @(ToSchemaObject schema)
showValue :: SchemaResult ('SchemaInclude ('Right schema)) -> ShowS
showValue = HasSchemaResult (ToSchemaObject schema) =>
SchemaResult (ToSchemaObject schema) -> ShowS
forall (schema :: SchemaType).
HasSchemaResult schema =>
SchemaResult schema -> ShowS
showValue @(ToSchemaObject schema)
parseFail :: forall (schema :: SchemaType) m a. (MonadFail m, HasSchemaResult schema) => [Text] -> Value -> m a
parseFail :: [Text] -> Value -> m a
parseFail [Text]
path Value
value = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
ellipses Int
200 (Value -> String
forall a. Show a => a -> String
show Value
value)
where
msg :: String
msg =
if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
path
then String
"Could not parse schema " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
schema'
else String
"Could not parse path '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
path' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' with schema " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
schema'
path' :: String
path' = Text -> String
Text.unpack (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
"." ([Text] -> String) -> [Text] -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
path
schema' :: String
schema' = String
"`" String -> ShowS
forall a. [a] -> [a] -> [a]
++ HasSchemaResult schema => String
forall (schemaType :: SchemaType).
HasSchemaResult schemaType =>
String
showSchemaType @schema String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"`"
ellipses :: Int -> ShowS
ellipses Int
n String
s = if String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n then Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
n String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"..." else String
s
data UnSchemaKey :: SchemaKey -> Fcf.Exp Symbol
type instance Fcf.Eval (UnSchemaKey ( 'NormalKey key)) = Fcf.Eval (Fcf.Pure key)
type instance Fcf.Eval (UnSchemaKey ( 'PhantomKey key)) = Fcf.Eval (Fcf.Pure key)
type Lookup a = Fcf.Map Fcf.Snd <=< Fcf.Find (Fcf.TyEq a <=< Fcf.Fst)
type family LookupSchema (key :: Symbol) (schema :: Schema) :: SchemaType where
LookupSchema key ( 'Schema schema) =
Fcf.Eval
( Fcf.FromMaybe
( TypeError
( 'Text "Key '"
':<>: 'Text key
':<>: 'Text "' does not exist in the following schema:"
':$$: 'ShowType schema
)
)
=<< Lookup key
=<< Fcf.Map (Fcf.Bimap UnSchemaKey Fcf.Pure) schema
)
getKey ::
forall (key :: Symbol) (schema :: Schema) (endSchema :: SchemaType) result.
( endSchema ~ LookupSchema key schema
, result ~ SchemaResult endSchema
, KnownSymbol key
, Typeable result
, Typeable endSchema
) =>
Proxy key ->
Object schema ->
result
getKey :: Proxy key -> Object schema -> result
getKey = forall (key :: Symbol) (schema :: Schema).
(KnownSymbol key, Typeable (SchemaResult endSchema)) =>
Proxy key -> Object schema -> SchemaResult endSchema
forall (endSchema :: SchemaType) (key :: Symbol)
(schema :: Schema).
(KnownSymbol key, Typeable (SchemaResult endSchema)) =>
Proxy key -> Object schema -> SchemaResult endSchema
unsafeGetKey @endSchema
unsafeGetKey ::
forall (endSchema :: SchemaType) (key :: Symbol) (schema :: Schema).
(KnownSymbol key, Typeable (SchemaResult endSchema)) =>
Proxy key ->
Object schema ->
SchemaResult endSchema
unsafeGetKey :: Proxy key -> Object schema -> SchemaResult endSchema
unsafeGetKey Proxy key
keyProxy (UnsafeObject HashMap Text Dynamic
object) =
SchemaResult endSchema
-> Maybe (SchemaResult endSchema) -> SchemaResult endSchema
forall a. a -> Maybe a -> a
fromMaybe (String -> SchemaResult endSchema
forall a. String -> a
unreachable (String -> SchemaResult endSchema)
-> String -> SchemaResult endSchema
forall a b. (a -> b) -> a -> b
$ String
"Could not load key: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
key) (Maybe (SchemaResult endSchema) -> SchemaResult endSchema)
-> Maybe (SchemaResult endSchema) -> SchemaResult endSchema
forall a b. (a -> b) -> a -> b
$
Dynamic -> Maybe (SchemaResult endSchema)
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (HashMap Text Dynamic
object HashMap Text Dynamic -> Text -> Dynamic
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! String -> Text
Text.pack String
key)
where
key :: String
key = Proxy key -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy key
keyProxy