{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
module Data.Aeson.Schema.Type
( Schema'(..)
, SchemaType'(..)
, SchemaV
, SchemaTypeV
, SchemaObjectMapV
, NameLike(..)
, toSchemaObjectV
, fromSchemaV
, showSchemaV
, showSchemaTypeV
, Schema
, SchemaType
, ToSchemaObject
, FromSchema
, IsSchemaType(..)
, IsSchemaObjectMap
) 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 Language.Haskell.TH.Syntax (Lift, Name, nameBase)
import Data.Aeson.Schema.Key
(IsSchemaKey(..), SchemaKey, SchemaKey', SchemaKeyV, showSchemaKeyV)
import Data.Aeson.Schema.Utils.All (All(..))
data Schema' s ty = Schema (SchemaObjectMap' s ty)
deriving (Show, Eq, Lift)
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)
deriving (Show, Eq, Lift)
type SchemaObjectMap' s ty = [(SchemaKey' s, SchemaType' s ty)]
data NameLike = NameRef String | NameTH Name
instance Eq NameLike where
ty1 == ty2 = show ty1 == show ty2
instance Show NameLike where
show (NameRef ty) = ty
show (NameTH ty) = nameBase 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
showSchemaTypeV' :: SchemaTypeV -> String
showSchemaTypeV' = \case
SchemaScalar ty -> show 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 ++ " }"
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
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 (mapAll @IsSchemaObjectPair @pairs toSchemaTypePairV)
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)