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

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.Pkg

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 [Int -> String -> String -> Q Dec
mkSwizzleSig Int
i String
pfx String
nm, String -> String -> Q Dec
mkSwizzleFun String
pfx String
nm]
	where i :: Int
i = [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 -> Int
unalphabet (Char -> Int) -> String -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
nm

mkSwizzleSig :: Int -> String -> String -> Q Dec
mkSwizzleSig :: Int -> String -> String -> Q Dec
mkSwizzleSig Int
i String
pfx String
nm = 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 Type) -> Q Type -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVarBndr Specificity] -> Q Cxt -> Q Type -> Q Type
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Type -> m Type
forallT [] (Int -> Q Cxt
mkSwizzleSigContext Int
i) (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$
	String -> Name -> Q Type
mkSwizzleSigTup String
nm (String -> Name
mkName String
"a")
	Q Type -> Q Type -> Q Type
`arrT`
	Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (String -> Name
mkName String
"a")
	Q Type -> Q Type -> Q Type
`arrT`
	Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (String -> Name
mkName String
"a")

mkSwizzleSigContext :: Int -> CxtQ
mkSwizzleSigContext :: Int -> Q Cxt
mkSwizzleSigContext Int
i = [Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [Int -> Q Type
clsSwizzle Int
i 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 (String -> Name
mkName String
"a")]

mkSwizzleSigTup :: String -> Name -> TypeQ
mkSwizzleSigTup :: String -> Name -> Q Type
mkSwizzleSigTup String
cs Name
a = [Q Type] -> Q Type
tupT ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ ((Char -> Q Type) -> String -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
cs) \Char
c -> 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
a

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

tupT :: [TypeQ] -> TypeQ
tupT :: [Q Type] -> Q Type
tupT = \case [Q Type
t] -> Q Type
t; [Q Type]
ts -> (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Int -> Q Type
forall (m :: * -> *). Quote m => Int -> m Type
tupleT (Int -> Q Type) -> Int -> Q Type
forall a b. (a -> b) -> a -> b
$ [Q Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
ts) [Q Type]
ts

tupP' :: [PatQ] -> PatQ
tupP' :: [PatQ] -> PatQ
tupP' = \case [PatQ
p] -> PatQ
p; [PatQ]
ps -> [PatQ] -> PatQ
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [PatQ]
ps

unalphabet :: Char -> Int
unalphabet :: Char -> Int
unalphabet Char
c = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Char -> String -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Char
c (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (String
"xyz" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
reverse [Char
'a' .. Char
'w'])) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

infixr 7 `arrT`

arrT :: TypeQ -> TypeQ -> TypeQ
Q Type
t1 arrT :: Q Type -> Q Type -> Q Type
`arrT` Q Type
t2 = Q Type
forall (m :: * -> *). Quote m => m Type
arrowT Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t1 Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t2

mkSwizzleFun :: String -> String -> Q Dec
mkSwizzleFun :: String -> String -> Q Dec
mkSwizzleFun 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 -> 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]
vs ->
	Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> String -> Name
mkFunName String
pfx String
nm) [
	[PatQ] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [[PatQ] -> PatQ
tupP' ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vs] (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
$ String -> [Name] -> ExpQ
mkSwizzleFunTup String
nm [Name]
vs) []
	]

mkSwizzleFunTup :: String -> [Name] -> ExpQ
mkSwizzleFunTup :: String -> [Name] -> ExpQ
mkSwizzleFunTup String
nm [Name]
vs = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 ExpQ -> ExpQ -> ExpQ
comE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (((Char, Name) -> ExpQ) -> [(Char, Name)] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [Name] -> [(Char, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip String
nm [Name]
vs) \(Char
c, Name
v) -> Char -> ExpQ
funX Char
c 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
v

infixr 7 `comE`

comE :: ExpQ -> ExpQ -> ExpQ
ExpQ
e1 comE :: ExpQ -> ExpQ -> ExpQ
`comE` ExpQ
e2 = Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
e1) (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(.)) (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
e2)

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