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

module Data.SwizzleModify.Base.TH where

import Language.Haskell.TH

import Data.Swizzle.Class qualified as Swz
import Data.SwizzleSet.Class qualified as SwzS
import Template.Tools

mkX0 :: DecsQ
mkX0 :: DecsQ
mkX0 = [d|
	x :: (Swz.Swizzle1 s, SwzS.SwizzleSet1 s b) => (Swz.X s -> b) -> s -> Swz.X s b
	x m s = SwzS.x s (m (Swz.x s))
	|]

mkX :: Int -> DecsQ
mkX :: Int -> DecsQ
mkX Int
n = [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Int -> Char -> Q Dec
tdX Int
n Char
c, Char -> Q Dec
fnX Char
c]
	where c :: Char
c = (String
"xyz" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
reverse [Char
'a' .. Char
'w']) String -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!! (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

tdX :: Int -> Char -> DecQ
tdX :: Int -> Char -> Q Dec
tdX Int
n Char
c = String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"s" Q Name -> (Name -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
s -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"b" Q Name -> (Name -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
b ->
	Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
"") (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$
		[TyVarBndr Specificity] -> Q Cxt -> Q Type -> Q Type
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Type -> m Type
forallT []
			([Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [
				Int -> Q Type
clsSwizzle Int
n 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
s,
				Int -> Q Type
clsSwizzleSet Int
n 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
s 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
b
				])
			((Char -> Q Type
typX Char
c 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
s Q Type -> Q Type -> Q Type
`arrT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
b) Q Type -> Q Type -> Q Type
`arrT`
				Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
s Q Type -> Q Type -> Q Type
`arrT`
				Char -> Q Type
typSetX Char
c 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
s 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
b)

fnX :: Char -> DecQ
fnX :: Char -> Q Dec
fnX Char
c = String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"m" Q Name -> (Name -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
m -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"s" Q Name -> (Name -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
s ->
	Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
"") [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
		[Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
m, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
s]
		(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$
			Char -> Q Exp
funSetX Char
c Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
				Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
s Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
				(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
m Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Char -> Q Exp
funX Char
c Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
s)))
		[]]