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