{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# OPTIONS_GHC -Wall -fno-warn-tabs #-} module Data.SwizzleLens.TH (swizzleLens) where import Language.Haskell.TH import Language.Haskell.TH.Syntax import Data.Maybe import Data.List qualified as L import Data.Char import Data.SwizzleLens.Pkg qualified as Pkg import Template.Tools swizzleLens :: String -> String -> DecsQ swizzleLens :: String -> String -> DecsQ swizzleLens 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` (Char -> Char xyzAbc (Char -> Char) -> String -> String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> 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 -> String -> Q Name forall (m :: * -> *). Quote m => String -> m Name newName String "f" 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 f -> 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 -> Q Dec forall a b. (a -> b) -> a -> b $ [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 ( [ Int -> TypeQ clsSwizzle (String -> Int maxIdx String nm) 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 s ] [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] -> [TypeQ] -> [TypeQ] forall a. [a] -> [a] -> [a] ++ [ Name -> TypeQ forall (m :: * -> *). Quote m => Name -> m Type conT ''Functor 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 f ])) (( [TypeQ] -> TypeQ tupT' ((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 s) (TypeQ -> TypeQ) -> (Char -> TypeQ) -> Char -> TypeQ forall b c a. (b -> c) -> (a -> b) -> a -> c . Char -> TypeQ typX (Char -> TypeQ) -> String -> [TypeQ] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String nm) TypeQ -> TypeQ -> TypeQ `arrT` Name -> TypeQ forall (m :: * -> *). Quote m => Name -> m Type varT Name f TypeQ -> TypeQ -> TypeQ forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` [TypeQ] -> TypeQ tupT' (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] ab) ) TypeQ -> TypeQ -> TypeQ `arrT` Name -> TypeQ forall (m :: * -> *). Quote m => Name -> m Type varT Name s TypeQ -> TypeQ -> TypeQ `arrT` Name -> TypeQ forall (m :: * -> *). Quote m => Name -> m Type varT Name f TypeQ -> TypeQ -> TypeQ forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` TypeQ xsa) xyzAbc :: Char -> Char xyzAbc :: Char -> Char xyzAbc Char c = ([Char 'a' .. Char 'z'] String -> Int -> Char forall a. HasCallStack => [a] -> Int -> a !!) (Int -> Char) -> (Maybe Int -> Int) -> Maybe Int -> Char forall b c a. (b -> c) -> (a -> b) -> a -> c . Maybe Int -> Int forall a. HasCallStack => Maybe a -> a fromJust (Maybe Int -> Char) -> Maybe Int -> Char forall a b. (a -> b) -> a -> b $ Char 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']) maxIdx :: String -> Int maxIdx :: String -> Int maxIdx String cs = [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 -> Maybe Int) -> String -> [Int] forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe (((Int -> Int -> Int forall a. Num a => a -> a -> a + Int 1) (Int -> Int) -> Maybe Int -> Maybe Int forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$>) (Maybe Int -> Maybe Int) -> (Char -> Maybe Int) -> Char -> Maybe 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']))) String cs 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'])) 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 "f" 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 f -> 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 "st" 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 st -> (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` (Char -> Char xyzAbc (Char -> Char) -> String -> String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> 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 -> 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 f, Name -> Q Pat forall (m :: * -> *). Quote m => Name -> m Pat varP Name s] (Q Exp -> Q Body forall (m :: * -> *). Quote m => m Exp -> m Body normalB (Q Exp -> Q Body) -> Q Exp -> Q Body forall a b. (a -> b) -> a -> b $ Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp varE Name st Q Exp -> Q Exp -> Q Exp `fmapE` Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp varE Name f Q Exp -> Q Exp -> Q Exp forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp `appE` ([Q Exp] -> Q Exp tupE' ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp forall a b. (a -> b) -> a -> b $ (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 s) (Q Exp -> Q Exp) -> (Char -> Q Exp) -> Char -> Q Exp forall b c a. (b -> c) -> (a -> b) -> a -> c . Char -> Q Exp funX (Char -> Q Exp) -> String -> [Q Exp] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String nm) ) [Name -> [Q Clause] -> Q Dec forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec funD Name st [[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] ab] (Q Exp -> Q Body forall (m :: * -> *). Quote m => m Exp -> m Body normalB (Q Exp -> Q Body) -> Q Exp -> Q Body forall a b. (a -> b) -> a -> b $ ((Q Exp, Q Exp) -> Q Exp -> Q Exp) -> Q Exp -> [(Q Exp, Q Exp)] -> Q Exp forall a b. (a -> b -> b) -> b -> [a] -> b forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (\(Q Exp x, Q Exp a) -> (Q Exp -> Q Exp -> Q Exp forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp `appE` Q Exp a) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp forall b c a. (b -> c) -> (a -> b) -> a -> c . (Q Exp 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 s) ([(Q Exp, Q Exp)] -> Q Exp) -> [(Q Exp, Q Exp)] -> Q Exp forall a b. (a -> b) -> a -> b $ [Q Exp] -> [Q Exp] -> [(Q Exp, Q Exp)] forall a b. [a] -> [b] -> [(a, b)] zip (Char -> Q Exp funSetX (Char -> Q Exp) -> String -> [Q Exp] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String nm) (Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp varE (Name -> Q Exp) -> [Name] -> [Q Exp] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Name] ab)) []]] ] clsSwizzle :: Int -> TypeQ clsSwizzle :: Int -> TypeQ clsSwizzle = Name -> TypeQ forall (m :: * -> *). Quote m => Name -> m Type conT (Name -> TypeQ) -> (Int -> Name) -> Int -> TypeQ forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String -> String -> Name mkNameG_tc String Pkg.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 typX :: Char -> TypeQ typX :: Char -> TypeQ typX = Name -> TypeQ forall (m :: * -> *). Quote m => Name -> m Type conT (Name -> TypeQ) -> (Char -> Name) -> Char -> TypeQ forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String -> String -> Name mkNameG_tc String Pkg.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 funX :: Char -> ExpQ funX :: Char -> Q Exp funX = 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.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 "") clsSwizzleSet :: Int -> TypeQ clsSwizzleSet :: Int -> TypeQ clsSwizzleSet = Name -> TypeQ forall (m :: * -> *). Quote m => Name -> m Type conT (Name -> TypeQ) -> (Int -> Name) -> Int -> TypeQ forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String -> String -> Name mkNameG_tc String Pkg.swizzleSetClassPkg String "Data.SwizzleSet.Class.Base" (String -> Name) -> (Int -> String) -> Int -> Name forall b c a. (b -> c) -> (a -> b) -> a -> c . (String "SwizzleSet" 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 typSetX :: Char -> TypeQ typSetX :: Char -> TypeQ typSetX = Name -> TypeQ forall (m :: * -> *). Quote m => Name -> m Type conT (Name -> TypeQ) -> (Char -> Name) -> Char -> TypeQ forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String -> String -> Name mkNameG_tc String Pkg.swizzleSetClassPkg String "Data.SwizzleSet.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 funSetX :: Char -> ExpQ funSetX :: Char -> Q Exp funSetX = 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.swizzleSetClassPkg String "Data.SwizzleSet.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 "")