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