{-# 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 <brandonchinn178@gmail.com>
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) 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 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unknown schema: " forall a. [a] -> [a] -> [a]
++ String
name) forall (m :: * -> *) a. Monad m => a -> m a
return
      NameTH Name
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 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 ->
              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 ->
              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
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"'" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
schemaName 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 forall a. Eq a => a -> a -> Bool
== ''Object -> forall a. a -> Maybe a
Just TypeWithoutKinds
inner
      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 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} =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Could not parse schema: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeWithoutKinds
reifiedSchemaType) forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. Eq a => a -> a -> Bool
== 'Schema -> forall (m :: * -> *) a. Monad m => a -> m a
return TypeWithoutKinds
schemaType
        TypeWithoutKinds
_ -> forall (f :: * -> *) a. Alternative f => f a
empty

      forall s ty. SchemaObjectMap' s ty -> Schema' s ty
Schema forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWithoutKinds -> Maybe SchemaObjectMapV
parseSchemaObjectMap TypeWithoutKinds
schemaObjectType

    -- should be the inverse of schemaObjectMapVToTypeQ
    parseSchemaObjectMap :: TypeWithoutKinds -> Maybe SchemaObjectMapV
    parseSchemaObjectMap :: TypeWithoutKinds -> Maybe SchemaObjectMapV
parseSchemaObjectMap TypeWithoutKinds
schemaObjectType = do
      [(TypeWithoutKinds, TypeWithoutKinds)]
schemaObjectListOfPairs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeWithoutKinds -> Maybe (TypeWithoutKinds, TypeWithoutKinds)
typeToPair forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeWithoutKinds -> Maybe [TypeWithoutKinds]
typeToList TypeWithoutKinds
schemaObjectType
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(TypeWithoutKinds, TypeWithoutKinds)]
schemaObjectListOfPairs forall a b. (a -> b) -> a -> b
$ \(TypeWithoutKinds
schemaKeyType, TypeWithoutKinds
schemaTypeType) -> do
        SchemaKey' String
schemaKey <- TypeWithoutKinds -> Maybe (SchemaKey' String)
parseSchemaKey TypeWithoutKinds
schemaKeyType
        SchemaType' String NameLike
schemaType <- TypeWithoutKinds -> Maybe (SchemaType' String NameLike)
parseSchemaType TypeWithoutKinds
schemaTypeType
        forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaKey' String
schemaKey, SchemaType' String NameLike
schemaType)

    -- should be the inverse of schemaKeyVToTypeQ
    parseSchemaKey :: TypeWithoutKinds -> Maybe SchemaKeyV
    parseSchemaKey :: TypeWithoutKinds -> Maybe (SchemaKey' String)
parseSchemaKey = \case
      AppT (PromotedT Name
ty) (LitT (StrTyLit String
key))
        | Name
ty forall a. Eq a => a -> a -> Bool
== 'NormalKey -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. s -> SchemaKey' s
NormalKey String
key
        | Name
ty forall a. Eq a => a -> a -> Bool
== 'PhantomKey -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. s -> SchemaKey' s
PhantomKey String
key
      TypeWithoutKinds
_ -> forall (f :: * -> *) a. Alternative f => f a
empty

    -- should be the inverse of schemaTypeVToTypeQ
    parseSchemaType :: TypeWithoutKinds -> Maybe SchemaTypeV
    parseSchemaType :: TypeWithoutKinds -> Maybe (SchemaType' String NameLike)
parseSchemaType = \case
      AppT (PromotedT Name
name) (ConT Name
inner)
        | Name
name forall a. Eq a => a -> a -> Bool
== 'SchemaScalar -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s ty. ty -> SchemaType' s ty
SchemaScalar forall a b. (a -> b) -> a -> b
$ Name -> NameLike
NameTH Name
inner
      AppT (PromotedT Name
name) TypeWithoutKinds
inner
        | Name
name forall a. Eq a => a -> a -> Bool
== 'SchemaMaybe -> forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWithoutKinds -> Maybe (SchemaType' String NameLike)
parseSchemaType TypeWithoutKinds
inner
        | Name
name forall a. Eq a => a -> a -> Bool
== 'SchemaTry -> forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaTry forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWithoutKinds -> Maybe (SchemaType' String NameLike)
parseSchemaType TypeWithoutKinds
inner
        | Name
name forall a. Eq a => a -> a -> Bool
== 'SchemaList -> forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWithoutKinds -> Maybe (SchemaType' String NameLike)
parseSchemaType TypeWithoutKinds
inner
        | Name
