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

module Data.SwizzleModify.TH (swizzleModify) where

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

import Data.SwizzleModify.Pkg qualified as Pkg
import Template.Tools

swizzleModify :: String -> String -> DecsQ
swizzleModify :: String -> String -> DecsQ
swizzleModify 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
tdXy String
pfx String
nm, String -> String -> Q Dec
fnXy String
pfx String
nm]

mkFunName :: String -> String -> Name
mkFunName :: String -> String -> Name
mkFunName String
"" String
nm = String -> Name
mkName String
nm
mkFunName String
pfx (Char
c : String
cs) = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
pfx String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> Char
toUpper Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
mkFunName String
_ String
"" = String -> Name
forall a. HasCallStack => String -> a
error String
"bad"

tdXy :: String -> String -> DecQ
tdXy :: String -> String -> Q Dec
tdXy 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) -> (Char -> String) -> Char -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> String
forall a. a -> [a] -> [a]
: String
"")) (Char -> 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` String -> String
xyab String
nm 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]
ab ->
	let	TypeQ
xsa : [TypeQ]
ysbs = Name -> String -> [Name] -> [TypeQ]
swzsList Name
s String
nm [Name]
ab in
	Name -> TypeQ -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD (String -> String -> Name
mkFunName String
pfx String
nm)
		(TypeQ -> Q Dec) -> (TypeQ -> TypeQ) -> TypeQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVarBndr Specificity] -> Q Cxt -> TypeQ -> TypeQ
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Type -> m Type
forallT [] ([TypeQ] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt (
			(TypeQ -> TypeQ -> TypeQ) -> [TypeQ] -> [TypeQ] -> [TypeQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Int -> TypeQ
clsSwizzle (Int -> TypeQ) -> [Int] -> [TypeQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Int
idx (Char -> Int) -> String -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
nm)) [TypeQ]
ysbs [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++
			((TypeQ, (TypeQ, Name)) -> TypeQ)
-> [(TypeQ, (TypeQ, Name))] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(TypeQ
cs, (TypeQ
ysb', Name
a')) -> TypeQ
cs TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` TypeQ
ysb' TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
a')
				((Int -> TypeQ
clsSwizzleSet (Int -> TypeQ) -> [Int] -> [TypeQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Int
idx (Char -> Int) -> String -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
nm)) [TypeQ] -> [(TypeQ, Name)] -> [(TypeQ, (TypeQ, Name))]
forall a b. [a] -> [b] -> [(a, b)]
`zip` ([TypeQ]
ysbs [TypeQ] -> [Name] -> [(TypeQ, Name)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Name]
ab))))
		(TypeQ -> Q Dec) -> TypeQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ [TypeQ] -> TypeQ
tupT' (((Char, (TypeQ, Name)) -> TypeQ)
-> [(Char, (TypeQ, Name))] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(Char
x, (TypeQ
ysb', Name
a')) -> Char -> TypeQ
typX Char
x TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` TypeQ
ysb' TypeQ -> TypeQ -> TypeQ
`arrT` Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
a')
				(String
nm String -> [(TypeQ, Name)] -> [(Char, (TypeQ, Name))]
forall a b. [a] -> [b] -> [(a, b)]
`zip` ([TypeQ]
ysbs [TypeQ] -> [Name] -> [(TypeQ, Name)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Name]
ab)))
			TypeQ -> TypeQ -> TypeQ
`arrT` Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
s TypeQ -> TypeQ -> TypeQ
`arrT` TypeQ
xsa

idx :: Char -> Int
idx :: Char -> Int
idx = (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']))

xyab :: String -> String
xyab :: String -> String
xyab String
xy = ([Char
'a' .. Char
'z'] String -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!!) (Int -> Char) -> (Char -> Int) -> Char -> Char
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'])) (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
xy

swzsList :: Name -> String -> [Name] -> [TypeQ]
swzsList :: Name -> String -> [Name] -> [TypeQ]
swzsList Name
s String
xyz [Name]
abc = ((Char, Name) -> TypeQ -> TypeQ)
-> TypeQ -> [(Char, Name)] -> [TypeQ]
forall a b. (a -> b -> b) -> b -> [a] -> [b]
scanr
	(\(Char
x, Name
a) TypeQ
t -> Char -> TypeQ
typSetX Char
x TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` TypeQ
t TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
a) (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
s) (String -> [Name] -> [(Char, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip String
xyz [Name]
abc)

fnXy :: String -> String -> DecQ
fnXy :: String -> String -> Q Dec
fnXy String
pfx String
nm = (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> (Char -> String) -> Char -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'm' Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Char -> String) -> Char -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> String
forall a. a -> [a] -> [a]
: String
"")) (Char -> 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` String
nm 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]
ms ->
	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 [[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]
ms]
			(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Exp -> Q Exp -> Q Exp
comE ([Q Exp] -> Q Body) -> [Q Exp] -> Q Body
forall a b. (a -> b) -> a -> b
$ (Char -> Name -> Q Exp) -> String -> [Name] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Char
x Name
m -> Char -> Q Exp
funBX Char
x 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) String
nm [Name]
ms) [] ]

funBX :: Char -> ExpQ
funBX :: Char -> Q Exp
funBX = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (Char -> Name) -> Char -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> Name
mkNameG_v String
Pkg.swizzleModifyBasePkg String
"Data.SwizzleModify.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
"")