{-|
Module      :  Data.Aeson.Schema.Internal
Maintainer  :  Brandon Chinn <brandon@leapyear.io>
Stability   :  experimental
Portability :  portable

Internal definitions for declaring JSON schemas.
-}
{-# 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(..))

{- Schema-validated JSON object -}

-- | The object containing JSON data and its schema.
--
-- Has a 'FromJSON' instance, so you can use the usual @Data.Aeson@ decoding functions.
--
-- > obj = decode "{\"a\": 1}" :: Maybe (Object [schema| { a: Int } |])
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)

-- | Convert an 'Object' into a 'HashMap', losing the type information in the schema.
--
-- @since 1.3.0
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-level schema definitions -}

-- | The constraint for most operations involving @Object schema@. If you're writing functions
-- on general Objects, you should use this constraint. e.g.
--
-- > logObject :: (MonadLogger m, IsSchema schema) => Object schema -> m ()
-- > logObject = logInfoN . Text.pack . show
--
-- @since 1.3.0
type IsSchema (schema :: Schema) =
  ( HasSchemaResult (ToSchemaObject schema)
  , All HasSchemaResultPair (FromSchema schema)
  , IsSchemaObjectMap (FromSchema schema)
  , SchemaResult (ToSchemaObject schema) ~ Object schema
  )

-- | Show the given schema.
--
-- Usage:
--
-- > type MySchema = [schema| { a: Int } |]
-- > showSchema @MySchema
--
showSchema :: forall (schema :: Schema). IsSchema schema => String
showSchema :: String
showSchema = String
"SchemaObject " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaV -> String
showSchemaV SchemaV
schema -- TODO: Remove "SchemaObject" prefix? Or rename to "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

{- Conversions from schema types into Haskell types -}

-- | A type family mapping SchemaType to the corresponding Haskell type.
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

-- | A type-class for types that can be parsed from JSON for an associated schema type.
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

  -- Note: Using ShowS here instead of just returning String to avoid quadratic performance when
  -- using (++)
  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

      -- intercalate for ShowS
      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
keyText -> [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)

-- | A helper for creating fail messages when parsing a 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

{- Lookups within SchemaObject -}

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)

-- first-class-families-0.3.0.1 doesn't support partially applying Lookup
type Lookup a = Fcf.Map Fcf.Snd <=< Fcf.Find (Fcf.TyEq a <=< Fcf.Fst)

-- | The type-level function that return the schema of the given key in a 'SchemaObject'.
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
    )

-- | Get a key from the given 'Data.Aeson.Schema.Internal.Object', returned as the type encoded in
-- its schema.
--
-- > let o = .. :: Object
-- >             ( 'SchemaObject
-- >                '[ '("foo", 'SchemaInt)
-- >                 , '("bar", 'SchemaObject
-- >                      '[ '("name", 'SchemaText)
-- >                       ]
-- >                 , '("baz", 'SchemaMaybe 'SchemaBool)
-- >                 ]
-- >             )
-- >
-- > getKey (Proxy @"foo") o                  :: Bool
-- > getKey (Proxy @"bar") o                  :: Object ('SchemaObject '[ '("name", 'SchemaText) ])
-- > getKey (Proxy @"name") $ getKey @"bar" o :: Text
-- > getKey (Proxy @"baz") o                  :: Maybe Bool
--
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