content: {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE UndecidableInstances #-}
  
  {-|
  Module      :  Data.Aeson.Schema.Type
  Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>
  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 (Show, 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 (Show, 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 (Schema schema) = SchemaObject schema
  
  fromSchemaV :: SchemaV -> SchemaObjectMapV
  fromSchemaV (Schema schema) = schema
  
  -- | Show the given schema, as "{ key: Schema, ... }"
  showSchemaV :: SchemaV -> String
  showSchemaV = showSchemaTypeV' . toSchemaObjectV
  
  -- | Pretty show the given SchemaType.
  showSchemaTypeV :: SchemaTypeV -> String
  showSchemaTypeV schema = case schema of
    SchemaScalar _ -> "SchemaScalar " ++ showSchemaTypeV' schema
    SchemaMaybe inner -> "SchemaMaybe " ++ showSchemaTypeV' inner
    SchemaTry inner -> "SchemaTry " ++ showSchemaTypeV' inner
    SchemaList inner -> "SchemaList " ++ showSchemaTypeV' inner
    SchemaUnion _ -> "SchemaUnion " ++ showSchemaTypeV' schema
    SchemaObject _ -> "SchemaObject " ++ showSchemaTypeV' schema
    SchemaInclude _ -> "SchemaInclude " ++ showSchemaTypeV' schema
  
  showSchemaTypeV' :: SchemaTypeV -> String
  showSchemaTypeV' = \case
    SchemaScalar ty -> fromName ty
    SchemaMaybe inner -> "Maybe " ++ showSchemaTypeV' inner
    SchemaTry inner -> "Try " ++ showSchemaTypeV' inner
    SchemaList inner -> "List " ++ showSchemaTypeV' inner
    SchemaUnion schemas -> "( " ++ mapJoin showSchemaTypeV' " | " schemas ++ " )"
    SchemaObject pairs -> "{ " ++ mapJoin showPair ", " pairs ++ " }"
    SchemaInclude (Left name) -> fromName name
    SchemaInclude (Right _) -> unreachable "Found 'SchemaInclude Right' when showing schema type"
    where
      showPair (key, inner) = showSchemaKeyV key ++ ": " ++ showSchemaTypeV' inner
  
      mapJoin f delim = intercalate delim . map 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 _ = Schema $ toSchemaTypeMapV $ Proxy @(FromSchema schema)
  
  toSchemaTypeMapV :: forall pairs. (IsSchemaObjectMap pairs) => Proxy pairs -> SchemaObjectMapV
  toSchemaTypeMapV _ = mapAll @IsSchemaObjectPair @pairs toSchemaTypePairV
  
  class IsSchemaType (schemaType :: SchemaType) where
    toSchemaTypeV :: Proxy schemaType -> SchemaTypeV
  
  instance (Typeable inner) => IsSchemaType ('SchemaScalar inner) where
    toSchemaTypeV _ = SchemaScalar (NameRef $ tyConName $ typeRepTyCon $ typeRep $ Proxy @inner)
  
  instance (IsSchemaType inner) => IsSchemaType ('SchemaMaybe inner) where
    toSchemaTypeV _ = SchemaMaybe (toSchemaTypeV $ Proxy @inner)
  
  instance (IsSchemaType inner) => IsSchemaType ('SchemaTry inner) where
    toSchemaTypeV _ = SchemaTry (toSchemaTypeV $ Proxy @inner)
  
  instance (IsSchemaType inner) => IsSchemaType ('SchemaList inner) where
    toSchemaTypeV _ = SchemaList (toSchemaTypeV $ Proxy @inner)
  
  instance (All IsSchemaType schemas) => IsSchemaType ('SchemaUnion schemas) where
    toSchemaTypeV _ = SchemaUnion (mapAll @IsSchemaType @schemas toSchemaTypeV)
  
  instance (IsSchemaObjectMap pairs) => IsSchemaType ('SchemaObject pairs) where
    toSchemaTypeV _ = SchemaObject (toSchemaTypeMapV $ Proxy @pairs)
  
  instance (IsSchemaObjectMap (FromSchema schema)) => IsSchemaType ('SchemaInclude ('Right schema)) where
    toSchemaTypeV _ = toSchemaObjectV $ toSchemaV $ 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 _ = (toSchemaKeyV $ Proxy @key, toSchemaTypeV $ Proxy @inner)
  