{-# LANGUAGE AllowAmbiguousTypes #-}
{-# 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
Maintainer  :  Brandon Chinn <brandon@leapyear.io>
Stability   :  experimental
Portability :  portable

Internal definitions for declaring JSON schemas.
-}
module Data.Aeson.Schema.Internal where

import Control.Applicative (Alternative (..), optional)
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.List (intersperse)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.String (fromString)
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.Compat (Key, KeyMap)
import qualified Data.Aeson.Schema.Utils.Compat as Compat
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 (KeyMap Dynamic)

instance IsSchema schema => Show (Object schema) where
  showsPrec :: Int -> Object schema -> ShowS
showsPrec Int
_ = 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 = forall a. ToJSON a => a -> Value
toJSON Object schema
a forall a. Eq a => a -> a -> Bool
== forall a. ToJSON a => a -> Value
toJSON Object schema
b

instance IsSchema schema => FromJSON (Object schema) where
  parseJSON :: Value -> Parser (Object schema)
parseJSON = forall (schema :: SchemaType).
HasSchemaResult schema =>
[Key] -> Value -> Parser (SchemaResult schema)
parseValue @(ToSchemaObject schema) []

instance IsSchema schema => ToJSON (Object schema) where
  toJSON :: Object schema -> Value
toJSON = forall (schema :: SchemaType).
HasSchemaResult schema =>
SchemaResult schema -> Value
toValue @(ToSchemaObject schema)

{- | Convert an 'Object' into a 'Aeson.Object', losing the type information in the schema.

 @since 1.3.0
-}
toMap :: IsSchema ('Schema schema) => Object ('Schema schema) -> Aeson.Object
toMap :: forall (schema :: SchemaObjectMap).
IsSchema ('Schema schema) =>
Object ('Schema schema) -> Object
toMap = forall (pairs :: SchemaObjectMap).
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 :: forall (schema :: Schema). IsSchema schema => String
showSchema = String
"SchemaObject " forall a. [a] -> [a] -> [a]
++ SchemaV -> String
showSchemaV SchemaV
schema -- TODO: Remove "SchemaObject" prefix? Or rename to "Schema"?
  where
    schema :: SchemaV
schema = forall (schema :: Schema).
IsSchemaObjectMap (FromSchema schema) =>
Proxy schema -> SchemaV
toSchemaV forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @schema

showSchemaType :: forall (schemaType :: SchemaType). HasSchemaResult schemaType => String
showSchemaType :: forall (schemaType :: SchemaType).
HasSchemaResult schemaType =>
String
showSchemaType = SchemaTypeV -> String
showSchemaTypeV SchemaTypeV
schemaType
  where
    schemaType :: SchemaTypeV
schemaType = forall (schemaType :: SchemaType).
IsSchemaType schemaType =>
Proxy schemaType -> SchemaTypeV
toSchemaTypeV forall a b. (a -> b) -> a -> b
$ 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 :: [Key] -> Value -> Parser (SchemaResult schema)
  default parseValue :: FromJSON (SchemaResult schema) => [Key] -> Value -> Parser (SchemaResult schema)
  parseValue [Key]
path Value
value = forall a. FromJSON a => Value -> Parser a
parseJSON Value
value forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (schema :: SchemaType) (m :: * -> *) a.
(MonadFail m, HasSchemaResult schema) =>
[Key] -> Value -> m a
parseFail @schema [Key]
path Value
value

  toValue :: SchemaResult schema -> Value
  default toValue :: ToJSON (SchemaResult schema) => SchemaResult schema -> Value
  toValue = 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 = 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 :: [Key] -> Value -> Parser (SchemaResult ('SchemaMaybe inner))
parseValue [Key]
path = \case
    Value
Null -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Value
value -> (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (schema :: SchemaType).
HasSchemaResult schema =>
[Key] -> Value -> Parser (SchemaResult schema)
parseValue @inner [Key]
path Value
value)

instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ('SchemaTry inner) where
  parseValue :: [Key] -> Value -> Parser (SchemaResult ('SchemaTry inner))
parseValue [Key]
path = forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (schema :: SchemaType).
HasSchemaResult schema =>
[Key] -> Value -> Parser (SchemaResult schema)
parseValue @inner [Key]
path

instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ('SchemaList inner) where
  parseValue :: [Key] -> Value -> Parser (SchemaResult ('SchemaList inner))
parseValue [Key]
path = \case
    Array Array
a -> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (schema :: SchemaType).
HasSchemaResult schema =>
[Key] -> Value -> Parser (SchemaResult schema)
parseValue @inner [Key]
path) (forall l. IsList l => l -> [Item l]
toList Array
a)
    Value
value -> forall (schema :: SchemaType) (m :: * -> *) a.
(MonadFail m, HasSchemaResult schema) =>
[Key] -> Value -> m a
parseFail @('SchemaList inner) [Key]
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 :: [Key] -> Value -> Parser (SchemaResult ('SchemaUnion schemas))
parseValue [Key]
path Value
value = forall (xs :: [SchemaType]).
ParseSumType xs =>
[Key] -> Value -> Parser (SumType (SchemaResultList xs))
parseSumType @schemas [Key]
path Value
value forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (schema :: SchemaType) (m :: * -> *) a.
(MonadFail m, HasSchemaResult schema) =>
[Key] -> Value -> m a
parseFail @('SchemaUnion schemas) [Key]
path Value
value

class ParseSumType xs where
  parseSumType :: [Key] -> Value -> Parser (SumType (SchemaResultList xs))

instance ParseSumType '[] where
  parseSumType :: [Key] -> Value -> Parser (SumType (SchemaResultList '[]))
parseSumType [Key]
_ Value
_ = forall (f :: * -> *) a. Alternative f => f a
empty

instance (HasSchemaResult schema, ParseSumType schemas) => ParseSumType (schema ': schemas) where
  parseSumType :: [Key]
-> Value -> Parser (SumType (SchemaResultList (schema : schemas)))
parseSumType [Key]
path Value
value = Parser (SumType (SchemaResult schema : SchemaResultList schemas))
parseHere 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 = forall x (xs :: [*]). x -> SumType (x : xs)
Here forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (schema :: SchemaType).
HasSchemaResult schema =>
[Key] -> Value -> Parser (SchemaResult schema)
parseValue @schema [Key]
path Value
value
      parseThere :: Parser (SumType (SchemaResult schema : SchemaResultList schemas))
parseThere = forall x (xs :: [*]). SumType xs -> SumType (x : xs)
There forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (xs :: [SchemaType]).
ParseSumType xs =>
[Key] -> Value -> Parser (SumType (SchemaResultList xs))
parseSumType @schemas [Key]
path Value
value

instance (All HasSchemaResultPair pairs, IsSchemaObjectMap pairs) => HasSchemaResult ('SchemaObject pairs) where
  parseValue :: [Key] -> Value -> Parser (SchemaResult ('SchemaObject pairs))
parseValue [Key]
path = \case
    Aeson.Object Object
o -> forall (schema :: Schema). KeyMap Dynamic -> Object schema
UnsafeObject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. [(Key, v)] -> KeyMap v
Compat.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser [(Key, Dynamic)]
parseValueMap Object
o
    Value
value -> forall (schema :: SchemaType) (m :: * -> *) a.
(MonadFail m, HasSchemaResult schema) =>
[Key] -> Value -> m a
parseFail @('SchemaObject pairs) [Key]
path Value
value
    where
      parseValueMap :: Aeson.Object -> Parser [(Key, Dynamic)]
      parseValueMap :: Object -> Parser [(Key, Dynamic)]
parseValueMap Object
o = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall {k} {k1} (f :: k -> Constraint) (xs :: k1) a.
All f xs =>
(forall (x :: k). f x => Proxy x -> a) -> [a]
mapAll @HasSchemaResultPair @pairs forall a b. (a -> b) -> a -> b
$ \Proxy x
proxy -> forall (a :: (SchemaKey, SchemaType)).
HasSchemaResultPair a =>
Proxy a -> [Key] -> Object -> Parser (Key, Dynamic)
parseValuePair Proxy x
proxy [Key]
path Object
o

  toValue :: SchemaResult ('SchemaObject pairs) -> Value
toValue = Object -> Value
Aeson.Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (pairs :: SchemaObjectMap).
All HasSchemaResultPair pairs =>
Object ('Schema pairs) -> Object
toValueMap

  showValue :: SchemaResult ('SchemaObject pairs) -> ShowS
showValue SchemaResult ('SchemaObject pairs)
o = String -> ShowS
showString String
"{ " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [ShowS] -> ShowS
intercalateShowS String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (String, a -> String) -> a -> String
fromPair [(String, ShowS)]
pairs) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
": " forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
v
      pairs :: [(String, ShowS)]
pairs = forall {k} {k1} (f :: k -> Constraint) (xs :: k1) a.
All f xs =>
(forall (x :: k). f x => Proxy x -> a) -> [a]
mapAll @HasSchemaResultPair @pairs forall a b. (a -> b) -> a -> b
$ \Proxy x
proxy -> forall (a :: (SchemaKey, SchemaType)) (schema :: Schema).
HasSchemaResultPair a =>
Proxy a -> Object schema -> (String, ShowS)
showValuePair Proxy x
proxy SchemaResult ('SchemaObject pairs)
o

      -- intercalate for ShowS
      intercalateShowS :: String -> [ShowS] -> ShowS
      intercalateShowS :: String -> [ShowS] -> ShowS
intercalateShowS String
s = [ShowS] -> ShowS
concatShowS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse (String -> ShowS
showString String
s)

      concatShowS :: [ShowS] -> ShowS
      concatShowS :: [ShowS] -> ShowS
concatShowS = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id

toValueMap :: forall pairs. All HasSchemaResultPair pairs => Object ('Schema pairs) -> Aeson.Object
toValueMap :: forall (pairs :: SchemaObjectMap).
All HasSchemaResultPair pairs =>
Object ('Schema pairs) -> Object
toValueMap Object ('Schema pairs)
o = forall v. [KeyMap v] -> KeyMap v
Compat.unions forall a b. (a -> b) -> a -> b
$ forall {k} {k1} (f :: k -> Constraint) (xs :: k1) a.
All f xs =>
(forall (x :: k). f x => Proxy x -> a) -> [a]
mapAll @HasSchemaResultPair @pairs (\Proxy x
proxy -> 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 -> [Key] -> Aeson.Object -> Parser (Key, 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) -> [Key] -> Object -> Parser (Key, Dynamic)
parseValuePair Proxy '(key, inner)
_ [Key]
path Object
o = do
    SchemaResult inner
inner <- forall (schema :: SchemaType).
HasSchemaResult schema =>
[Key] -> Value -> Parser (SchemaResult schema)
parseValue @inner (Key
key forall a. a -> [a] -> [a]
: [Key]
path) forall a b. (a -> b) -> a -> b
$ SchemaKeyV -> Object -> Value
getContext SchemaKeyV
schemaKey Object
o
    forall (m :: * -> *) a. Monad m => a -> m a
return (Key
key, forall a. Typeable a => a -> Dynamic
toDyn SchemaResult inner
inner)
    where
      schemaKey :: SchemaKeyV
schemaKey = forall (key :: SchemaKey).
IsSchemaKey key =>
Proxy key -> SchemaKeyV
toSchemaKeyV forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @key
      key :: Key
key = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ SchemaKeyV -> String
fromSchemaKeyV SchemaKeyV
schemaKey

  toValuePair :: forall (schema :: Schema).
Proxy '(key, inner) -> Object schema -> Object
toValuePair Proxy '(key, inner)
_ Object schema
o = SchemaKeyV -> Value -> Object
toContext SchemaKeyV
schemaKey (forall (schema :: SchemaType).
HasSchemaResult schema =>
SchemaResult schema -> Value
toValue @inner SchemaResult inner
val)
    where
      schemaKey :: SchemaKeyV
schemaKey = forall (key :: SchemaKey).
IsSchemaKey key =>
Proxy key -> SchemaKeyV
toSchemaKeyV forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @key
      val :: SchemaResult inner
val = forall (endSchema :: SchemaType) (key :: Symbol)
       (schema :: Schema).
(KnownSymbol key, Typeable (SchemaResult endSchema)) =>
Proxy key -> Object schema -> SchemaResult endSchema
unsafeGetKey @inner (forall {k} (t :: k). Proxy t
Proxy @(FromSchemaKey key)) Object schema
o

  showValuePair :: forall (schema :: Schema).
Proxy '(key, inner) -> Object schema -> (String, ShowS)
showValuePair Proxy '(key, inner)
_ Object schema
o = (forall (key :: SchemaKey). IsSchemaKey key => String
showSchemaKey @key, forall (schema :: SchemaType).
HasSchemaResult schema =>
SchemaResult schema -> ShowS
showValue @inner SchemaResult inner
val)
    where
      val :: SchemaResult inner
val = forall (endSchema :: SchemaType) (key :: Symbol)
       (schema :: Schema).
(KnownSymbol key, Typeable (SchemaResult endSchema)) =>
Proxy key -> Object schema -> SchemaResult endSchema
unsafeGetKey @inner (forall {k} (t :: k). Proxy t
Proxy @(FromSchemaKey key)) Object schema
o

instance IsSchema schema => HasSchemaResult ('SchemaInclude ('Right schema)) where
  parseValue :: [Key]
-> Value -> Parser (SchemaResult ('SchemaInclude ('Right schema)))
parseValue = forall (schema :: SchemaType).
HasSchemaResult schema =>
[Key] -> Value -> Parser (SchemaResult schema)
parseValue @(ToSchemaObject schema)
  toValue :: SchemaResult ('SchemaInclude ('Right schema)) -> Value
toValue = forall (schema :: SchemaType).
HasSchemaResult schema =>
SchemaResult schema -> Value
toValue @(ToSchemaObject schema)
  showValue :: SchemaResult ('SchemaInclude ('Right schema)) -> ShowS
showValue = 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) => [Key] -> Value -> m a
parseFail :: forall (schema :: SchemaType) (m :: * -> *) a.
(MonadFail m, HasSchemaResult schema) =>
[Key] -> Value -> m a
parseFail [Key]
path Value
value = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
msg forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ Int -> ShowS
ellipses Int
200 (forall a. Show a => a -> String
show Value
value)
  where
    msg :: String
msg =
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
path
        then String
"Could not parse schema " forall a. [a] -> [a] -> [a]
++ String
schema'
        else String
"Could not parse path '" forall a. [a] -> [a] -> [a]
++ String
path' forall a. [a] -> [a] -> [a]
++ String
"' with schema " forall a. [a] -> [a] -> [a]
++ String
schema'
    path' :: String
path' = Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Key -> Text
Compat.keyToText forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Key]
path
    schema' :: String
schema' = String
"`" forall a. [a] -> [a] -> [a]
++ forall (schemaType :: SchemaType).
HasSchemaResult schemaType =>
String
showSchemaType @schema forall a. [a] -> [a] -> [a]
++ String
"`"
    ellipses :: Int -> ShowS
ellipses Int
n String
s = if forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s forall a. Ord a => a -> a -> Bool
> Int
n then forall a. Int -> [a] -> [a]
take Int
n String
s 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 :: 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 = 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 :: forall (endSchema :: SchemaType) (key :: Symbol)
       (schema :: Schema).
(KnownSymbol key, Typeable (SchemaResult endSchema)) =>
Proxy key -> Object schema -> SchemaResult endSchema
unsafeGetKey Proxy key
keyProxy (UnsafeObject KeyMap Dynamic
object) =
  forall a. a -> Maybe a -> a
fromMaybe (forall a. String -> a
unreachable forall a b. (a -> b) -> a -> b
$ String
"Could not load key: " forall a. [a] -> [a] -> [a]
++ String
key) forall a b. (a -> b) -> a -> b
$
    forall a. Typeable a => Dynamic -> Maybe a
fromDynamic forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall v. Key -> KeyMap v -> Maybe v
Compat.lookup (forall a. IsString a => String -> a
fromString String
key) KeyMap Dynamic
object
  where
    key :: String
key = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy key
keyProxy