{-# LANGUAGE TemplateHaskell #-} module Data.Profunctor.Product.Tuples.TH ( mkTs , pTns , mkFlattenNs , mkUnflattenNs , pNs , mkDefaultNs , maxTupleSize ) where import Language.Haskell.TH import Language.Haskell.TH.Datatype.TyVarBndr import Data.Profunctor (Profunctor (dimap)) import Data.Profunctor.Product.Class (ProductProfunctor, (***!), empty) import Data.Profunctor.Product.Default.Class (Default (def)) import Control.Applicative (pure) mkTs :: [Int] -> Q [Dec] mkTs :: [Int] -> Q [Dec] mkTs = forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Int -> Q Dec mkT mkT :: Int -> Q Dec mkT :: Int -> Q Dec mkT Int n = forall (m :: * -> *). Quote m => Name -> [TyVarBndr ()] -> m Type -> m Dec tySynD (forall {a}. Show a => a -> Name tyName Int n) [TyVarBndr ()] tyVars Q Type tyDef where tyName :: a -> Name tyName a n' = String -> Name mkName (Char 'T'forall a. a -> [a] -> [a] :forall a. Show a => a -> String show a n') tyVars :: [TyVarBndr ()] tyVars = forall a b. (a -> b) -> [a] -> [b] map Name -> TyVarBndr () plainTV forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Int -> [a] -> [a] take Int n forall a b. (a -> b) -> a -> b $ [Name] allNames tyDef :: Q Type tyDef = case Int n of Int 0 -> forall (m :: * -> *). Quote m => Int -> m Type tupleT Int 0 Int 1 -> forall (m :: * -> *). Quote m => Name -> m Type varT (forall a. [a] -> a head [Name] allNames) Int _ -> forall (m :: * -> *). Quote m => Int -> m Type tupleT Int 2 forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall (m :: * -> *). Quote m => Name -> m Type varT (forall a. [a] -> a head [Name] allNames) forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall (m :: * -> *). Quote m => Int -> m Type applyT (Int n forall a. Num a => a -> a -> a - Int 1) applyT :: Int -> m Type applyT Int n' = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl (\m Type t Name v -> m Type t forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall (m :: * -> *). Quote m => Name -> m Type varT Name v) (forall (m :: * -> *). Quote m => Name -> m Type conT (forall {a}. Show a => a -> Name tyName Int n')) (forall a. Int -> [a] -> [a] take Int n' (forall a. [a] -> [a] tail [Name] allNames)) allNames :: [Name] allNames = [ String -> Name mkName forall a b. (a -> b) -> a -> b $ Char cforall a. a -> [a] -> [a] :forall a. Show a => a -> String show Int i | Int i <- [Int 0::Int ..], Char c <- [Char 'a'..Char 'z'] ] chain :: ProductProfunctor p => (t -> p a2 b2) -> (p a1 b1, t) -> p (a1, a2) (b1, b2) chain :: forall (p :: * -> * -> *) t a2 b2 a1 b1. ProductProfunctor p => (t -> p a2 b2) -> (p a1 b1, t) -> p (a1, a2) (b1, b2) chain t -> p a2 b2 rest (p a1 b1 a, t as) = p a1 b1 a forall (p :: * -> * -> *) a b a' b'. ProductProfunctor p => p a b -> p a' b' -> p (a, a') (b, b') ***! t -> p a2 b2 rest t as pTns :: [Int] -> Q [Dec] pTns :: [Int] -> Q [Dec] pTns = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Int -> Q [Dec] pTn productProfunctor :: Name -> Q Pred productProfunctor :: Name -> Q Type productProfunctor Name p = [t|ProductProfunctor $(v p)|] where v :: Name -> Q Type v = forall (f :: * -> *) a. Applicative f => a -> f a pure forall b c a. (b -> c) -> (a -> b) -> a -> c . Name -> Type VarT default_ :: Name -> Name -> Name -> Q Pred default_ :: Name -> Name -> Name -> Q Type default_ Name p Name a Name b = [t|Default $(v p) $(v a) $(v b)|] where v :: Name -> Q Type v = forall (f :: * -> *) a. Applicative f => a -> f a pure forall b c a. (b -> c) -> (a -> b) -> a -> c . Name -> Type VarT pTn :: Int -> Q [Dec] pTn :: Int -> Q [Dec] pTn Int n = forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence [Q Dec sig, Q Dec fun] where p :: Name p = String -> Name mkName String "p" sig :: Q Dec sig = forall (m :: * -> *). Quote m => Name -> m Type -> m Dec sigD (forall {a}. Show a => a -> Name pT Int n) (forall (m :: * -> *). Quote m => [TyVarBndr Specificity] -> m Cxt -> m Type -> m Type forallT (forall a b. (a -> b) -> [a] -> [b] map Name -> TyVarBndr Specificity plainTVSpecified forall a b. (a -> b) -> a -> b $ Name p forall a. a -> [a] -> [a] : forall a. Int -> [a] -> [a] take Int n [Name] as forall a. [a] -> [a] -> [a] ++ forall a. Int -> [a] -> [a] take Int n [Name] bs) (forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence [Name -> Q Type productProfunctor Name p]) (forall (m :: * -> *). Quote m => m Type arrowT forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` Q Type mkLeftTy forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` Q Type mkRightTy) ) mkLeftTy :: Q Type mkLeftTy = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type appT (forall (m :: * -> *). Quote m => Name -> m Type conT Name tN) forall a b. (a -> b) -> a -> b $ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith (\Name a Name b -> forall (m :: * -> *). Quote m => Name -> m Type varT Name p forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall (m :: * -> *). Quote m => Name -> m Type varT Name a forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall (m :: * -> *). Quote m => Name -> m Type varT Name b) (forall a. Int -> [a] -> [a] take Int n [Name] as) (forall a. Int -> [a] -> [a] take Int n [Name] bs) mkRightTy :: Q Type mkRightTy = forall (m :: * -> *). Quote m => Name -> m Type varT Name p forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type appT (forall (m :: * -> *). Quote m => Name -> m Type conT Name tN) (forall a b. (a -> b) -> [a] -> [b] map forall (m :: * -> *). Quote m => Name -> m Type varT forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Int -> [a] -> [a] take Int n forall a b. (a -> b) -> a -> b $ [Name] as) forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type appT (forall (m :: * -> *). Quote m => Name -> m Type conT Name tN) (forall a b. (a -> b) -> [a] -> [b] map forall (m :: * -> *). Quote m => Name -> m Type varT forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Int -> [a] -> [a] take Int n forall a b. (a -> b) -> a -> b $ [Name] bs) fun :: Q Dec fun = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec funD (forall {a}. Show a => a -> Name pT Int n) [ forall (m :: * -> *). Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body normalB Q Exp bdy) [] ] bdy :: Q Exp bdy = case Int n of Int 0 -> [| const empty |] Int 1 -> [| id |] Int 2 -> [| uncurry (***!) |] Int _ -> [| chain $(varE (pT (n - 1))) |] pT :: a -> Name pT a n' = String -> Name mkName (String "pT" forall a. [a] -> [a] -> [a] ++ forall a. Show a => a -> String show a n') tN :: Name tN = String -> Name mkName (Char 'T'forall a. a -> [a] -> [a] :forall a. Show a => a -> String show Int n) as :: [Name] as = [ String -> Name mkName forall a b. (a -> b) -> a -> b $ Char 'a'forall a. a -> [a] -> [a] :forall a. Show a => a -> String show Int i | Int i <- [Int 0::Int ..] ] bs :: [Name] bs = [ String -> Name mkName forall a b. (a -> b) -> a -> b $ Char 'b'forall a. a -> [a] -> [a] :forall a. Show a => a -> String show Int i | Int i <- [Int 0::Int ..] ] mkFlattenNs :: [Int] -> Q [Dec] mkFlattenNs :: [Int] -> Q [Dec] mkFlattenNs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Int -> Q [Dec] mkFlattenN mkFlattenN :: Int -> Q [Dec] mkFlattenN :: Int -> Q [Dec] mkFlattenN Int n = forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence [Q Dec sig, Q Dec fun] where sig :: Q Dec sig = forall (m :: * -> *). Quote m => Name -> m Type -> m Dec sigD Name nm (forall (m :: * -> *). Quote m => [TyVarBndr Specificity] -> m Cxt -> m Type -> m Type forallT (forall a b. (a -> b) -> [a] -> [b] map Name -> TyVarBndr Specificity plainTVSpecified [Name] names) (forall (f :: * -> *) a. Applicative f => a -> f a pure []) forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). Quote m => m Type arrowT forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall {m :: * -> *}. Quote m => [Name] -> m Type unflatT [Name] names forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall {m :: * -> *}. Quote m => [Name] -> m Type flatT [Name] names) fun :: Q Dec fun = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec funD Name nm [ forall (m :: * -> *). Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause clause [forall {m :: * -> *}. Quote m => [Name] -> m Pat mkTupPat [Name] names] (forall (m :: * -> *). Quote m => m Exp -> m Body normalB Q Exp bdy) [] ] bdy :: Q Exp bdy = forall {m :: * -> *}. Quote m => [Name] -> m Exp mkFlatExp [Name] names unflatT :: [Name] -> m Type unflatT [] = forall (m :: * -> *). Quote m => Int -> m Type tupleT Int 0 unflatT [Name v] = forall (m :: * -> *). Quote m => Name -> m Type varT Name v unflatT (Name v:[Name] vs) = forall (m :: * -> *). Quote m => Int -> m Type tupleT Int 2 forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall (m :: * -> *). Quote m => Name -> m Type varT Name v forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` [Name] -> m Type unflatT [Name] vs flatT :: [Name] -> m Type flatT [] = forall (m :: * -> *). Quote m => Int -> m Type tupleT Int 0 flatT [Name v] = forall (m :: * -> *). Quote m => Name -> m Type varT Name v flatT [Name] vs = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type appT (forall (m :: * -> *). Quote m => Int -> m Type tupleT (forall (t :: * -> *) a. Foldable t => t a -> Int length [Name] vs)) (forall a b. (a -> b) -> [a] -> [b] map forall (m :: * -> *). Quote m => Name -> m Type varT [Name] vs) mkTupPat :: [Name] -> m Pat mkTupPat [] = forall (m :: * -> *). Quote m => [m Pat] -> m Pat tupP [] mkTupPat [Name v] = forall (m :: * -> *). Quote m => Name -> m Pat varP Name v mkTupPat (Name v:[Name] vs) = forall (m :: * -> *). Quote m => [m Pat] -> m Pat tupP [forall (m :: * -> *). Quote m => Name -> m Pat varP Name v, [Name] -> m Pat mkTupPat [Name] vs] mkFlatExp :: [Name] -> m Exp mkFlatExp [] = forall (m :: * -> *). Quote m => [m Exp] -> m Exp tupE [] mkFlatExp [Name v] = forall (m :: * -> *). Quote m => Name -> m Exp varE Name v mkFlatExp [Name] vs = forall (m :: * -> *). Quote m => [m Exp] -> m Exp tupE (forall a b. (a -> b) -> [a] -> [b] map forall (m :: * -> *). Quote m => Name -> m Exp varE [Name] vs) nm :: Name nm = String -> Name mkName (String "flatten" forall a. [a] -> [a] -> [a] ++ forall a. Show a => a -> String show Int n) names :: [Name] names = forall a. Int -> [a] -> [a] take Int n [ String -> Name mkName forall a b. (a -> b) -> a -> b $ Char cforall a. a -> [a] -> [a] :forall a. Show a => a -> String show Int i | Int i <- [Int 0::Int ..], Char c <- [Char 'a'..Char 'z'] ] mkUnflattenNs :: [Int] -> Q [Dec] mkUnflattenNs :: [Int] -> Q [Dec] mkUnflattenNs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Int -> Q [Dec] mkUnflattenN mkUnflattenN :: Int -> Q [Dec] mkUnflattenN :: Int -> Q [Dec] mkUnflattenN Int n = forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence [Q Dec sig, Q Dec fun] where sig :: Q Dec sig = forall (m :: * -> *). Quote m => Name -> m Type -> m Dec sigD Name nm (forall (m :: * -> *). Quote m => [TyVarBndr Specificity] -> m Cxt -> m Type -> m Type forallT (forall a b. (a -> b) -> [a] -> [b] map Name -> TyVarBndr Specificity plainTVSpecified [Name] names) (forall (f :: * -> *) a. Applicative f => a -> f a pure []) forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). Quote m => m Type arrowT forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall {m :: * -> *}. Quote m => [Name] -> m Type flatT [Name] names forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall {m :: * -> *}. Quote m => [Name] -> m Type unflatT [Name] names) fun :: Q Dec fun = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec funD Name nm [ forall (m :: * -> *). Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause clause [forall {m :: * -> *}. Quote m => [Name] -> m Pat mkTupPat [Name] names] (forall (m :: * -> *). Quote m => m Exp -> m Body normalB Q Exp bdy) [] ] bdy :: Q Exp bdy = forall {m :: * -> *}. Quote m => [Name] -> m Exp mkUnflatExp [Name] names unflatT :: [Name] -> m Type unflatT [] = forall (m :: * -> *). Quote m => Int -> m Type tupleT Int 0 unflatT [Name v] = forall (m :: * -> *). Quote m => Name -> m Type varT Name v unflatT (Name v:[Name] vs) = forall (m :: * -> *). Quote m => Int -> m Type tupleT Int 2 forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall (m :: * -> *). Quote m => Name -> m Type varT Name v forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` [Name] -> m Type unflatT [Name] vs flatT :: [Name] -> m Type flatT [] = forall (m :: * -> *). Quote m => Int -> m Type tupleT Int 0 flatT [Name v] = forall (m :: * -> *). Quote m => Name -> m Type varT Name v flatT [Name] vs = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type appT (forall (m :: * -> *). Quote m => Int -> m Type tupleT (forall (t :: * -> *) a. Foldable t => t a -> Int length [Name] vs)) (forall a b. (a -> b) -> [a] -> [b] map forall (m :: * -> *). Quote m => Name -> m Type varT [Name] vs) mkTupPat :: [Name] -> m Pat mkTupPat [] = forall (m :: * -> *). Quote m => [m Pat] -> m Pat tupP [] mkTupPat [Name v] = forall (m :: * -> *). Quote m => Name -> m Pat varP Name v mkTupPat [Name] vs = forall (m :: * -> *). Quote m => [m Pat] -> m Pat tupP (forall a b. (a -> b) -> [a] -> [b] map forall (m :: * -> *). Quote m => Name -> m Pat varP [Name] vs) mkUnflatExp :: [Name] -> m Exp mkUnflatExp [] = forall (m :: * -> *). Quote m => [m Exp] -> m Exp tupE [] mkUnflatExp [Name v] = forall (m :: * -> *). Quote m => Name -> m Exp varE Name v mkUnflatExp (Name v:[Name] vs) = forall (m :: * -> *). Quote m => [m Exp] -> m Exp tupE [forall (m :: * -> *). Quote m => Name -> m Exp varE Name v, [Name] -> m Exp mkUnflatExp [Name] vs] nm :: Name nm = String -> Name mkName (String "unflatten" forall a. [a] -> [a] -> [a] ++ forall a. Show a => a -> String show Int n) names :: [Name] names = forall a. Int -> [a] -> [a] take Int n [ String -> Name mkName forall a b. (a -> b) -> a -> b $ Char cforall a. a -> [a] -> [a] :forall a. Show a => a -> String show Int i | Int i <- [Int 0::Int ..], Char c <- [Char 'a'..Char 'z'] ] pNs :: [Int] -> Q [Dec] pNs :: [Int] -> Q [Dec] pNs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Int -> Q [Dec] pN pN :: Int -> Q [Dec] pN :: Int -> Q [Dec] pN Int n = forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence [Q Dec sig, Q Dec fun] where sig :: Q Dec sig = forall (m :: * -> *). Quote m => Name -> m Type -> m Dec sigD Name nm (forall (m :: * -> *). Quote m => [TyVarBndr Specificity] -> m Cxt -> m Type -> m Type forallT (forall a b. (a -> b) -> [a] -> [b] map Name -> TyVarBndr Specificity plainTVSpecified forall a b. (a -> b) -> a -> b $ Name p forall a. a -> [a] -> [a] : [Name] as forall a. [a] -> [a] -> [a] ++ [Name] bs) (forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence [Name -> Q Type productProfunctor Name p]) (forall (m :: * -> *). Quote m => m Type arrowT forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` Q Type mkLeftTy forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` Q Type mkRightTy) ) mkLeftTy :: Q Type mkLeftTy = case Int n of Int 1 -> forall {m :: * -> *}. Quote m => Name -> Name -> m Type mkPT (forall a. [a] -> a head [Name] as) (forall a. [a] -> a head [Name] bs) Int _ -> forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type appT (forall (m :: * -> *). Quote m => Int -> m Type tupleT Int n) (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith forall {m :: * -> *}. Quote m => Name -> Name -> m Type mkPT [Name] as [Name] bs) mkRightTy :: Q Type mkRightTy = forall (m :: * -> *). Quote m => Name -> m Type varT Name p forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall {m :: * -> *}. Quote m => [Name] -> m Type mkTupT [Name] as forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall {m :: * -> *}. Quote m => [Name] -> m Type mkTupT [Name] bs mkTupT :: [Name] -> m Type mkTupT [Name v] = forall (m :: * -> *). Quote m => Name -> m Type varT Name v mkTupT [Name] vs = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type appT (forall (m :: * -> *). Quote m => Int -> m Type tupleT Int n) (forall a b. (a -> b) -> [a] -> [b] map forall (m :: * -> *). Quote m => Name -> m Type varT [Name] vs) mkPT :: Name -> Name -> m Type mkPT Name a Name b = forall (m :: * -> *). Quote m => Name -> m Type varT Name p forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall (m :: * -> *). Quote m => Name -> m Type varT Name a forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall (m :: * -> *). Quote m => Name -> m Type varT Name b fun :: Q Dec fun = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec funD Name nm [ forall (m :: * -> *). Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body normalB Q Exp bdy) [] ] bdy :: Q Exp bdy = [| convert $(unflat) $(unflat) $(flat) $(pT) |] unflat :: Q Exp unflat = forall (m :: * -> *). Quote m => Name -> m Exp varE forall a b. (a -> b) -> a -> b $ String -> Name mkName String unflatNm flat :: Q Exp flat = forall (m :: * -> *). Quote m => Name -> m Exp varE forall a b. (a -> b) -> a -> b $ String -> Name mkName String flatNm pT :: Q Exp pT = forall (m :: * -> *). Quote m => Name -> m Exp varE forall a b. (a -> b) -> a -> b $ String -> Name mkName String pTNm unflatNm :: String unflatNm = String "unflatten" forall a. [a] -> [a] -> [a] ++ forall a. Show a => a -> String show Int n flatNm :: String flatNm = String "flatten" forall a. [a] -> [a] -> [a] ++ forall a. Show a => a -> String show Int n pTNm :: String pTNm = String "pT" forall a. [a] -> [a] -> [a] ++ forall a. Show a => a -> String show Int n nm :: Name nm = String -> Name mkName (Char 'p'forall a. a -> [a] -> [a] :forall a. Show a => a -> String show Int n) p :: Name p = String -> Name mkName String "p" as :: [Name] as = forall a. Int -> [a] -> [a] take Int n [ String -> Name mkName forall a b. (a -> b) -> a -> b $ Char 'a'forall a. a -> [a] -> [a] :forall a. Show a => a -> String show Int i | Int i <- [Int 0::Int ..] ] bs :: [Name] bs = forall a. Int -> [a] -> [a] take Int n [ String -> Name mkName forall a b. (a -> b) -> a -> b $ Char 'b'forall a. a -> [a] -> [a] :forall a. Show a => a -> String show Int i | Int i <- [Int 0::Int ..] ] convert :: Profunctor p => (a2 -> a1) -> (tp -> tTp) -> (b1 -> b2) -> (tTp -> p a1 b1) -> tp -> p a2 b2 convert :: forall (p :: * -> * -> *) a2 a1 tp tTp b1 b2. Profunctor p => (a2 -> a1) -> (tp -> tTp) -> (b1 -> b2) -> (tTp -> p a1 b1) -> tp -> p a2 b2 convert a2 -> a1 u tp -> tTp u' b1 -> b2 f tTp -> p a1 b1 c = forall (p :: * -> * -> *) a b c d. Profunctor p => (a -> b) -> (c -> d) -> p b c -> p a d dimap a2 -> a1 u b1 -> b2 f forall b c a. (b -> c) -> (a -> b) -> a -> c . tTp -> p a1 b1 c forall b c a. (b -> c) -> (a -> b) -> a -> c . tp -> tTp u' mkDefaultNs :: [Int] -> Q [Dec] mkDefaultNs :: [Int] -> Q [Dec] mkDefaultNs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Int -> Q [Dec] mkDefaultN mkDefaultN :: Int -> Q [Dec] mkDefaultN :: Int -> Q [Dec] mkDefaultN Int n = forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence [ forall (m :: * -> *). Quote m => Maybe Overlap -> m Cxt -> m Type -> [m Dec] -> m Dec instanceWithOverlapD (forall a. a -> Maybe a Just Overlap Incoherent) (forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence (Name -> Q Type productProfunctor Name p forall a. a -> [a] -> [a] : Q Type x forall (m :: * -> *). Quote m => m Type -> m Type -> m Type ~~ [Name] -> Q Type mkTupT [Name] as forall a. a -> [a] -> [a] : [Q Type] mkDefs)) (forall (m :: * -> *). Quote m => Name -> m Type conT ''Default forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall (m :: * -> *). Quote m => Name -> m Type varT Name p forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` Q Type x forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` [Name] -> Q Type mkTupT [Name] bs) [Q Dec mkFun] , forall (m :: * -> *). Quote m => Maybe Overlap -> m Cxt -> m Type -> [m Dec] -> m Dec instanceWithOverlapD (forall a. a -> Maybe a Just Overlap Incoherent) (forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence (Name -> Q Type productProfunctor Name p forall a. a -> [a] -> [a] : Q Type x forall (m :: * -> *). Quote m => m Type -> m Type -> m Type ~~ [Name] -> Q Type mkTupT [Name] bs forall a. a -> [a] -> [a] : [Q Type] mkDefs)) (forall (m :: * -> *). Quote m => Name -> m Type conT ''Default forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` forall (m :: * -> *). Quote m => Name -> m Type varT Name p forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` [Name] -> Q Type mkTupT [Name] as forall (m :: * -> *). Quote m => m Type -> m Type -> m Type `appT` Q Type x) [Q Dec mkFun] ] where mkDefs :: [Q Type] mkDefs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith (Name -> Name -> Name -> Q Type default_ Name p) [Name] as [Name] bs mkTupT :: [Name] -> Q Type mkTupT = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type appT (forall (m :: * -> *). Quote m => Int -> m Type tupleT Int n) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall (m :: * -> *). Quote m => Name -> m Type varT mkFun :: Q Dec mkFun = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec funD 'def [forall (m :: * -> *). Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause clause [] Q Body bdy []] bdy :: Q Body bdy = forall (m :: * -> *). Quote m => m Exp -> m Body normalB forall a b. (a -> b) -> a -> b $ case Int n of Int 0 -> forall (m :: * -> *). Quote m => Name -> m Exp varE 'empty Int _ -> forall (m :: * -> *). Quote m => Name -> m Exp varE (String -> Name mkName forall a b. (a -> b) -> a -> b $ Char 'p'forall a. a -> [a] -> [a] :forall a. Show a => a -> String show Int n) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp `appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp tupE (forall a. Int -> a -> [a] replicate Int n [| def |]) p :: Name p = String -> Name mkName String "p" x :: Q Type x = forall (m :: * -> *). Quote m => Name -> m Type varT (String -> Name mkName String "x") m Type t1 ~~ :: m Type -> m Type -> m Type ~~ m Type t2 = [t| $t1 ~ $t2 |] as :: [Name] as = forall a. Int -> [a] -> [a] take Int n [ String -> Name mkName forall a b. (a -> b) -> a -> b $ Char 'a'forall a. a -> [a] -> [a] :forall a. Show a => a -> String show Int i | Int i <- [Int 0::Int ..] ] bs :: [Name] bs = forall a. Int -> [a] -> [a] take Int n [ String -> Name mkName forall a b. (a -> b) -> a -> b $ Char 'b'forall a. a -> [a] -> [a] :forall a. Show a => a -> String show Int i | Int i <- [Int 0::Int ..] ] maxTupleSize :: Int maxTupleSize :: Int maxTupleSize = Int 62