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