{-# 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
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
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
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
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) = 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' 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 " forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
schema
  SchemaMaybe SchemaTypeV
inner -> String
"SchemaMaybe " forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner
  SchemaTry SchemaTypeV
inner -> String
"SchemaTry " forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner
  SchemaList SchemaTypeV
inner -> String
"SchemaList " forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner
  SchemaUnion [SchemaTypeV]
_ -> String
"SchemaUnion " forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
schema
  SchemaObject SchemaObjectMap' String NameLike
_ -> String
"SchemaObject " forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
schema
  SchemaInclude Either NameLike SchemaV
_ -> String
"SchemaInclude " 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 " forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner
  SchemaTry SchemaTypeV
inner -> String
"Try " forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner
  SchemaList SchemaTypeV
inner -> String
"List " forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner
  SchemaUnion [SchemaTypeV]
schemas -> String
"( " forall a. [a] -> [a] -> [a]
++ forall {a} {a}. (a -> [a]) -> [a] -> [a] -> [a]
mapJoin SchemaTypeV -> String
showSchemaTypeV' String
" | " [SchemaTypeV]
schemas forall a. [a] -> [a] -> [a]
++ String
" )"
  SchemaObject SchemaObjectMap' String NameLike
pairs -> String
"{ " forall a. [a] -> [a] -> [a]
++ forall {a} {a}. (a -> [a]) -> [a] -> [a] -> [a]
mapJoin (SchemaKeyV, SchemaTypeV) -> String
showPair String
", " SchemaObjectMap' String NameLike
pairs forall a. [a] -> [a] -> [a]
++ String
" }"
  SchemaInclude (Left NameLike
name) -> NameLike -> String
fromName NameLike
name
  SchemaInclude (Right SchemaV
_) -> 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 forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV' SchemaTypeV
inner

    mapJoin :: (a -> [a]) -> [a] -> [a] -> [a]
mapJoin a -> [a]
f [a]
delim = forall a. [a] -> [[a]] -> [a]
intercalate [a]
delim forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (schema :: Schema).
IsSchemaObjectMap (FromSchema schema) =>
Proxy schema -> SchemaV
toSchemaV Proxy schema
_ = forall s ty. SchemaObjectMap' s ty -> Schema' s ty
Schema forall a b. (a -> b) -> a -> b
$ forall (pairs :: SchemaObjectMap).
IsSchemaObjectMap pairs =>
Proxy pairs -> SchemaObjectMap' String NameLike
toSchemaTypeMapV forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @(FromSchema schema)

toSchemaTypeMapV :: forall pairs. IsSchemaObjectMap pairs => Proxy pairs -> SchemaObjectMapV
toSchemaTypeMapV :: forall (pairs :: SchemaObjectMap).
IsSchemaObjectMap pairs =>
Proxy pairs -> SchemaObjectMap' String NameLike
toSchemaTypeMapV Proxy pairs
_ = forall {k} {k1} (f :: k -> Constraint) (xs :: k1) a.
All f xs =>
(forall (x :: k). f x => Proxy x -> a) -> [a]
mapAll @IsSchemaObjectPair @pairs forall (a :: (SchemaKey, SchemaType)).
IsSchemaObjectPair a =>
Proxy a -> (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)
_ = forall s ty. ty -> SchemaType' s ty
SchemaScalar (String -> NameLike
NameRef forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConName forall a b. (a -> b) -> a -> b
$ TypeRep -> TyCon
typeRepTyCon forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @inner)

instance IsSchemaType inner => IsSchemaType ('SchemaMaybe inner) where
  toSchemaTypeV :: Proxy ('SchemaMaybe inner) -> SchemaTypeV
toSchemaTypeV Proxy ('SchemaMaybe inner)
_ = forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaMaybe (forall (schemaType :: SchemaType).
IsSchemaType schemaType =>
Proxy schemaType -> SchemaTypeV
toSchemaTypeV forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @inner)

instance IsSchemaType inner => IsSchemaType ('SchemaTry inner) where
  toSchemaTypeV :: Proxy ('SchemaTry inner) -> SchemaTypeV
toSchemaTypeV Proxy ('SchemaTry inner)
_ = forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaTry (forall (schemaType :: SchemaType).
IsSchemaType schemaType =>
Proxy schemaType -> SchemaTypeV
toSchemaTypeV forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @inner)

instance IsSchemaType inner => IsSchemaType ('SchemaList inner) where
  toSchemaTypeV :: Proxy ('SchemaList inner) -> SchemaTypeV
toSchemaTypeV Proxy ('SchemaList inner)
_ = forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaList (forall (schemaType :: SchemaType).
IsSchemaType schemaType =>
Proxy schemaType -> SchemaTypeV
toSchemaTypeV forall a b. (a -> b) -> a -> b
$ 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)
_ = forall s ty. [SchemaType' s ty] -> SchemaType' s ty
SchemaUnion (forall {k} {k1} (f :: k -> Constraint) (xs :: k1) 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)
_ = forall s ty. SchemaObjectMap' s ty -> SchemaType' s ty
SchemaObject (forall (pairs :: SchemaObjectMap).
IsSchemaObjectMap pairs =>
Proxy pairs -> SchemaObjectMap' String NameLike
toSchemaTypeMapV forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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

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)
_ = (forall (key :: SchemaKey).
IsSchemaKey key =>
Proxy key -> SchemaKeyV
toSchemaKeyV forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @key, forall (schemaType :: SchemaType).
IsSchemaType schemaType =>
Proxy schemaType -> SchemaTypeV
toSchemaTypeV forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @inner)