name forall a. Eq a => a -> a -> Bool
== 'SchemaUnion -> do
            [TypeWithoutKinds]
schemas <- TypeWithoutKinds -> Maybe [TypeWithoutKinds]
typeToList TypeWithoutKinds
inner
            forall s ty. [SchemaType' s ty] -> SchemaType' s ty
SchemaUnion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeWithoutKinds -> Maybe (SchemaType' String NameLike)
parseSchemaType [TypeWithoutKinds]
schemas
        | Name
name forall a. Eq a => a -> a -> Bool
== 'SchemaObject -> forall s ty. SchemaObjectMap' s ty -> SchemaType' s ty
SchemaObject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWithoutKinds -> Maybe SchemaObjectMapV
parseSchemaObjectMap TypeWithoutKinds
inner
      AppT (PromotedT Name
name) (AppT (PromotedT Name
right) (ConT Name
inner))
        | Name
name forall a. Eq a => a -> a -> Bool
== 'SchemaInclude
        , Name
right forall a. Eq a => a -> a -> Bool
== 'Right ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s ty. Either ty (Schema' s ty) -> SchemaType' s ty
SchemaInclude forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Name -> NameLike
NameTH Name
inner
      TypeWithoutKinds
_ -> forall (f :: * -> *) a. Alternative f => f a
empty

-- | Resolve SchemaInclude, if present. (Not recursive)
resolveSchemaType :: SchemaTypeV -> Q SchemaTypeV
resolveSchemaType :: SchemaType' String NameLike -> Q (SchemaType' String NameLike)
resolveSchemaType = \case
  SchemaInclude (Left NameLike
name) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SchemaV -> SchemaType' String NameLike
toSchemaObjectV forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReifiedSchema -> Q SchemaV
loadSchema forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NameLike -> Q ReifiedSchema
lookupSchema NameLike
name
  SchemaInclude (Right SchemaV
_) -> forall a. String -> a
unreachable String
"Found 'SchemaInclude Right' when resolving schema type"
  SchemaType' String NameLike
schemaType -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SchemaType' String NameLike
schemaType

{- Splicing schema into TH -}

