{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Template.Tools (
	Q, Dec, Name, newName,

	conT, varT, appT, arrT, arrK, eqT, tupT,
	tupT', tupP', tupE',

	sigD, classD, openTypeFamilyD,

	noSig, plainTV, cxt,

	nameSwizzle, nameSwizzleXyz,
	nameGswizzle, nameGxU, nameGxL, nameXU,

	prodT, prodP, prodE

	) where

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

nameSwizzleXyz :: Char -> Name
nameSwizzleXyz :: Char -> Name
nameSwizzleXyz = Int -> Name
nameSwizzle
	(Int -> Name) -> (Char -> Int) -> Char -> Name
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 -> [Char] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`L.elemIndex` ([Char]
"xyz" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char
'a' .. Char
'w']))

nameSwizzle :: Int -> Name
nameSwizzle :: Int -> Name
nameSwizzle = [Char] -> Name
mkName ([Char] -> Name) -> (Int -> [Char]) -> Int -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"SwizzleSet" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show

nameXU :: Int -> Name
nameXU :: Int -> Name
nameXU = [Char] -> Name
mkName ([Char] -> Name) -> (Int -> [Char]) -> Int -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
"") (Char -> [Char]) -> (Int -> Char) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toUpper (Char -> Char) -> (Int -> Char) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
alphabet

eqT :: TypeQ -> TypeQ -> TypeQ
TypeQ
t1 eqT :: TypeQ -> TypeQ -> TypeQ
`eqT` TypeQ
t2 = TypeQ
forall (m :: * -> *). Quote m => m Type
equalityT TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` TypeQ
t1 TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` TypeQ
t2

tupT :: [Name] -> TypeQ
tupT :: [Name] -> TypeQ
tupT [Name]
ns = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Int -> TypeQ
forall (m :: * -> *). Quote m => Int -> m Type
tupleT (Int -> TypeQ) -> Int -> TypeQ
forall a b. (a -> b) -> a -> b
$ [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
ns) ([TypeQ] -> TypeQ) -> [TypeQ] -> TypeQ
forall a b. (a -> b) -> a -> b
$ 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]
ns

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

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

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

nameGswizzle :: Int -> Name
nameGswizzle :: Int -> Name
nameGswizzle = [Char] -> Name
mkName ([Char] -> Name) -> (Int -> [Char]) -> Int -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"GSwizzleSet" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show

nameGxU :: Int -> Name
nameGxU :: Int -> Name
nameGxU Int
i = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"G" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char -> Char
toUpper (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$ Int -> Char
alphabet Int
i]

nameGxL :: Int -> Name
nameGxL :: Int -> Name
nameGxL Int
i = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"g" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int -> Char
alphabet Int
i]

infixr 9 `prodT`, `prodE`, `prodP`

prodT :: TypeQ -> TypeQ -> TypeQ
TypeQ
t1 prodT :: TypeQ -> TypeQ -> TypeQ
`prodT` TypeQ
t2 = Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT ''(:*:) TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` TypeQ
t1 TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` TypeQ
t2

prodE :: ExpQ -> ExpQ -> ExpQ
ExpQ
e1 prodE :: ExpQ -> ExpQ -> ExpQ
`prodE` ExpQ
e2 = Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE '(:*:) ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
e1 ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
e2

prodP :: PatQ -> PatQ -> PatQ
PatQ
p1 prodP :: PatQ -> PatQ -> PatQ
`prodP` PatQ
p2 = PatQ -> Name -> PatQ -> PatQ
forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
infixP PatQ
p1 '(:*:) PatQ
p2

alphabet :: Int -> Char
alphabet :: Int -> Char
alphabet Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
26 = [Char] -> Char
forall a. HasCallStack => [Char] -> a
error ([Char] -> Char) -> [Char] -> Char
forall a b. (a -> b) -> a -> b
$ [Char]
"no such alphabet: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
alphabet Int
i = (([Char]
"xyz" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char
'a' .. Char
'w']) [Char] -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!!) (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 Int
i

infixr 7 `arrT`

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

infixr 6 `arrK`

arrK :: Kind -> Kind -> Kind
Type
k1 arrK :: Type -> Type -> Type
`arrK` Type
k2 = Type
arrowK Type -> Type -> Type
`appK` Type
k1 Type -> Type -> Type
`appK` Type
k2