{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}

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

Defines SchemaType, the AST that defines a JSON schema.
-}
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)

-- | The schema definition for a JSON object.
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)

-- | The AST defining a JSON schema.
data SchemaType' s ty
  = SchemaScalar ty
  | SchemaMaybe (SchemaType' s ty)
  | -- | @since v1.2.0
    SchemaTry (SchemaType' s ty)
  | SchemaList (SchemaType' s ty)
  | -- | @since v1.1.0
    SchemaUnion [SchemaType' s ty]
  | SchemaObject (SchemaObjectMap' s ty)
  | -- | An optimization for including schemas.
    --
    -- Will always be 'Left' when used in a value-level schema and 'Right' when used in
    -- a type-level schema. We can't use a type parameter for this because type synonyms
    -- can't be recursive (e.g. `type Schema = Schema' Symbol Type Schema`).
    --
    -- @since v1.3.2
    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)]

{- Value-level schema types -}

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

-- | Show the given schema, as "{ key: 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

-- | Pretty show the given SchemaType.
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-level schema types -}

{- | The kind of schemas that may be used with Object; e.g.

 > data Payload (schema :: Schema) = Payload
 >   { getPayload :: Object schema
 >   , timestamp  :: UTCTime
 >   }
-}
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)