{-# 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 _ = showValue @(ToSchemaObject schema)
instance IsSchema schema => Eq (Object schema) where
a == b = toJSON a == toJSON b
instance IsSchema schema => FromJSON (Object schema) where
parseJSON = parseValue @(ToSchemaObject schema) []
instance IsSchema schema => ToJSON (Object schema) where
toJSON = toValue @(ToSchemaObject schema)
toMap :: IsSchema ('Schema schema) => Object ('Schema schema) -> Aeson.Object
toMap = 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 = "SchemaObject " ++ showSchemaV schema
where
schema = toSchemaV $ Proxy @schema
showSchemaType :: forall (schemaType :: SchemaType). HasSchemaResult schemaType => String
showSchemaType = showSchemaTypeV schemaType
where
schemaType = toSchemaTypeV $ 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 path value = parseJSON value <|> parseFail @schema path value
toValue :: SchemaResult schema -> Value
default toValue :: ToJSON (SchemaResult schema) => SchemaResult schema -> Value
toValue = toJSON
showValue :: SchemaResult schema -> ShowS
default showValue :: Show (SchemaResult schema) => SchemaResult schema -> ShowS
showValue = 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 path = \case
Null -> return Nothing
value -> (Just <$> parseValue @inner path value)
instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ('SchemaTry inner) where
parseValue path = wrapTry . parseValue @inner path
where
wrapTry parser = (Just <$> parser) <|> pure Nothing
instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ('SchemaList inner) where
parseValue path = \case
Array a -> traverse (parseValue @inner path) (toList a)
value -> parseFail @('SchemaList inner) path 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 path value = parseSumType @schemas path value <|> parseFail @('SchemaUnion schemas) path value
class ParseSumType xs where
parseSumType :: [Text] -> Value -> Parser (SumType (SchemaResultList xs))
instance ParseSumType '[] where
parseSumType _ _ = empty
instance (HasSchemaResult schema, ParseSumType schemas) => ParseSumType (schema ': schemas) where
parseSumType path value = parseHere <|> parseThere
where
parseHere = Here <$> parseValue @schema path value
parseThere = There <$> parseSumType @schemas path value
instance (All HasSchemaResultPair pairs, IsSchemaObjectMap pairs) => HasSchemaResult ('SchemaObject pairs) where
parseValue path = \case
Aeson.Object o -> UnsafeObject . HashMap.fromList <$> parseValueMap o
value -> parseFail @('SchemaObject pairs) path value
where
parseValueMap :: Aeson.Object -> Parser [(Text, Dynamic)]
parseValueMap o = sequence $ mapAll @HasSchemaResultPair @pairs $ \proxy -> parseValuePair proxy path o
toValue = Aeson.Object . toValueMap
showValue o = showString "{ " . intercalateShowS ", " (map fromPair pairs) . showString " }"
where
fromPair (k, v) = showString k . showString ": " . v
pairs = mapAll @HasSchemaResultPair @pairs $ \proxy -> showValuePair proxy o
intercalateShowS :: String -> [ShowS] -> ShowS
intercalateShowS s = concatShowS . intersperse (showString s)
concatShowS :: [ShowS] -> ShowS
concatShowS = foldr (.) id
toValueMap :: forall pairs. All HasSchemaResultPair pairs => Object ('Schema pairs) -> Aeson.Object
toValueMap o = HashMap.unions $ mapAll @HasSchemaResultPair @pairs (\proxy -> toValuePair proxy 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 _ path o = do
inner <- parseValue @inner (key:path) $ getContext schemaKey o
return (key, toDyn inner)
where
schemaKey = toSchemaKeyV $ Proxy @key
key = Text.pack $ fromSchemaKeyV schemaKey
toValuePair _ o = toContext schemaKey (toValue @inner val)
where
schemaKey = toSchemaKeyV $ Proxy @key
val = unsafeGetKey @inner (Proxy @(FromSchemaKey key)) o
showValuePair _ o = (showSchemaKey @key, showValue @inner val)
where
val = unsafeGetKey @inner (Proxy @(FromSchemaKey key)) o
instance IsSchema schema => HasSchemaResult ('SchemaInclude ('Right schema)) where
parseValue = parseValue @(ToSchemaObject schema)
toValue = toValue @(ToSchemaObject schema)
showValue = showValue @(ToSchemaObject schema)
parseFail :: forall (schema :: SchemaType) m a. (MonadFail m, HasSchemaResult schema) => [Text] -> Value -> m a
parseFail path value = fail $ msg ++ ": " ++ ellipses 200 (show value)
where
msg = if null path
then "Could not parse schema " ++ schema'
else "Could not parse path '" ++ path' ++ "' with schema " ++ schema'
path' = Text.unpack . Text.intercalate "." $ reverse path
schema' = "`" ++ showSchemaType @schema ++ "`"
ellipses n s = if length s > n then take n s ++ "..." else 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 = unsafeGetKey @endSchema
unsafeGetKey
:: forall (endSchema :: SchemaType) (key :: Symbol) (schema :: Schema)
. (KnownSymbol key, Typeable (SchemaResult endSchema))
=> Proxy key -> Object schema -> SchemaResult endSchema
unsafeGetKey keyProxy (UnsafeObject object) =
fromMaybe (unreachable $ "Could not load key: " ++ key) $
fromDynamic (object ! Text.pack key)
where
key = symbolVal keyProxy