{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Data.TypeLevel.Tuple.MapIndex.TH (mkM, mkMTup, mTupIndices) where

import Language.Haskell.TH
import Data.List qualified as L

vars :: [String]
vars :: [String]
vars = Int -> [String]
mkVar (Int -> [String]) -> [Int] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
`concatMap` [Int
1 ..]
	where
	mkVar :: Int -> [String]
	mkVar :: Int -> [String]
mkVar Int
0 = [String
""]
	mkVar Int
n = [ String
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c] | String
cs <- Int -> [String]
mkVar (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1), Char
c <- [Char
'a' .. Char
'z'] ]

names :: [Q Name]
names :: [Q Name]
names = String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> [String] -> [Q Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
vars

mkM :: Int -> Int -> Q Dec
mkM :: Int -> Int -> Q Dec
mkM Int
i Int
n = Name -> Int -> [Q Name] -> Q Dec
mkFoo' (String -> Name
mkName String
nm) Int
i (Int -> [Q Name] -> [Q Name]
forall a. Int -> [a] -> [a]
take Int
n [Q Name]
names) -- [varT $ mkName "a", varT $ mkName "b"]
	where
	nm :: String
nm = Char
'M' Char -> 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

mkFoo' :: Name -> Int -> [Q Name] -> Q Dec
mkFoo' :: Name -> Int -> [Q Name] -> Q Dec
mkFoo' Name
nm Int
i [Q Name]
nms = do
	[Type]
ts <- (Name -> Type
VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ([Name] -> [Type]) -> Q [Name] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Name] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q Name]
nms
	[Q Type]
ts' <- (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> [Name] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ([Name] -> [Q Type]) -> Q [Name] -> Q [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Name] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q Name]
nms
	Name
-> [TyVarBndr ()]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> [Q TySynEqn]
-> Q Dec
forall (m :: * -> *).
Quote m =>
Name
-> [TyVarBndr ()]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> [m TySynEqn]
-> m Dec
closedTypeFamilyD Name
nm
		[	Name -> Type -> TyVarBndr ()
kindedTV (String -> Name
mkName String
"tpl") (Type
ListT Type -> Type -> Type
`AppT` [Type] -> Type
tuple [Type]
ts) ] -- [VarT $ mkName "a", VarT $ mkName "b"]) ]
		(Type -> FamilyResultSig
KindSig (Type -> FamilyResultSig) -> Type -> FamilyResultSig
forall a b. (a -> b) -> a -> b
$ Type
ListT Type -> Type -> Type
`AppT` ([Type]
ts [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! Int
i))
		Maybe InjectivityAnn
forall a. Maybe a
Nothing
		[	Maybe [TyVarBndr ()] -> Q Type -> Q Type -> Q TySynEqn
forall (m :: * -> *).
Quote m =>
Maybe [TyVarBndr ()] -> m Type -> m Type -> m TySynEqn
tySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
nm Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
forall (m :: * -> *). Quote m => m Type
promotedNilT) Q Type
forall (m :: * -> *). Quote m => m Type
promotedNilT,
			Maybe [TyVarBndr ()] -> Q Type -> Q Type -> Q TySynEqn
forall (m :: * -> *).
Quote m =>
Maybe [TyVarBndr ()] -> m Type -> m Type -> m TySynEqn
tySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
nm Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` [Q Type] -> Q Type
bar [Q Type]
ts')
				(Q Type -> Q TySynEqn) -> Q Type -> Q TySynEqn
forall a b. (a -> b) -> a -> b
$ Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT '(:) Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` ([Q Type]
ts' [Q Type] -> Int -> Q Type
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
nm Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (String -> Name
mkName String
"rst"))
			]

bar :: [TypeQ] -> TypeQ
bar :: [Q Type] -> Q Type
bar [Q Type]
ts = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT '(:) Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` [Q Type] -> Q Type
promotedTuple [Q Type]
ts Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"rst")

