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

module Data.TypeLevel.Tuple.Index.TH (mkI, mkITup, mTupIndices) where

import Data.List qualified as L
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 ..]

mkITup :: [Int] -> Int -> DecQ
mkITup :: [Int] -> Int -> DecQ
mkITup [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 -> Name -> [Name] -> [Name] -> [Int] -> DecQ
bazRaw Name
nm Name
xyzs [Name]
ks [Name]
vs [Int]
is
	where
	nm :: Name
nm = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"I" 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] -> [Int] -> DecQ
bazRaw :: Name -> Name -> [Name] -> [Name] -> [Int] -> DecQ
bazRaw Name
tn Name
xyzs [Name]
ks [Name]
vs [Int]
is = 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
xyzs (Kind -> TyVarBndr ())
-> ([Kind] -> Kind) -> [Kind] -> TyVarBndr ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Kind] -> Kind
tuple' ([Kind] -> TyVarBndr ()) -> [Kind] -> TyVarBndr ()
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
promotedTuple (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))
			([Q Kind] -> Q Kind
promotedTuple (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT (Name -> Q Kind) -> (Int -> Name) -> Int -> Q Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Name]
vs [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!!) (Int -> Q Kind) -> [Int] -> [Q Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
is))
		]

tuple' :: [Kind] -> Kind
tuple' :: [Kind] -> Kind
tuple' [Kind]
ts = (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]
ts) [Kind]
ts

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

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]

combinations :: [a] -> [[a]]
combinations :: forall a. [a] -> [[a]]
combinations [] = [[]]
combinations (a
x : [a]
xs) = ((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) [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [a] -> [[a]]
forall a. [a] -> [[a]]
combinations [a]
xs
-- combinations (x : xs) = combinations xs ++ ((x :) <$> combinations xs)