{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall -fno-warn-tabs #-} module Data.SwizzleModify.TH (swizzleModify) where import Language.Haskell.TH import Language.Haskell.TH.Syntax import Data.Maybe import Data.List qualified as L import Data.Char import Data.SwizzleModify.Pkg qualified as Pkg import Template.Tools swizzleModify :: String -> String -> DecsQ swizzleModify :: String -> String -> DecsQ swizzleModify 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` String -> String xyab 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 -> 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 -> TypeQ) -> TypeQ -> Q Dec forall b c a. (b -> c) -> (a -> b) -> a -> c . [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 ( (TypeQ -> TypeQ -> TypeQ) -> [TypeQ] -> [TypeQ] -> [TypeQ] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith TypeQ -> TypeQ -> TypeQ forall (m :: * -> *). Quote m => m Type -> m Type -> m Type appT (Int -> TypeQ clsSwizzle (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] ysbs [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 -> Q Dec) -> TypeQ -> Q Dec forall a b. (a -> b) -> a -> b $ [TypeQ] -> TypeQ tupT' (((Char, (TypeQ, Name)) -> TypeQ) -> [(Char, (TypeQ, Name))] -> [TypeQ] forall a b. (a -> b) -> [a] -> [b] map (\(Char x, (TypeQ ysb', Name a')) -> Char -> TypeQ typX Char x TypeQ -> TypeQ -> TypeQ forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` TypeQ ysb' TypeQ -> TypeQ -> TypeQ `arrT` Name -> TypeQ forall (m :: * -> *). Quote m => Name -> m Type varT Name a') (String nm String -> [(TypeQ, Name)] -> [(Char, (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 `arrT` Name -> TypeQ forall (m :: * -> *). Quote m => Name -> m Type varT Name s TypeQ -> TypeQ -> TypeQ `arrT` TypeQ xsa 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'])) xyab :: String -> String xyab :: String -> String xyab String xy = ([Char 'a' .. Char 'z'] String -> Int -> Char forall a. HasCallStack => [a] -> Int -> a !!) (Int -> Char) -> (Char -> Int) -> Char -> Char 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'])) (Char -> Char) -> String -> String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String xy 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 -> Q Name) -> (Char -> String) -> Char -> Q Name forall b c a. (b -> c) -> (a -> b) -> a -> c . (Char 'm' Char -> String -> String forall a. a -> [a] -> [a] :) (String -> String) -> (Char -> String) -> Char -> String 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] ms -> 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 [[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] ms] (Q Exp -> Q Body forall (m :: * -> *). Quote m => m Exp -> m Body normalB (Q Exp -> Q Body) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Body forall b c a. (b -> c) -> (a -> b) -> a -> c . (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp forall a. (a -> a -> a) -> [a] -> a forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a foldr1 Q Exp -> Q Exp -> Q Exp comE ([Q Exp] -> Q Body) -> [Q Exp] -> Q Body forall a b. (a -> b) -> a -> b $ (Char -> Name -> Q Exp) -> String -> [Name] -> [Q Exp] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith (\Char x Name m -> Char -> Q Exp funBX Char 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 m) String nm [Name] ms) [] ] funBX :: Char -> ExpQ funBX :: Char -> Q Exp funBX = 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.swizzleModifyBasePkg String "Data.SwizzleModify.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 "")