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

{- 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

-- | 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
    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
    -- 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 ) |]