{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Data.TypeLevel.Tuple.Index.TH (mkI) where

import Language.Haskell.TH

mkI :: Int -> Int -> DecQ
mkI :: Int -> Int -> DecQ
mkI Int
i Int
n = do
	Name
hd <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> ([String] -> String) -> [String] -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> Q Name) -> [String] -> Q Name
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
n [String]
varNames
	[Name]
ks <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
n [String]
kindNames
	[Name]
vs <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
n [String]
varNames
	Name -> Name -> [Name] -> [Name] -> Int -> DecQ
rawBar Name
tn Name
hd [Name]
ks [Name]
vs Int
i
	where tn :: Name
tn = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"I" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n

rawBar :: Name -> Name -> [Name] -> [Name] -> Int -> DecQ
rawBar :: Name -> Name -> [Name] -> [Name] -> Int -> DecQ
rawBar Name
tn Name
hd [Name]
ks [Name]
vs Int
i = Name
-> [TyVarBndr ()]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> [Q TySynEqn]
-> DecQ
forall (m :: * -> *).
Quote m =>
Name
-> [TyVarBndr ()]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> [m TySynEqn]
-> m Dec
closedTypeFamilyD Name
tn
	[Name -> Kind -> TyVarBndr ()
kindedTV Name
hd
		([Kind] -> Kind
tupleKind ([Kind] -> Kind) -> [Kind] -> Kind
forall a b. (a -> b) -> a -> b
$ Name -> Kind
varK (Name -> Kind) -> [Name] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
ks)]
	FamilyResultSig
NoSig Maybe InjectivityAnn
forall a. Maybe a
Nothing
	[Maybe [TyVarBndr ()] -> Q Kind -> Q Kind -> Q TySynEqn
forall (m :: * -> *).
Quote m =>
Maybe [TyVarBndr ()] -> m Kind -> m Kind -> m TySynEqn
tySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing
		(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
tn Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` [Q Kind] -> Q Kind
forall (m :: * -> *). Quote m => [m Kind] -> m Kind
promotedTupleType (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT (Name -> Q Kind) -> [Name] -> [Q Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vs))
		(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT (Name -> Q Kind) -> Name -> Q Kind
forall a b. (a -> b) -> a -> b
$ [Name]
vs [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)]

promotedTupleType :: Quote m => [m Type] -> m Type
promotedTupleType :: forall (m :: * -> *). Quote m => [m Kind] -> m Kind
promotedTupleType [m Kind]
ts = (m Kind -> m Kind -> m Kind) -> m Kind -> [m Kind] -> m Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m Kind -> m Kind -> m Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (Int -> m Kind
forall (m :: * -> *). Quote m => Int -> m Kind
promotedTupleT (Int -> m Kind) -> Int -> m Kind
forall a b. (a -> b) -> a -> b
$ [m Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [m Kind]
ts) [m Kind]
ts

tupleKind :: [Kind] -> Kind
tupleKind :: [Kind] -> Kind
tupleKind [Kind]
ks = (Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
appK (Int -> Kind
tupleK (Int -> Kind) -> Int -> Kind
forall a b. (a -> b) -> a -> b
$ [Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
ks) [Kind]
ks

varNames :: [String]
varNames :: [String]
varNames = ((Char -> String -> String
forall a. a -> [a] -> [a]
: String
"") (Char -> String) -> String -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char
'a' .. Char
'z']) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
	[ String
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c] | String
cs <- [String]
varNames, Char
c <- [Char
'a' .. Char
'z'] ]

kindNames :: [String]
kindNames :: [String]
kindNames = (Char
'k' Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> [Int] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0 :: Int ..]