{-# 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 (Show, 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 (Show, 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 (Schema schema) = SchemaObject schema
fromSchemaV :: SchemaV -> SchemaObjectMapV
fromSchemaV (Schema schema) = schema
showSchemaV :: SchemaV -> String
showSchemaV = showSchemaTypeV' . toSchemaObjectV
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 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)