{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Aeson.Schema.Type
( Schema'(..)
, SchemaType'(..)
, SchemaV
, SchemaTypeV
, SchemaObjectMapV
, toSchemaObjectV
, fromSchemaV
, showSchemaV
, showSchemaTypeV
, Schema
, SchemaType
, ToSchemaObject
, FromSchema
, IsSchemaType(..)
, IsSchemaObjectMap
, toSchemaV
) where
import Data.Kind (Type)
import Data.List (intercalate)
import Data.Proxy (Proxy(..))
import Data.Typeable (Typeable, tyConName, typeRep, typeRepTyCon)
import GHC.TypeLits (Symbol)
import Data.Aeson.Schema.Key
(IsSchemaKey(..), SchemaKey, SchemaKey', SchemaKeyV, showSchemaKeyV)
import Data.Aeson.Schema.Utils.All (All(..))
import Data.Aeson.Schema.Utils.Invariant (unreachable)
import Data.Aeson.Schema.Utils.NameLike (NameLike(..), fromName)
data Schema' s ty = Schema (SchemaObjectMap' s ty)
deriving (Int -> Schema' s ty -> ShowS
[Schema' s ty] -> ShowS
Schema' s ty -> String
(Int -> Schema' s ty -> ShowS)
-> (Schema' s ty -> String)
-> ([Schema' s ty] -> ShowS)
-> Show (Schema' s ty)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s ty. (Show s, Show ty) => Int -> Schema' s ty -> ShowS
forall s ty. (Show s, Show ty) => [Schema' s ty] -> ShowS
forall s ty. (Show s, Show ty) => Schema' s ty -> String
showList :: [Schema' s ty] -> ShowS
$cshowList :: forall s ty. (Show s, Show ty) => [Schema' s ty] -> ShowS
show :: Schema' s ty -> String
$cshow :: forall s ty. (Show s, Show ty) => Schema' s ty -> String
showsPrec :: Int -> Schema' s ty -> ShowS
$cshowsPrec :: forall s ty. (Show s, Show ty) => Int -> Schema' s ty -> ShowS
Show, Schema' s ty -> Schema' s ty -> Bool
(Schema' s ty -> Schema' s ty -> Bool)
-> (Schema' s ty -> Schema' s ty -> Bool) -> Eq (Schema' s ty)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s ty. (Eq s, Eq ty) => Schema' s ty -> Schema' s ty -> Bool
/= :: Schema' s ty -> Schema' s ty -> Bool
$c/= :: forall s ty. (Eq s, Eq ty) => Schema' s ty -> Schema' s ty -> Bool
== :: Schema' s ty -> Schema' s ty -> Bool
$c== :: forall s ty. (Eq s, Eq ty) => Schema' s ty -> Schema' s ty -> Bool
Eq)
data SchemaType' s ty
= SchemaScalar ty
| SchemaMaybe (SchemaType' s ty)
| SchemaTry (SchemaType' s ty)
| SchemaList (SchemaType' s ty)
| SchemaUnion [SchemaType' s ty]
| SchemaObject (SchemaObjectMap' s ty)
| SchemaInclude (Either ty (Schema' s ty))
deriving (Int -> SchemaType' s ty -> ShowS
[SchemaType' s ty] -> ShowS
SchemaType' s ty -> String
(Int -> SchemaType' s ty -> ShowS)
-> (SchemaType' s ty -> String)
-> ([SchemaType' s ty] -> ShowS)
-> Show (SchemaType' s ty)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s ty. (Show ty, Show s) => Int -> SchemaType' s ty -> ShowS
forall s ty. (Show ty, Show s) => [SchemaType' s ty] -> ShowS
forall s ty. (Show ty, Show s) => SchemaType' s ty -> String
showList :: [SchemaType' s ty] -> ShowS
$cshowList :: forall s ty. (Show ty, Show s) => [SchemaType' s ty] -> ShowS
show :: SchemaType' s ty -> String
$cshow :: forall s ty. (Show ty, Show s) => SchemaType' s ty -> String
showsPrec :: Int -> SchemaType' s ty -> ShowS
$cshowsPrec :: forall s ty. (Show ty, Show s) => Int -> SchemaType' s ty -> ShowS
Show, SchemaType' s ty -> SchemaType' s ty -> Bool
(SchemaType' s ty -> SchemaType' s ty -> Bool)
-> (SchemaType' s ty -> SchemaType' s ty -> Bool)
-> Eq (SchemaType' s ty)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s ty.
(Eq ty, Eq s) =>
SchemaType' s ty -> SchemaType' s ty -> Bool
/= :: SchemaType' s ty -> SchemaType' s ty -> Bool
$c/= :: forall s ty.
(Eq ty, Eq s) =>
SchemaType' s ty -> SchemaType' s ty -> Bool
== :: SchemaType' s ty -> SchemaType' s ty -> Bool
$c== :: forall s ty.
(Eq ty, Eq s) =>
SchemaType' s ty -> SchemaType' s ty -> Bool
Eq)
type SchemaObjectMap' s ty = [(SchemaKey' s, SchemaType' s ty)]
type SchemaV = Schema' String NameLike
type SchemaTypeV = SchemaType' String NameLike
type SchemaObjectMapV = SchemaObjectMap' String NameLike
toSchemaObjectV :: SchemaV -> SchemaTypeV
toSchemaObjectV :: SchemaV -> SchemaTypeV
toSchemaObjectV (Schema SchemaObjectMap' String NameLike
schema) = SchemaObjectMap' String NameLike -> SchemaTypeV
forall s ty. SchemaObjectMap' s ty -> SchemaType' s ty
SchemaObject SchemaObjectMap' String NameLike
schema
fromSchemaV :: SchemaV -> SchemaObjectMapV
fromSchemaV :: SchemaV -> SchemaObjectMap' String NameLike
fromSchemaV (Schema SchemaObjectMap' String NameLike
schema) = SchemaObjectMap' String NameLike
schema
showSchemaV :: SchemaV -> String
showSchemaV :: SchemaV -> String
showSchemaV = SchemaTypeV -> String
showSchemaTypeV' (SchemaTypeV -> String)
-> (SchemaV -> SchemaTypeV) -> SchemaV -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaV -> SchemaTypeV
toSchemaObjectV
showSchemaTypeV :: SchemaTypeV -> String
showSchemaTypeV :: SchemaTypeV -> String
showSchemaTypeV SchemaTypeV
schema = case SchemaTypeV
schema of
SchemaScalar NameLike
_ -> String
"SchemaScalar " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
schema
SchemaMaybe SchemaTypeV
inner -> String
"SchemaMaybe " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner
SchemaTry SchemaTypeV
inner -> String
"SchemaTry " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner
SchemaList SchemaTypeV
inner -> String
"SchemaList " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner
SchemaUnion [SchemaTypeV]
_ -> String
"SchemaUnion " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
schema
SchemaObject SchemaObjectMap' String NameLike
_ -> String
"SchemaObject " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
schema
SchemaInclude Either NameLike SchemaV
_ -> String
"SchemaInclude " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
schema
showSchemaTypeV' :: SchemaTypeV -> String
showSchemaTypeV' :: SchemaTypeV -> String
showSchemaTypeV' = \case
SchemaScalar NameLike
ty -> NameLike -> String
fromName NameLike
ty
SchemaMaybe SchemaTypeV
inner -> String
"Maybe " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner
SchemaTry SchemaTypeV
inner -> String
"Try " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner
SchemaList SchemaTypeV
inner -> String
"List " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner
SchemaUnion [SchemaTypeV]
schemas -> String
"( " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (SchemaTypeV -> String) -> String -> [SchemaTypeV] -> String
forall a a. (a -> [a]) -> [a] -> [a] -> [a]
mapJoin SchemaTypeV -> String
showSchemaTypeV' String
" | " [SchemaTypeV]
schemas String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" )"
SchemaObject SchemaObjectMap' String NameLike
pairs -> String
"{ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((SchemaKeyV, SchemaTypeV) -> String)
-> String -> SchemaObjectMap' String NameLike -> String
forall a a. (a -> [a]) -> [a] -> [a] -> [a]
mapJoin (SchemaKeyV, SchemaTypeV) -> String
showPair String
", " SchemaObjectMap' String NameLike
pairs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" }"
SchemaInclude (Left NameLike
name) -> NameLike -> String
fromName NameLike
name
SchemaInclude (Right SchemaV
_) -> ShowS
forall a. String -> a
unreachable String
"Found 'SchemaInclude Right' when showing schema type"
where
showPair :: (SchemaKeyV, SchemaTypeV) -> String
showPair (SchemaKeyV
key, SchemaTypeV
inner) = SchemaKeyV -> String
showSchemaKeyV SchemaKeyV
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner
mapJoin :: (a -> [a]) -> [a] -> [a] -> [a]
mapJoin a -> [a]
f [a]
delim = [a] -> [[a]] -> [a]
forall a. [a] -> [[a]] -> [a]
intercalate [a]
delim ([[a]] -> [a]) -> ([a] -> [[a]]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a]) -> [a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map a -> [a]
f
type Schema = Schema' Symbol Type
type SchemaType = SchemaType' Symbol Type
type SchemaObjectMap = SchemaObjectMap' Symbol Type
type family ToSchemaObject (schema :: Schema) :: SchemaType where
ToSchemaObject ('Schema schema) = 'SchemaObject schema
type family FromSchema (schema :: Schema) :: SchemaObjectMap where
FromSchema ('Schema schema) = schema
toSchemaV :: forall schema. IsSchemaObjectMap (FromSchema schema) => Proxy schema -> SchemaV
toSchemaV :: Proxy schema -> SchemaV
toSchemaV Proxy schema
_ = SchemaObjectMap' String NameLike -> SchemaV
forall s ty. SchemaObjectMap' s ty -> Schema' s ty
Schema (SchemaObjectMap' String NameLike -> SchemaV)
-> SchemaObjectMap' String NameLike -> SchemaV
forall a b. (a -> b) -> a -> b
$ Proxy (FromSchema schema) -> SchemaObjectMap' String NameLike
forall (pairs :: SchemaObjectMap).
IsSchemaObjectMap pairs =>
Proxy pairs -> SchemaObjectMap' String NameLike
toSchemaTypeMapV (Proxy (FromSchema schema) -> SchemaObjectMap' String NameLike)
-> Proxy (FromSchema schema) -> SchemaObjectMap' String NameLike
forall a b. (a -> b) -> a -> b
$ Proxy (FromSchema schema)
forall k (t :: k). Proxy t
Proxy @(FromSchema schema)
toSchemaTypeMapV :: forall pairs. IsSchemaObjectMap pairs => Proxy pairs -> SchemaObjectMapV
toSchemaTypeMapV :: Proxy pairs -> SchemaObjectMap' String NameLike
toSchemaTypeMapV Proxy pairs
_ = (forall (x :: (SchemaKey, SchemaType)).
IsSchemaObjectPair x =>
Proxy x -> (SchemaKeyV, SchemaTypeV))
-> SchemaObjectMap' String NameLike
forall k k (f :: k -> Constraint) (xs :: k) a.
All f xs =>
(forall (x :: k). f x => Proxy x -> a) -> [a]
mapAll @IsSchemaObjectPair @pairs forall (x :: (SchemaKey, SchemaType)).
IsSchemaObjectPair x =>
Proxy x -> (SchemaKeyV, SchemaTypeV)
toSchemaTypePairV
class IsSchemaType (schemaType :: SchemaType) where
toSchemaTypeV :: Proxy schemaType -> SchemaTypeV
instance Typeable inner => IsSchemaType ('SchemaScalar inner) where
toSchemaTypeV :: Proxy ('SchemaScalar inner) -> SchemaTypeV
toSchemaTypeV Proxy ('SchemaScalar inner)
_ = NameLike -> SchemaTypeV
forall s ty. ty -> SchemaType' s ty
SchemaScalar (String -> NameLike
NameRef (String -> NameLike) -> String -> NameLike
forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConName (TyCon -> String) -> TyCon -> String
forall a b. (a -> b) -> a -> b
$ TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> TypeRep -> TyCon
forall a b. (a -> b) -> a -> b
$ Proxy inner -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy inner -> TypeRep) -> Proxy inner -> TypeRep
forall a b. (a -> b) -> a -> b
$ Proxy inner
forall k (t :: k). Proxy t
Proxy @inner)
instance IsSchemaType inner => IsSchemaType ('SchemaMaybe inner) where
toSchemaTypeV :: Proxy ('SchemaMaybe inner) -> SchemaTypeV
toSchemaTypeV Proxy ('SchemaMaybe inner)
_ = SchemaTypeV -> SchemaTypeV
forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaMaybe (Proxy inner -> SchemaTypeV
forall (schemaType :: SchemaType).
IsSchemaType schemaType =>
Proxy schemaType -> SchemaTypeV
toSchemaTypeV (Proxy inner -> SchemaTypeV) -> Proxy inner -> SchemaTypeV
forall a b. (a -> b) -> a -> b
$ Proxy inner
forall k (t :: k). Proxy t
Proxy @inner)
instance IsSchemaType inner => IsSchemaType ('SchemaTry inner) where
toSchemaTypeV :: Proxy ('SchemaTry inner) -> SchemaTypeV
toSchemaTypeV Proxy ('SchemaTry inner)
_ = SchemaTypeV -> SchemaTypeV
forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaTry (Proxy inner -> SchemaTypeV
forall (schemaType :: SchemaType).
IsSchemaType schemaType =>
Proxy schemaType -> SchemaTypeV
toSchemaTypeV (Proxy inner -> SchemaTypeV) -> Proxy inner -> SchemaTypeV
forall a b. (a -> b) -> a -> b
$ Proxy inner
forall k (t :: k). Proxy t
Proxy @inner)
instance IsSchemaType inner => IsSchemaType ('SchemaList inner) where
toSchemaTypeV :: Proxy ('SchemaList inner) -> SchemaTypeV
toSchemaTypeV Proxy ('SchemaList inner)
_ = SchemaTypeV -> SchemaTypeV
forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaList (Proxy inner -> SchemaTypeV
forall (schemaType :: SchemaType).
IsSchemaType schemaType =>
Proxy schemaType -> SchemaTypeV
toSchemaTypeV (Proxy inner -> SchemaTypeV) -> Proxy inner -> SchemaTypeV
forall a b. (a -> b) -> a -> b
$ Proxy inner
forall k (t :: k). Proxy t
Proxy @inner)
instance All IsSchemaType schemas => IsSchemaType ('SchemaUnion schemas) where
toSchemaTypeV :: Proxy ('SchemaUnion schemas) -> SchemaTypeV
toSchemaTypeV Proxy ('SchemaUnion schemas)
_ = [SchemaTypeV] -> SchemaTypeV
forall s ty. [SchemaType' s ty] -> SchemaType' s ty
SchemaUnion ((forall (schemaType :: SchemaType).
IsSchemaType schemaType =>
Proxy schemaType -> SchemaTypeV)
-> [SchemaTypeV]
forall k k (f :: k -> Constraint) (xs :: k) a.
All f xs =>
(forall (x :: k). f x => Proxy x -> a) -> [a]
mapAll @IsSchemaType @schemas forall (schemaType :: SchemaType).
IsSchemaType schemaType =>
Proxy schemaType -> SchemaTypeV
toSchemaTypeV)
instance IsSchemaObjectMap pairs => IsSchemaType ('SchemaObject pairs) where
toSchemaTypeV :: Proxy ('SchemaObject pairs) -> SchemaTypeV
toSchemaTypeV Proxy ('SchemaObject pairs)
_ = SchemaObjectMap' String NameLike -> SchemaTypeV
forall s ty. SchemaObjectMap' s ty -> SchemaType' s ty
SchemaObject (Proxy pairs -> SchemaObjectMap' String NameLike
forall (pairs :: SchemaObjectMap).
IsSchemaObjectMap pairs =>
Proxy pairs -> SchemaObjectMap' String NameLike
toSchemaTypeMapV (Proxy pairs -> SchemaObjectMap' String NameLike)
-> Proxy pairs -> SchemaObjectMap' String NameLike
forall a b. (a -> b) -> a -> b
$ Proxy pairs
forall k (t :: k). Proxy t
Proxy @pairs)
instance IsSchemaObjectMap (FromSchema schema) => IsSchemaType ('SchemaInclude ('Right schema)) where
toSchemaTypeV :: Proxy ('SchemaInclude ('Right schema)) -> SchemaTypeV
toSchemaTypeV Proxy ('SchemaInclude ('Right schema))
_ = SchemaV -> SchemaTypeV
toSchemaObjectV (SchemaV -> SchemaTypeV) -> SchemaV -> SchemaTypeV
forall a b. (a -> b) -> a -> b
$ 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
type IsSchemaObjectMap (pairs :: SchemaObjectMap) = All IsSchemaObjectPair pairs
class IsSchemaObjectPair (a :: (SchemaKey, SchemaType)) where
toSchemaTypePairV :: Proxy a -> (SchemaKeyV, SchemaTypeV)
instance (IsSchemaKey key, IsSchemaType inner) => IsSchemaObjectPair '(key, inner) where
toSchemaTypePairV :: Proxy '(key, inner) -> (SchemaKeyV, SchemaTypeV)
toSchemaTypePairV Proxy '(key, inner)
_ = (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, Proxy inner -> SchemaTypeV
forall (schemaType :: SchemaType).
IsSchemaType schemaType =>
Proxy schemaType -> SchemaTypeV
toSchemaTypeV (Proxy inner -> SchemaTypeV) -> Proxy inner -> SchemaTypeV
forall a b. (a -> b) -> a -> b
$ Proxy inner
forall k (t :: k). Proxy t
Proxy @inner)