tuple :: [Type] -> Type
tuple :: [Type] -> Type
tuple [Type]
ts = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT (Int -> Type) -> Int -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts) [Type]
ts

tuple' :: [Kind] -> Kind
tuple' :: [Type] -> Type
tuple' [Type]
ts = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
appK (Int -> Type
tupleK (Int -> Type) -> Int -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts) [Type]
ts

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

mkMTup :: [Int] -> Int -> DecQ
mkMTup :: [Int] -> Int -> Q Dec
mkMTup [Int]
is Int
n = do
	Name
xyzs <- 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]
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]
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
rst <- 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 -> Name -> [Name] -> [Name] -> Name -> [Int] -> Q Dec
bazRaw Name
nm Name
xyzs [Name]
ks [Name]
vs Name
rst [Int]
is
	where
	nm :: Name
nm = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"M" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"'" (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]
is) 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

bazRaw :: Name -> Name -> [Name] -> [Name] -> Name -> [Int] -> DecQ
bazRaw :: Name -> Name -> [Name] -> [Name] -> Name -> [Int] -> Q Dec
bazRaw Name
tn Name
xyzs [Name]
ks [Name]
vs Name
rst [Int]
is = Name
-> [TyVarBndr ()]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> [Q TySynEqn]
-> Q Dec
forall (m :: * -> *).
Quote m =>
Name
-> [TyVarBndr ()]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> [m TySynEqn]
-> m Dec
closedTypeFamilyD Name
tn
	[Name -> Type -> TyVarBndr ()
kindedTV Name
xyzs (Type -> TyVarBndr ()) -> Type -> TyVarBndr ()
forall a b. (a -> b) -> a -> b
$ Type
listK Type -> Type -> Type
`appK` ([Type] -> Type
tuple' ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
varK (Name -> Type) -> [Name] -> [Type]
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 Type -> Q Type -> Q TySynEqn
forall (m :: * -> *).
Quote m =>
Maybe [TyVarBndr ()] -> m Type -> m Type -> m TySynEqn
tySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing
			(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tn Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
forall (m :: * -> *). Quote m => m Type
promotedNilT)
			Q Type
forall (m :: * -> *). Quote m => m Type
promotedNilT,
		Maybe [TyVarBndr ()] -> Q Type -> Q Type -> Q TySynEqn
forall (m :: * -> *).
Quote m =>
Maybe [TyVarBndr ()] -> m Type -> m Type -> m TySynEqn
tySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing
			(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tn Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (
				[Q Type] -> Q Type
promotedTuple (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> [Name] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vs) Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`promotedConsType`
					Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
rst ))
			([Q Type] -> Q Type
promotedTuple (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> (Int -> Name) -> Int -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Name]
vs [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!!) (Int -> Q Type) -> [Int] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
is) Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`promotedConsType`
				(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tn Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
rst))
		]

promotedConsType :: Quote m => m Type -> m Type -> m Type
promotedConsType :: forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
promotedConsType m Type
a m Type
as = m Type
forall (m :: * -> *). Quote m => m Type
promotedConsT m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` m Type
a m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` m Type
as

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

combinations :: [a] -> [[a]]
combinations :: forall a. [a] -> [[a]]
combinations [] = [[]]
combinations (a
x : [a]
xs) = [a] -> [[a]]
forall a. [a] -> [[a]]
combinations [a]
xs [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ ((a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> [[a]] -> [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> [[a]]
forall a. [a] -> [[a]]
combinations [a]
xs)

mTupIndices :: Int -> [[Int]]
mTupIndices :: Int -> [[Int]]
mTupIndices Int
n = ([Int] -> Bool) -> [[Int]] -> [[Int]]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int
0, Int
1, Int
n]) (Int -> Bool) -> ([Int] -> Int) -> [Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ [Int] -> [[Int]]
forall a. [a] -> [[a]]
combinations [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]