{-# 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