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

module Data.SwizzleLens.TH (swizzleLens) where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.Maybe
import Data.List qualified as L
import Data.Char
import Data.SwizzleLens.Pkg qualified as Pkg
import Template.Tools

swizzleLens :: String -> String -> DecsQ
swizzleLens :: String -> String -> DecsQ
swizzleLens 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` (Char -> Char
xyzAbc (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ->
	String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f" 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
f ->
	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 -> Q Dec
forall a b. (a -> b) -> a -> b
$ [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 (	[	Int -> TypeQ
clsSwizzle (String -> Int
maxIdx String
nm) 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
s ] [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] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++
			[	Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Functor 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
f ]))
		((	[TypeQ] -> TypeQ
tupT' ((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
s) (TypeQ -> TypeQ) -> (Char -> TypeQ) -> Char -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> TypeQ
typX (Char -> TypeQ) -> String -> [TypeQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
nm) TypeQ -> TypeQ -> TypeQ
`arrT`
			Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
f TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` [TypeQ] -> TypeQ
tupT' (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> TypeQ) -> [Name] -> [TypeQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
ab) ) TypeQ -> TypeQ -> TypeQ
`arrT`
		Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
s TypeQ -> TypeQ -> TypeQ
`arrT`
		Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
f TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` TypeQ
xsa)

xyzAbc :: Char -> Char
xyzAbc :: Char -> Char
xyzAbc Char
c = ([Char
'a' .. Char
'z'] String -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!!) (Int -> Char) -> (Maybe Int -> Int) -> Maybe Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Char) -> Maybe Int -> Char
forall a b. (a -> b) -> a -> b
$ Char
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'])

maxIdx :: String -> Int
maxIdx :: String -> Int
maxIdx String
cs = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Maybe Int) -> String -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
	(((Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe Int -> Maybe Int)
-> (Char -> Maybe Int) -> Char -> Maybe 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']))) String
cs

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']))

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
"f" 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
f -> 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
"st" 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
st -> (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` (Char -> Char
xyzAbc (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ->
	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
f, 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
$
				Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
st Q Exp -> Q Exp -> Q Exp
`fmapE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
					([Q Exp] -> Q Exp
tupE' ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (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) -> (Char -> Q Exp) -> Char -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Q Exp
funX (Char -> Q Exp) -> String -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
nm)
				)
			[Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
st [[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]
ab]
				(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
$ ((Q Exp, Q Exp) -> Q Exp -> Q Exp)
-> Q Exp -> [(Q Exp, Q Exp)] -> Q Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Q Exp
x, Q Exp
a) -> (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
a) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Exp
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
s) ([(Q Exp, Q Exp)] -> Q Exp) -> [(Q Exp, Q Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$
					[Q Exp] -> [Q Exp] -> [(Q Exp, Q Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Char -> Q Exp
funSetX (Char -> Q Exp) -> String -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
nm) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
ab))
				[]]]
		]


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

typX :: Char -> TypeQ
typX :: Char -> TypeQ
typX = Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT
	(Name -> TypeQ) -> (Char -> Name) -> Char -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> Name
mkNameG_tc String
Pkg.swizzleClassPkg String
"Data.Swizzle.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

funX :: Char -> ExpQ
funX :: Char -> Q Exp
funX = 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.swizzleClassPkg String
"Data.Swizzle.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
"")

clsSwizzleSet :: Int -> TypeQ
clsSwizzleSet :: Int -> TypeQ
clsSwizzleSet = Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT
	(Name -> TypeQ) -> (Int -> Name) -> Int -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> Name
mkNameG_tc String
Pkg.swizzleSetClassPkg 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

typSetX :: Char -> TypeQ
typSetX :: Char -> TypeQ
typSetX = Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT
	(Name -> TypeQ) -> (Char -> Name) -> Char -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> Name
mkNameG_tc String
Pkg.swizzleSetClassPkg 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

funSetX :: Char -> ExpQ
funSetX :: Char -> Q Exp
funSetX = 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.swizzleSetClassPkg 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
"")