schemaVToTypeQ :: SchemaV -> TypeQ
schemaVToTypeQ :: SchemaV -> Q TypeWithoutKinds
schemaVToTypeQ = forall (m :: * -> *).
Quote m =>
m TypeWithoutKinds -> m TypeWithoutKinds -> m TypeWithoutKinds
appT [t|'Schema|] forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaObjectMapV -> Q TypeWithoutKinds
schemaObjectMapVToTypeQ forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaV -> SchemaObjectMapV
fromSchemaV

schemaObjectMapVToTypeQ :: SchemaObjectMapV -> TypeQ
schemaObjectMapVToTypeQ :: SchemaObjectMapV -> Q TypeWithoutKinds
schemaObjectMapVToTypeQ = [Q TypeWithoutKinds] -> Q TypeWithoutKinds
promotedListT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (SchemaKey' String, SchemaType' String NameLike)
-> Q TypeWithoutKinds
schemaObjectPairVToTypeQ
  where
    schemaObjectPairVToTypeQ :: (SchemaKeyV, SchemaTypeV) -> TypeQ
    schemaObjectPairVToTypeQ :: (SchemaKey' String, SchemaType' String NameLike)
-> Q TypeWithoutKinds
schemaObjectPairVToTypeQ = (Q TypeWithoutKinds, Q TypeWithoutKinds) -> Q TypeWithoutKinds
promotedPairT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap SchemaKey' String -> Q TypeWithoutKinds
schemaKeyVToTypeQ SchemaType' String NameLike -> Q TypeWithoutKinds
schemaTypeVToTypeQ

    schemaKeyVToTypeQ :: SchemaKeyV -> TypeQ
    schemaKeyVToTypeQ :: SchemaKey' String -> Q TypeWithoutKinds
schemaKeyVToTypeQ = \case
      NormalKey String
key -> [t|'NormalKey $(litT $ strTyLit key)|]
      PhantomKey String
key -> [t|'PhantomKey $(litT $ strTyLit key)|]

schemaTypeVToTypeQ :: SchemaTypeV -> TypeQ
schemaTypeVToTypeQ :: SchemaType' String NameLike -> Q TypeWithoutKinds
schemaTypeVToTypeQ = \case
  SchemaScalar NameLike
name -> [t|'SchemaScalar $(resolveName name >>= conT)|]
  SchemaMaybe SchemaType' String NameLike
inner -> [t|'SchemaMaybe $(schemaTypeVToTypeQ inner)|]
  SchemaTry SchemaType' String NameLike
inner -> [t|'SchemaTry $(schemaTypeVToTypeQ inner)|]
  SchemaList SchemaType' String NameLike
inner -> [t|'SchemaList $(schemaTypeVToTypeQ inner)|]
  SchemaUnion [SchemaType' String NameLike]
schemas -> [t|'SchemaUnion $(promotedListT $ map schemaTypeVToTypeQ schemas)|]
  SchemaObject SchemaObjectMapV
pairs -> [t|'SchemaObject $(schemaObjectMapVToTypeQ pairs)|]
  SchemaInclude (Left NameLike
name) -> [t|'SchemaInclude ('Right $(conT . reifiedSchemaName =<< lookupSchema name))|]
  SchemaInclude (Right SchemaV
_) -> 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
    AppKindT TypeWithoutKinds
ty1 TypeWithoutKinds
_ -> TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1

    -- cases that recurse
    ForallT [TyVarBndr Specificity]
tyVars [TypeWithoutKinds]
ctx TypeWithoutKinds
ty1 -> [TyVarBndr Specificity]
-> [TypeWithoutKinds] -> TypeWithoutKinds -> TypeWithoutKinds
ForallT [TyVarBndr Specificity]
tyVars [TypeWithoutKinds]
ctx (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1)
    ForallVisT [TyVarBndr ()]
tyVars TypeWithoutKinds
ty1 -> [TyVarBndr ()] -> TypeWithoutKinds -> TypeWithoutKinds
ForallVisT [TyVarBndr ()]
tyVars (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1)
    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)
#if MIN_VERSION_template_haskell(2,19,0)
    PromotedInfixT ty1 name ty2 -> PromotedInfixT (stripKinds ty1) name (stripKinds ty2)
    PromotedUInfixT ty1 name ty2 -> PromotedUInfixT (stripKinds ty1) name (stripKinds ty2)
#endif
    ParensT TypeWithoutKinds
ty1 -> TypeWithoutKinds -> TypeWithoutKinds
ParensT (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1)
    ImplicitParamT String
str TypeWithoutKinds
ty1 -> String -> TypeWithoutKinds -> TypeWithoutKinds
ImplicitParamT String
str (TypeWithoutKinds -> TypeWithoutKinds
stripKinds TypeWithoutKinds
ty1)

    -- 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)
    TypeWithoutKinds
MulArrowT -> TypeWithoutKinds
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 -> forall a. a -> Maybe a
Just []
  AppT (AppT TypeWithoutKinds
PromotedConsT TypeWithoutKinds
x) TypeWithoutKinds
xs -> (TypeWithoutKinds
x forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWithoutKinds -> Maybe [TypeWithoutKinds]
typeToList TypeWithoutKinds
xs
  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 -> forall a. a -> Maybe a
Just (TypeWithoutKinds
a, TypeWithoutKinds
b)
  TypeWithoutKinds
_ -> forall a. Maybe a
Nothing

promotedListT :: [TypeQ] -> TypeQ
promotedListT :: [Q TypeWithoutKinds] -> Q TypeWithoutKinds
promotedListT = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (m :: * -> *).
Quote m =>
m TypeWithoutKinds -> m TypeWithoutKinds -> m TypeWithoutKinds
consT forall (m :: * -> *). Quote m => m TypeWithoutKinds
promotedNilT
  where
    -- nb. https://stackoverflow.com/a/34457936
    consT :: m TypeWithoutKinds -> m TypeWithoutKinds -> m TypeWithoutKinds
consT m TypeWithoutKinds
x m TypeWithoutKinds
xs = forall (m :: * -> *).
Quote m =>
m TypeWithoutKinds -> m TypeWithoutKinds -> m TypeWithoutKinds
appT (forall (m :: * -> *).
Quote m =>
m TypeWithoutKinds -> m TypeWithoutKinds -> m TypeWithoutKinds
appT forall (m :: * -> *). Quote m => m TypeWithoutKinds
promotedConsT m TypeWithoutKinds
x) m TypeWithoutKinds
xs

promotedPairT :: (TypeQ, TypeQ) -> TypeQ
promotedPairT :: (Q TypeWithoutKinds, Q TypeWithoutKinds) -> Q TypeWithoutKinds
promotedPairT (Q TypeWithoutKinds
a, Q TypeWithoutKinds
b) = [t|'($a, $b)|]