{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments #-}

module Data.SwizzleSet.TH (swizzleSet) where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.Maybe
import Data.List qualified as L
import Data.Char

import Data.SwizzleSet.Class ()
import Data.SwizzleSet.Class.Pkg
import Template.Tools

swizzleSet :: String -> String -> DecsQ
swizzleSet :: String -> String -> DecsQ
swizzleSet String
pfx String
nm = [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 [String -> String -> Q Dec
xyzttd String
pfx String
nm, String -> String -> Q Dec
xyztfn String
pfx String
nm]

xyzttd :: String -> String -> DecQ
xyzttd :: String -> String -> Q Dec
xyzttd String
pfx String
nm = 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 -> 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` ((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
<$> String
uvws) 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]
uvw ->
	Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD (String -> String -> Name
mkFunName String
pfx String
nm) (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 ((Q Type -> Q Type -> Q Type) -> [Q Type] -> [Q Type] -> [Q Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT ((Q Type -> Q Type -> Q Type) -> [Q Type] -> [Q Type] -> [Q Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT
				(Char -> Q Type
clsSwizzleXyz (Char -> Q Type) -> String -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
nm) ([Q Type] -> [Q Type]
forall a. HasCallStack => [a] -> [a]
tail ([Q Type] -> [Q Type]) -> [Q Type] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ ((Q Type, Q Type) -> Q Type -> Q Type)
-> Q Type -> [(Q Type, Q Type)] -> [Q Type]
forall a b. (a -> b -> b) -> b -> [a] -> [b]
scanr (Q Type, Q Type) -> Q Type -> Q Type
forall {m :: * -> *}.
Quote m =>
(m Type, m Type) -> m Type -> m Type
go (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
s) ([(Q Type, Q Type)] -> [Q Type]) -> [(Q Type, Q Type)] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ [Name] -> [(Q Type, Q Type)]
forall {m :: * -> *}. Quote m => [Name] -> [(Q Type, m Type)]
pairs [Name]
uvw)) (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]
uvw)))
			(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
s Q Type -> Q Type -> Q Type
`arrT` [Q Type] -> Q Type
tupT' (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]
uvw) Q Type -> Q Type -> Q Type
`arrT`
				((Q Type, Q Type) -> Q Type -> Q Type)
-> Q Type -> [(Q Type, Q Type)] -> Q Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Q Type, Q Type) -> Q Type -> Q Type
forall {m :: * -> *}.
Quote m =>
(m Type, m Type) -> m Type -> m Type
go (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
s) ([Name] -> [(Q Type, Q Type)]
forall {m :: * -> *}. Quote m => [Name] -> [(Q Type, m Type)]
pairs [Name]
uvw))
	where
	go :: (m Type, m Type) -> m Type -> m Type
go (m Type
xu, m Type
ul) = (m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` m Type
ul) (m Type -> m Type) -> (m Type -> m Type) -> m Type -> m Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m Type
xu m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`)
	pairs :: [Name] -> [(Q Type, m Type)]
pairs [Name]
uvw = [Q Type] -> [m Type] -> [(Q Type, m Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Char -> Q Type
typX (Char -> Q Type) -> String -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
nm) (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> m Type) -> [Name] -> [m Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
uvw)
	uvws :: String
uvws = String -> String -> Char -> Char
forall a b. Eq a => [a] -> [b] -> a -> b
crrPos (String
"xyz" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
reverse [Char
'a' .. Char
'w']) (String
"uvwxyz" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
reverse [Char
'a' .. Char
't']) (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
nm

clsSwizzleXyz :: Char -> TypeQ
clsSwizzleXyz :: Char -> Q Type
clsSwizzleXyz = Int -> Q Type
clsSwizzle
	(Int -> Q Type) -> (Char -> Int) -> Char -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> (Char -> Maybe Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`L.elemIndex` (String
"xyz" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
reverse [Char
'a' .. Char
'w']))

clsSwizzle :: Int -> TypeQ
clsSwizzle :: Int -> Q Type
clsSwizzle = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> (Int -> Name) -> Int -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> Name
mkNameG_tc String
swizzleClassPkg String
"Data.SwizzleSet.Class.Base" (String -> Name) -> (Int -> String) -> Int -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"SwizzleSet" 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

funX :: Char -> ExpQ
funX :: Char -> ExpQ
funX = Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> ExpQ) -> (Char -> Name) -> Char -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> Name
mkNameG_v String
swizzleClassPkg String
"Data.SwizzleSet.Class.Base" (String -> Name) -> (Char -> String) -> Char -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> String
forall a. a -> [a] -> [a]
: String
"")

typX :: Char -> TypeQ
typX :: Char -> Q Type
typX = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> (Char -> Name) -> Char -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> Name
mkNameG_tc String
swizzleClassPkg String
"Data.SwizzleSet.Class.Base" (String -> Name) -> (Char -> String) -> Char -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> String
forall a. a -> [a] -> [a]
: String
"") (Char -> String) -> (Char -> Char) -> Char -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toUpper

crrPos :: Eq a => [a] -> [b] -> a -> b
crrPos :: forall a b. Eq a => [a] -> [b] -> a -> b
crrPos [a]
xs [b]
ys a
x = [b]
ys [b] -> Int -> b
forall a. HasCallStack => [a] -> Int -> a
!! Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (a
x a -> [a] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`L.elemIndex` [a]
xs)

xyztfn :: String -> String -> DecQ
xyztfn :: String -> String -> Q Dec
xyztfn String
pfx String
nm =
	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 -> 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` ((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
<$> String
uvws) 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]
uvw ->
	Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> String -> Name
mkFunName String
pfx String
nm) [
		[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
s, [Q Pat] -> Q Pat
tupP' ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> Q Pat) -> [Name] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
uvw] (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (ExpQ -> Q Body) -> ExpQ -> Q Body
forall a b. (a -> b) -> a -> b
$
			((ExpQ, ExpQ) -> ExpQ -> ExpQ) -> ExpQ -> [(ExpQ, ExpQ)] -> ExpQ
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(ExpQ
xl, ExpQ
ul) -> (ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
ul) (ExpQ -> ExpQ) -> (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExpQ
xl ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`)) (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
s) ([(ExpQ, ExpQ)] -> ExpQ) -> [(ExpQ, ExpQ)] -> ExpQ
forall a b. (a -> b) -> a -> b
$
				[ExpQ] -> [ExpQ] -> [(ExpQ, ExpQ)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Char -> ExpQ
funX (Char -> ExpQ) -> String -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
nm) (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
uvw)
--				zip (varE . mkName <$> ((: "") <$> nm)) (varE <$> uvw)
			) [] ]
	where
	uvws :: String
uvws = String -> String -> Char -> Char
forall a b. Eq a => [a] -> [b] -> a -> b
crrPos (String
"xyz" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
reverse [Char
'a' .. Char
'w']) (String
"uvwxyz" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
reverse [Char
'a' .. Char
't']) (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
nm

mkFunName :: String -> String -> Name
mkFunName :: String -> String -> Name
mkFunName String
pfx String
nm = String -> Name
mkName case String
pfx of
	String
"" -> String
nm;
	String
_ -> case String
nm of Char
h : String
t -> String
pfx String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> Char
toUpper Char
h Char -> String -> String
forall a. a -> [a] -> [a]
: String
t; String
_ -> String
pfx