{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Data.Aeson.Schema.TH.Utils
( reifySchema
, lookupSchema
, loadSchema
, resolveSchemaType
, schemaVToTypeQ
, schemaTypeVToTypeQ
) where
import Control.Applicative (empty)
import Control.Monad (forM)
import Data.Bifunctor (bimap)
import Language.Haskell.TH
import Data.Aeson.Schema.Internal (Object)
import Data.Aeson.Schema.Key (SchemaKey'(..), SchemaKeyV)
import Data.Aeson.Schema.Type
( Schema'(..)
, SchemaObjectMapV
, SchemaType'(..)
, SchemaTypeV
, SchemaV
, fromSchemaV
, toSchemaObjectV
)
import Data.Aeson.Schema.Utils.Invariant (unreachable)
import Data.Aeson.Schema.Utils.NameLike (NameLike(..), resolveName)
reifySchema :: String -> Q SchemaV
reifySchema :: String -> Q SchemaV
reifySchema String
name = NameLike -> Q ReifiedSchema
lookupSchema (String -> NameLike
NameRef String
name) Q ReifiedSchema -> (ReifiedSchema -> Q SchemaV) -> Q SchemaV
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReifiedSchema -> Q SchemaV
loadSchema
data ReifiedSchema = ReifiedSchema
{ ReifiedSchema -> Name
reifiedSchemaName :: Name
, ReifiedSchema -> TypeWithoutKinds
reifiedSchemaType :: TypeWithoutKinds
}
lookupSchema :: NameLike -> Q ReifiedSchema
lookupSchema :: NameLike -> Q ReifiedSchema
lookupSchema NameLike
nameLike = do
Name
name <- NameLike -> Q Name
lookupSchemaName NameLike
nameLike
Name -> TypeWithoutKinds -> ReifiedSchema
ReifiedSchema Name
name (TypeWithoutKinds -> ReifiedSchema)
-> Q TypeWithoutKinds -> Q ReifiedSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q TypeWithoutKinds
reifySchemaType Name
name
where
lookupSchemaName :: NameLike -> Q Name
lookupSchemaName = \case
NameRef String
name -> String -> Q (Maybe Name)
lookupTypeName String
name Q (Maybe Name) -> (Maybe Name -> Q Name) -> Q Name
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Q Name -> (Name -> Q Name) -> Maybe Name -> Q Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"Unknown schema: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return
NameTH Name
name -> Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
reifySchemaType :: Name -> Q TypeWithoutKinds
reifySchemaType :: Name -> Q TypeWithoutKinds
reifySchemaType Name
schemaName = Name -> Q Info
reify Name
schemaName Q Info -> (Info -> Q TypeWithoutKinds) -> Q TypeWithoutKinds
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
TyConI (TySynD Name
_ [TyVarBndr]
_ (TypeWithoutKinds -> TypeWithoutKinds
stripKinds -> TypeWithoutKinds
ty))
| TypeWithoutKinds -> Bool
isPromotedSchema TypeWithoutKinds
ty
-> TypeWithoutKinds -> Q TypeWithoutKinds
forall (m :: * -> *) a. Monad m => a -> m a
return TypeWithoutKinds
ty
| Just TypeWithoutKinds
inner <- TypeWithoutKinds -> Maybe TypeWithoutKinds
unwrapObject TypeWithoutKinds
ty
, TypeWithoutKinds -> Bool
isPromotedSchema TypeWithoutKinds
inner
-> TypeWithoutKinds -> Q TypeWithoutKinds
forall (m :: * -> *) a. Monad m => a -> m a
return TypeWithoutKinds
inner
| Just (ConT Name
schemaName') <- TypeWithoutKinds -> Maybe TypeWithoutKinds
unwrapObject TypeWithoutKinds
ty
-> Name -> Q TypeWithoutKinds
reifySchemaType Name
schemaName'
Info
_ -> String -> Q TypeWithoutKinds
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q TypeWithoutKinds) -> String -> Q TypeWithoutKinds
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
schemaName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a Schema"
unwrapObject :: TypeWithoutKinds -> Maybe TypeWithoutKinds
unwrapObject :: TypeWithoutKinds -> Maybe TypeWithoutKinds
unwrapObject = \case
AppT (ConT Name
name) TypeWithoutKinds
inner | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Object -> TypeWithoutKinds -> Maybe TypeWithoutKinds
forall a. a -> Maybe a
Just TypeWithoutKinds
inner
TypeWithoutKinds
_ -> Maybe TypeWithoutKinds
forall a. Maybe a
Nothing
isPromotedSchema :: TypeWithoutKinds -> Bool
isPromotedSchema :: TypeWithoutKinds -> Bool
isPromotedSchema = \case
AppT (PromotedT Name
name) TypeWithoutKinds
_ | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'Schema -> Bool
True
TypeWithoutKinds
_ -> Bool
False
loadSchema :: ReifiedSchema -> Q SchemaV
loadSchema :: ReifiedSchema -> Q SchemaV
loadSchema ReifiedSchema{TypeWithoutKinds
reifiedSchemaType :: TypeWithoutKinds
reifiedSchemaType :: ReifiedSchema -> TypeWithoutKinds
reifiedSchemaType} =
Q SchemaV -> (SchemaV -> Q SchemaV) -> Maybe SchemaV -> Q SchemaV
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Q SchemaV
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q SchemaV) -> String -> Q SchemaV
forall a b. (a -> b) -> a -> b
$ String
"Could not parse schema: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeWithoutKinds -> String
forall a. Show a => a -> String
show TypeWithoutKinds
reifiedSchemaType) SchemaV -> Q SchemaV
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SchemaV -> Q SchemaV) -> Maybe SchemaV -> Q SchemaV
forall a b. (a -> b) -> a -> b
$ TypeWithoutKinds -> Maybe SchemaV
parseSchema TypeWithoutKinds
reifiedSchemaType
where
parseSchema :: TypeWithoutKinds -> Maybe SchemaV
parseSchema :: TypeWithoutKinds -> Maybe SchemaV
parseSchema TypeWithoutKinds
ty = do
TypeWithoutKinds
schemaObjectType <- case TypeWithoutKinds
ty of
AppT (PromotedT Name
name) TypeWithoutKinds
schemaType | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'Schema -> TypeWithoutKinds -> Maybe TypeWithoutKinds
forall (m :: * -> *) a. Monad m => a -> m a
return TypeWithoutKinds
schemaType
TypeWithoutKinds
_ -> Maybe TypeWithoutKinds
forall (f :: * -> *) a. Alternative f => f a
empty
SchemaObjectMap' String NameLike -> SchemaV
forall s ty. SchemaObjectMap' s ty -> Schema' s ty
Schema (SchemaObjectMap' String NameLike -> SchemaV)
-> Maybe (SchemaObjectMap' String NameLike) -> Maybe SchemaV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWithoutKinds -> Maybe (SchemaObjectMap' String NameLike)
parseSchemaObjectMap TypeWithoutKinds
schemaObjectType
parseSchemaObjectMap :: TypeWithoutKinds -> Maybe SchemaObjectMapV
parseSchemaObjectMap :: TypeWithoutKinds -> Maybe (SchemaObjectMap' String NameLike)
parseSchemaObjectMap TypeWithoutKinds
schemaObjectType = do
[(TypeWithoutKinds, TypeWithoutKinds)]
schemaObjectListOfPairs <- (TypeWithoutKinds -> Maybe (TypeWithoutKinds, TypeWithoutKinds))
-> [TypeWithoutKinds]
-> Maybe [(TypeWithoutKinds, TypeWithoutKinds)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeWithoutKinds -> Maybe (TypeWithoutKinds, TypeWithoutKinds)
typeToPair ([TypeWithoutKinds]
-> Maybe [(TypeWithoutKinds, TypeWithoutKinds)])
-> Maybe [TypeWithoutKinds]
-> Maybe [(TypeWithoutKinds, TypeWithoutKinds)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeWithoutKinds -> Maybe [TypeWithoutKinds]
typeToList TypeWithoutKinds
schemaObjectType
[(TypeWithoutKinds, TypeWithoutKinds)]
-> ((TypeWithoutKinds, TypeWithoutKinds)
-> Maybe (SchemaKeyV, SchemaTypeV))
-> Maybe (SchemaObjectMap' String NameLike)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(TypeWithoutKinds, TypeWithoutKinds)]
schemaObjectListOfPairs (((TypeWithoutKinds, TypeWithoutKinds)
-> Maybe (SchemaKeyV, SchemaTypeV))
-> Maybe (SchemaObjectMap' String NameLike))
-> ((TypeWithoutKinds, TypeWithoutKinds)
-> Maybe (SchemaKeyV, SchemaTypeV))
-> Maybe (SchemaObjectMap' String NameLike)
forall a b. (a -> b) -> a -> b
$ \(TypeWithoutKinds
schemaKeyType, TypeWithoutKinds
schemaTypeType) -> do
SchemaKeyV
schemaKey <- TypeWithoutKinds -> Maybe SchemaKeyV
parseSchemaKey TypeWithoutKinds
schemaKeyType
SchemaTypeV
schemaType <- TypeWithoutKinds -> Maybe SchemaTypeV
parseSchemaType TypeWithoutKinds
schemaTypeType
(SchemaKeyV, SchemaTypeV) -> Maybe (SchemaKeyV, SchemaTypeV)
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaKeyV
schemaKey, SchemaTypeV
schemaType)
parseSchemaKey :: TypeWithoutKinds -> Maybe SchemaKeyV
parseSchemaKey :: TypeWithoutKinds -> Maybe SchemaKeyV
parseSchemaKey = \case
AppT (PromotedT Name
ty) (LitT (StrTyLit String
key))
| Name
ty Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'NormalKey -> SchemaKeyV -> Maybe SchemaKeyV
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaKeyV -> Maybe SchemaKeyV) -> SchemaKeyV -> Maybe SchemaKeyV
forall a b. (a -> b) -> a -> b
$ String -> SchemaKeyV
forall s. s -> SchemaKey' s
NormalKey String
key
| Name
ty Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'PhantomKey -> SchemaKeyV -> Maybe SchemaKeyV
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaKeyV -> Maybe SchemaKeyV) -> SchemaKeyV -> Maybe SchemaKeyV
forall a b. (a -> b) -> a -> b
$ String -> SchemaKeyV
forall s. s -> SchemaKey' s
PhantomKey String
key
TypeWithoutKinds
_ -> Maybe SchemaKeyV
forall (f :: * -> *) a. Alternative f => f a
empty
parseSchemaType :: TypeWithoutKinds -> Maybe SchemaTypeV
parseSchemaType :: TypeWithoutKinds -> Maybe SchemaTypeV
parseSchemaType = \case
AppT (PromotedT Name
name) (ConT Name
inner)
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'SchemaScalar -> SchemaTypeV -> Maybe SchemaTypeV
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaTypeV -> Maybe SchemaTypeV)
-> SchemaTypeV -> Maybe SchemaTypeV
forall a b. (a -> b) -> a -> b
$ NameLike -> SchemaTypeV
forall s ty. ty -> SchemaType' s ty
SchemaScalar (NameLike -> SchemaTypeV) -> NameLike -> SchemaTypeV
forall a b. (a -> b) -> a -> b
$ Name -> NameLike
NameTH Name
inner
AppT (PromotedT Name
name) TypeWithoutKinds
inner
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'SchemaMaybe -> SchemaTypeV -> SchemaTypeV
forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaMaybe (SchemaTypeV -> SchemaTypeV)
-> Maybe SchemaTypeV -> Maybe SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWithoutKinds -> Maybe SchemaTypeV
parseSchemaType TypeWithoutKinds
inner
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'SchemaTry -> SchemaTypeV -> SchemaTypeV
forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaTry (SchemaTypeV -> SchemaTypeV)
-> Maybe SchemaTypeV -> Maybe SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWithoutKinds -> Maybe SchemaTypeV
parseSchemaType TypeWithoutKinds
inner
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'SchemaList -> SchemaTypeV -> SchemaTypeV
forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaList (SchemaTypeV -> SchemaTypeV)
-> Maybe SchemaTypeV -> Maybe SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWithoutKinds -> Maybe SchemaTypeV
parseSchemaType TypeWithoutKinds
inner
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'SchemaUnion -> do
[TypeWithoutKinds]
schemas <- TypeWithoutKinds -> Maybe [TypeWithoutKinds]
typeToList TypeWithoutKinds
inner
[SchemaTypeV] -> SchemaTypeV
forall s ty. [SchemaType' s ty] -> SchemaType' s ty
SchemaUnion ([SchemaTypeV] -> SchemaTypeV)
-> Maybe [SchemaTypeV] -> Maybe SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeWithoutKinds -> Maybe SchemaTypeV)
-> [TypeWithoutKinds] -> Maybe [SchemaTypeV]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeWithoutKinds -> Maybe SchemaTypeV
parseSchemaType [TypeWithoutKinds]
schemas
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'SchemaObject -> SchemaObjectMap' String NameLike -> SchemaTypeV
forall s ty. SchemaObjectMap' s ty -> SchemaType' s ty
SchemaObject (SchemaObjectMap' String NameLike -> SchemaTypeV)
-> Maybe (SchemaObjectMap' String NameLike) -> Maybe SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWithoutKinds -> Maybe (SchemaObjectMap' String NameLike)
parseSchemaObjectMap TypeWithoutKinds
inner
AppT (PromotedT Name
name) (AppT (PromotedT Name
right) (ConT Name
inner))
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'SchemaInclude
, Name
right Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'Right
-> SchemaTypeV -> Maybe SchemaTypeV
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaTypeV -> Maybe SchemaTypeV)
-> SchemaTypeV -> Maybe SchemaTypeV
forall a b. (a -> b) -> a -> b
$ Either NameLike SchemaV -> SchemaTypeV
forall s ty. Either ty (Schema' s ty) -> SchemaType' s ty
SchemaInclude (Either NameLike SchemaV -> SchemaTypeV)
-> Either NameLike SchemaV -> SchemaTypeV
forall a b. (a -> b) -> a -> b
$ NameLike -> Either NameLike SchemaV
forall a b. a -> Either a b
Left (NameLike -> Either NameLike SchemaV)
-> NameLike -> Either NameLike SchemaV
forall a b. (a -> b) -> a -> b
$ Name -> NameLike
NameTH Name
inner
TypeWithoutKinds
_ -> Maybe SchemaTypeV
forall (f :: * -> *) a. Alternative f => f a
empty
resolveSchemaType :: SchemaTypeV -> Q SchemaTypeV
resolveSchemaType :: SchemaTypeV -> Q SchemaTypeV
resolveSchemaType = \case
SchemaInclude (Left NameLike
name) -> (SchemaV -> SchemaTypeV) -> Q SchemaV -> Q SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SchemaV -> SchemaTypeV
toSchemaObjectV (Q SchemaV -> Q SchemaTypeV)
-> (ReifiedSchema -> Q SchemaV) -> ReifiedSchema -> Q SchemaTypeV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReifiedSchema -> Q SchemaV
loadSchema (ReifiedSchema -> Q SchemaTypeV)
-> Q ReifiedSchema -> Q SchemaTypeV
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NameLike -> Q ReifiedSchema
lookupSchema NameLike
name
SchemaInclude (Right SchemaV
_) -> String -> Q SchemaTypeV
forall a. String -> a
unreachable String
"Found 'SchemaInclude Right' when resolving schema type"
SchemaTypeV
schemaType -> SchemaTypeV -> Q SchemaTypeV
forall (f :: * -> *) a. Applicative f => a -> f a
pure SchemaTypeV
schemaType
schemaVToTypeQ :: SchemaV -> TypeQ
schemaVToTypeQ :: SchemaV -> Q TypeWithoutKinds
schemaVToTypeQ = Q TypeWithoutKinds -> Q TypeWithoutKinds -> Q TypeWithoutKinds
appT [t| 'Schema |] (Q TypeWithoutKinds -> Q TypeWithoutKinds)
-> (SchemaV -> Q TypeWithoutKinds) -> SchemaV -> Q TypeWithoutKinds
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaObjectMap' String NameLike -> Q TypeWithoutKinds
schemaObjectMapVToTypeQ (SchemaObjectMap' String NameLike -> Q TypeWithoutKinds)
-> (SchemaV -> SchemaObjectMap' String NameLike)
-> SchemaV
-> Q TypeWithoutKinds
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaV -> SchemaObjectMap' String NameLike
fromSchemaV
schemaObjectMapVToTypeQ :: SchemaObjectMapV -> TypeQ
schemaObjectMapVToTypeQ :: SchemaObjectMap' String NameLike -> Q TypeWithoutKinds
schemaObjectMapVToTypeQ = [Q TypeWithoutKinds] -> Q TypeWithoutKinds
promotedListT ([Q TypeWithoutKinds] -> Q TypeWithoutKinds)
-> (SchemaObjectMap' String NameLike -> [Q TypeWithoutKinds])
-> SchemaObjectMap' String NameLike
-> Q TypeWithoutKinds
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SchemaKeyV, SchemaTypeV) -> Q TypeWithoutKinds)
-> SchemaObjectMap' String NameLike -> [Q TypeWithoutKinds]
forall a b. (a -> b) -> [a] -> [b]
map (SchemaKeyV, SchemaTypeV) -> Q TypeWithoutKinds
schemaObjectPairVToTypeQ
where
schemaObjectPairVToTypeQ :: (SchemaKeyV, SchemaTypeV) -> TypeQ
schemaObjectPairVToTypeQ :: (SchemaKeyV, SchemaTypeV) -> Q TypeWithoutKinds
schemaObjectPairVToTypeQ = (Q TypeWithoutKinds, Q TypeWithoutKinds) -> Q TypeWithoutKinds
promotedPairT ((Q TypeWithoutKinds, Q TypeWithoutKinds) -> Q TypeWithoutKinds)
-> ((SchemaKeyV, SchemaTypeV)
-> (Q TypeWithoutKinds, Q TypeWithoutKinds))
-> (SchemaKeyV, SchemaTypeV)
-> Q TypeWithoutKinds
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SchemaKeyV -> Q TypeWithoutKinds)
-> (SchemaTypeV -> Q TypeWithoutKinds)
-> (SchemaKeyV, SchemaTypeV)
-> (Q TypeWithoutKinds, Q TypeWithoutKinds)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap SchemaKeyV -> Q TypeWithoutKinds
schemaKeyVToTypeQ SchemaTypeV -> Q TypeWithoutKinds
schemaTypeVToTypeQ
schemaKeyVToTypeQ :: SchemaKeyV -> TypeQ
schemaKeyVToTypeQ :: SchemaKeyV -> Q TypeWithoutKinds
schemaKeyVToTypeQ = \case
NormalKey String
key -> [t| 'NormalKey $(litT $ strTyLit key) |]
PhantomKey String
key -> [t| 'PhantomKey $(litT $ strTyLit key) |]
schemaTypeVToTypeQ :: SchemaTypeV -> TypeQ
schemaTypeVToTypeQ :: SchemaTypeV -> Q TypeWithoutKinds
schemaTypeVToTypeQ = \case
SchemaScalar NameLike
name -> [t| 'SchemaScalar $(resolveName name >>= conT) |]
SchemaMaybe SchemaTypeV
inner -> [t| 'SchemaMaybe $(schemaTypeVToTypeQ inner) |]
SchemaTry SchemaTypeV
inner -> [t| 'SchemaTry $(schemaTypeVToTypeQ inner) |]
SchemaList SchemaTypeV
inner -> [t| 'SchemaList $(schemaTypeVToTypeQ inner) |]
SchemaUnion [SchemaTypeV]
schemas -> [t| 'SchemaUnion $(promotedListT $ map schemaTypeVToTypeQ schemas) |]
SchemaObject SchemaObjectMap' String NameLike
pairs -> [t| 'SchemaObject $(schemaObjectMapVToTypeQ pairs) |]
SchemaInclude (Left NameLike
name) -> [t| 'SchemaInclude ('Right $(conT . reifiedSchemaName =<< lookupSchema name)) |]
SchemaInclude (Right SchemaV
_) -> String -> Q TypeWithoutKinds
forall a. String -> a
unreachable String
"Found 'SchemaInclude Right' when converting to TypeQ"
type TypeWithoutKinds = Type
stripKinds :: Type -> TypeWithoutKinds
stripKinds :: TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty =
case TypeWithoutKinds
ty of
SigT TypeWithoutKinds
ty1 TypeWithoutKinds
_ -> TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1
#if MIN_VERSION_template_haskell(2,15,0)
AppKindT TypeWithoutKinds
ty1 TypeWithoutKinds
_ -> TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1
#endif
ForallT [TyVarBndr]
tyVars [TypeWithoutKinds]
ctx TypeWithoutKinds
ty1 -> [TyVarBndr]
-> [TypeWithoutKinds] -> TypeWithoutKinds -> TypeWithoutKinds
ForallT [TyVarBndr]
tyVars [TypeWithoutKinds]
ctx (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1)
#if MIN_VERSION_template_haskell(2,16,0)
ForallVisT [TyVarBndr]
tyVars TypeWithoutKinds
ty1 -> [TyVarBndr] -> TypeWithoutKinds -> TypeWithoutKinds
ForallVisT [TyVarBndr]
tyVars (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1)
#endif
AppT TypeWithoutKinds
ty1 TypeWithoutKinds
ty2 -> TypeWithoutKinds -> TypeWithoutKinds -> TypeWithoutKinds
AppT (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1) (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty2)
InfixT TypeWithoutKinds
ty1 Name
name TypeWithoutKinds
ty2 -> TypeWithoutKinds -> Name -> TypeWithoutKinds -> TypeWithoutKinds
InfixT (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1) Name
name (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty2)
UInfixT TypeWithoutKinds
ty1 Name
name TypeWithoutKinds
ty2 -> TypeWithoutKinds -> Name -> TypeWithoutKinds -> TypeWithoutKinds
UInfixT (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1) Name
name (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty2)
ParensT TypeWithoutKinds
ty1 -> TypeWithoutKinds -> TypeWithoutKinds
ParensT (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1)
#if MIN_VERSION_template_haskell(2,15,0)
ImplicitParamT String
str TypeWithoutKinds
ty1 -> String -> TypeWithoutKinds -> TypeWithoutKinds
ImplicitParamT String
str (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1)
#endif
VarT Name
_ -> TypeWithoutKinds
ty
ConT Name
_ -> TypeWithoutKinds
ty
PromotedT Name
_ -> TypeWithoutKinds
ty
TupleT Int
_ -> TypeWithoutKinds
ty
UnboxedTupleT Int
_ -> TypeWithoutKinds
ty
UnboxedSumT Int
_ -> TypeWithoutKinds
ty
TypeWithoutKinds
ArrowT -> TypeWithoutKinds
ty
TypeWithoutKinds
EqualityT -> TypeWithoutKinds
ty
TypeWithoutKinds
ListT -> TypeWithoutKinds
ty
PromotedTupleT Int
_ -> TypeWithoutKinds
ty
TypeWithoutKinds
PromotedNilT -> TypeWithoutKinds
ty
TypeWithoutKinds
PromotedConsT -> TypeWithoutKinds
ty
TypeWithoutKinds
StarT -> TypeWithoutKinds
ty
TypeWithoutKinds
ConstraintT -> TypeWithoutKinds
ty
LitT TyLit
_ -> TypeWithoutKinds
ty
TypeWithoutKinds
WildCardT -> TypeWithoutKinds
ty
typeToList :: TypeWithoutKinds -> Maybe [TypeWithoutKinds]
typeToList :: TypeWithoutKinds -> Maybe [TypeWithoutKinds]
typeToList = \case
TypeWithoutKinds
PromotedNilT -> [TypeWithoutKinds] -> Maybe [TypeWithoutKinds]
forall a. a -> Maybe a
Just []
AppT (AppT TypeWithoutKinds
PromotedConsT TypeWithoutKinds
x) TypeWithoutKinds
xs -> (TypeWithoutKinds
xTypeWithoutKinds -> [TypeWithoutKinds] -> [TypeWithoutKinds]
forall a. a -> [a] -> [a]
:) ([TypeWithoutKinds] -> [TypeWithoutKinds])
-> Maybe [TypeWithoutKinds] -> Maybe [TypeWithoutKinds]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWithoutKinds -> Maybe [TypeWithoutKinds]
typeToList TypeWithoutKinds
xs
TypeWithoutKinds
_ -> Maybe [TypeWithoutKinds]
forall a. Maybe a
Nothing
typeToPair :: TypeWithoutKinds -> Maybe (TypeWithoutKinds, TypeWithoutKinds)
typeToPair :: TypeWithoutKinds -> Maybe (TypeWithoutKinds, TypeWithoutKinds)
typeToPair = \case
AppT (AppT (PromotedTupleT Int
2) TypeWithoutKinds
a) TypeWithoutKinds
b -> (TypeWithoutKinds, TypeWithoutKinds)
-> Maybe (TypeWithoutKinds, TypeWithoutKinds)
forall a. a -> Maybe a
Just (TypeWithoutKinds
a, TypeWithoutKinds
b)
TypeWithoutKinds
_ -> Maybe (TypeWithoutKinds, TypeWithoutKinds)
forall a. Maybe a
Nothing
promotedListT :: [TypeQ] -> TypeQ
promotedListT :: [Q TypeWithoutKinds] -> Q TypeWithoutKinds
promotedListT = (Q TypeWithoutKinds -> Q TypeWithoutKinds -> Q TypeWithoutKinds)
-> Q TypeWithoutKinds -> [Q TypeWithoutKinds] -> Q TypeWithoutKinds
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Q TypeWithoutKinds -> Q TypeWithoutKinds -> Q TypeWithoutKinds
consT Q TypeWithoutKinds
promotedNilT
where
consT :: Q TypeWithoutKinds -> Q TypeWithoutKinds -> Q TypeWithoutKinds
consT Q TypeWithoutKinds
x Q TypeWithoutKinds
xs = Q TypeWithoutKinds -> Q TypeWithoutKinds -> Q TypeWithoutKinds
appT (Q TypeWithoutKinds -> Q TypeWithoutKinds -> Q TypeWithoutKinds
appT Q TypeWithoutKinds
promotedConsT Q TypeWithoutKinds
x) Q TypeWithoutKinds
xs
promotedPairT :: (TypeQ, TypeQ) -> TypeQ
promotedPairT :: (Q TypeWithoutKinds, Q TypeWithoutKinds) -> Q TypeWithoutKinds
promotedPairT (Q TypeWithoutKinds
a, Q TypeWithoutKinds
b) = [t| '( $a, $b ) |]