{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}

{- |
Module      :  Data.Aeson.Schema.TH.Utils
Maintainer  :  Brandon Chinn <brandon@leapyear.io>
Stability   :  experimental
Portability :  portable
-}
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)

{- Loading schema from TH -}

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
  }

{- | Look up a schema with the given name. Errors if the name doesn't exist or if the name does
 not refer to a schema.
-}
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))
          -- `type MySchema = 'Schema '[ ... ]`
          | TypeWithoutKinds -> Bool
isPromotedSchema TypeWithoutKinds
ty ->
            TypeWithoutKinds -> Q TypeWithoutKinds
forall (m :: * -> *) a. Monad m => a -> m a
return TypeWithoutKinds
ty
          -- `type MySchema = Object ('Schema '[ ... ])`
          | 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
          -- `type MySchema = Object OtherSchema`
          | 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"

    -- If the given type is of the format `Object a`, return `a`.
    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

    -- Return True if the given type is of the format: 'Schema '[ ... ]
    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
    -- should be the inverse of schemaVToTypeQ
    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

    -- should be the inverse of schemaObjectMapVToTypeQ
    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)

    -- should be the inverse of schemaKeyVToTypeQ
    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

    -- should be the inverse of schemaTypeVToTypeQ
    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

-- | Resolve SchemaInclude, if present. (Not recursive)
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

{- Splicing schema into TH -}

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"

{- TH utilities -}

{- | Same as 'Type' except without any kind signatures or applications at any depth.

 Provides no actual guarantees. The caller is responsible for making sure the value
 has been run through 'stripKinds' at one point.
-}
type TypeWithoutKinds = Type

{- FOURMOLU_DISABLE -}

-- | Recursively strip all kind signatures and applications.
stripKinds :: Type -> TypeWithoutKinds
stripKinds :: TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty =
  case TypeWithoutKinds
ty of
    -- cases that strip + recurse
    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

    -- cases that recurse
    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

    -- base cases
    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
#if MIN_VERSION_template_haskell(2,17,0)
    MulArrowT -> ty
#endif
    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

{- FOURMOLU_ENABLE -}

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
x TypeWithoutKinds -> [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
    -- nb. https://stackoverflow.com/a/34457936
    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)|]