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

module Data.TypeLevel.Tuple.Uncurry.TH (uc, showUc) where

import Language.Haskell.TH

uc :: Int -> DecQ
uc :: Int -> DecQ
uc Int
n = do
	Name
t <- Q Name
mkT
	[Name]
ss <- Int -> Q [Name]
mkSs Int
n
	Q Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [Q Con]
-> [Q DerivClause]
-> DecQ
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) (Int -> Name
ucName Int
n)
		[	Name -> TyVarBndr ()
plainTV (String -> Name
mkName String
"t"), Name -> TyVarBndr ()
plainTV (String -> Name
mkName String
"ss") ]
		Maybe Kind
forall a. Maybe a
Nothing
		[	[Name] -> [Q VarStrictType] -> Q Kind -> Q Con
forall (m :: * -> *).
Quote m =>
[Name] -> [m VarStrictType] -> m Kind -> m Con
recGadtC
				[Int -> Name
ucName Int
n]
				[	Name -> Q BangType -> Q VarStrictType
forall (m :: * -> *).
Quote m =>
Name -> m BangType -> m VarStrictType
varBangType (Int -> Name
ucUnName Int
n) (
						(,)	(Bang -> Kind -> BangType) -> Q Bang -> Q (Kind -> BangType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Bang
noSourceBang
							Q (Kind -> BangType) -> Q Kind -> Q BangType
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> [Name] -> Q Kind
crrType Name
t [Name]
ss)]
				(	Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT (Int -> Name
ucName Int
n)
						Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
t
						Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` [Name] -> Q Kind
ucrrType [Name]
ss ) ]
		[]

noSourceBang :: BangQ
noSourceBang :: Q Bang
noSourceBang = Q SourceUnpackedness -> Q SourceStrictness -> Q Bang
forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang Q SourceUnpackedness
forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness Q SourceStrictness
forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness

showUc :: Int -> DecQ
showUc :: Int -> DecQ
showUc Int
n = do
	Name
t <- Q Name
mkT
	[Name]
ss <- Int -> Q [Name]
mkSs Int
n
	Q Cxt -> Q Kind -> DecQ
forall (m :: * -> *). Quote m => m Cxt -> m Kind -> m Dec
standaloneDerivD
		([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt [	Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Show Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` Name -> [Name] -> Q Kind
crrType Name
t [Name]
ss ])
		(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Show Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` (
			Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT (Int -> Name
ucName Int
n)
				Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
t Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` [Name] -> Q Kind
ucrrType [Name]
ss ))

ucName :: Int -> Name
ucName :: Int -> Name
ucName = String -> Name
mkName (String -> Name) -> (Int -> String) -> Int -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"U" String -> 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

ucUnName :: Int -> Name
ucUnName :: Int -> Name
ucUnName = String -> Name
mkName (String -> Name) -> (Int -> String) -> Int -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"unU" String -> 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

mkT :: Q Name
mkT :: Q Name
mkT = String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"

mkSs :: Int -> Q [Name]
mkSs :: Int -> Q [Name]
mkSs Int
n = (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"s" String -> 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 -> Q Name) -> [Int] -> 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
1 .. Int
n]

crrType :: Name -> [Name] -> TypeQ
crrType :: Name -> [Name] -> Q Kind
crrType Name
t = (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 (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
t) ([Q Kind] -> Q Kind) -> ([Name] -> [Q Kind]) -> [Name] -> Q Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT -- varT t `appT` varT (mkName "s1") `appT` varT (mkName "s2")

ucrrType :: [Name] -> Q Type
ucrrType :: [Name] -> Q Kind
ucrrType = [Name] -> Q Kind
pTupTN -- pTupT2 (varT $ mkName "s1") (varT $ mkName "s2")

pTupTN :: [Name] -> TypeQ
pTupTN :: [Name] -> Q Kind
pTupTN [Name]
ns = (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
$ [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
ns) ([Q Kind] -> Q Kind) -> [Q Kind] -> Q Kind
forall a b. (a -> b) -> a -> b
$ (Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT [Name]
ns