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

module Data.Swizzle.TH (swizzle) where

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

import Data.Swizzle.Class.Pkg

swizzle :: String -> String -> DecsQ
swizzle :: String -> String -> DecsQ
swizzle 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

mkFunName :: String -> String -> Name
mkFunName :: String -> String -> Name
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) -> (Char -> Char) -> Bool -> Char -> Char
forall a. a -> a -> Bool -> a
bool Char -> Char
toUpper Char -> Char
forall a. a -> a
id (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
pfx) Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs

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
$ Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (String -> Name
mkName String
"a") Q Type -> Q Type -> Q Type
`arrT` String -> Name -> Q Type
mkSwizzleSigTup String
nm (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.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

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.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
"")

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

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

tupE' :: [ExpQ] -> ExpQ
tupE' :: [ExpQ] -> ExpQ
tupE' = \case [ExpQ
e] -> ExpQ
e; [ExpQ]
es -> [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [ExpQ]
es

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

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
"a" 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
a -> 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
a] (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
a) [] ]

mkSwizzleFunTup :: String -> Name -> ExpQ
mkSwizzleFunTup :: String -> Name -> ExpQ
mkSwizzleFunTup String
nm Name
a = [ExpQ] -> ExpQ
tupE' ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ((Char -> ExpQ) -> String -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
nm) \Char
c -> 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
a