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

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

-- | 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)
  | SchemaTry (SchemaType' s ty) -- ^ @since v1.2.0
  | SchemaList (SchemaType' s ty)
  | SchemaUnion [SchemaType' s ty] -- ^ @since v1.1.0
  | SchemaObject (SchemaObjectMap' s ty)
  | SchemaInclude (Either ty (Schema' 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
  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)