{-# 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 = (Int -> Q Dec) -> [Int] -> Q [Dec]
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 = Name -> [TyVarBndr] -> TypeQ -> Q Dec
tySynD (Int -> Name
forall a. Show a => a -> Name
tyName Int
n) [TyVarBndr]
tyVars TypeQ
tyDef
  where
    tyName :: a -> Name
tyName a
n' = String -> Name
mkName (Char
'T'Char -> String -> String
forall a. a -> [a] -> [a]
:a -> String
forall a. Show a => a -> String
show a
n')
    tyVars :: [TyVarBndr]
tyVars = (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTV ([Name] -> [TyVarBndr])
-> ([Name] -> [Name]) -> [Name] -> [TyVarBndr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n ([Name] -> [TyVarBndr]) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ [Name]
allNames
    tyDef :: TypeQ
tyDef = case Int
n of
      Int
0 -> Int -> TypeQ
tupleT Int
0
      Int
1 -> Name -> TypeQ
varT ([Name] -> Name
forall a. [a] -> a
head [Name]
allNames)
      Int
_ -> Int -> TypeQ
tupleT Int
2 TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT ([Name] -> Name
forall a. [a] -> a
head [Name]
allNames) TypeQ -> TypeQ -> TypeQ
`appT` Int -> TypeQ
applyT (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    applyT :: Int -> TypeQ
applyT Int
n' = (TypeQ -> Name -> TypeQ) -> TypeQ -> [Name] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\TypeQ
t Name
v -> TypeQ
t TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT Name
v) (Name -> TypeQ
conT (Int -> Name
forall a. Show a => a -> Name
tyName Int
n')) (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n' ([Name] -> [Name]
forall a. [a] -> [a]
tail [Name]
allNames))
    allNames :: [Name]
allNames = [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
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 :: (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 -> p a2 b2 -> p (a1, a2) (b1, b2))
-> (p a1 b1, p a2 b2) -> p (a1, a2) (b1, b2)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry p a1 b1 -> p a2 b2 -> p (a1, a2) (b1, b2)
forall (p :: * -> * -> *) a b a' b'.
ProductProfunctor p =>
p a b -> p a' b' -> p (a, a') (b, b')
(***!) (p a1 b1
a, t -> p a2 b2
rest t
as)

pTns :: [Int] -> Q [Dec]
pTns :: [Int] -> Q [Dec]
pTns = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> ([Int] -> Q [[Dec]]) -> [Int] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Q [Dec]) -> [Int] -> Q [[Dec]]
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 -> TypeQ
productProfunctor Name
p = Name -> [TypeQ] -> TypeQ
classP ''ProductProfunctor [Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Type
VarT Name
p)]

default_ :: Name -> Name -> Name -> Q Pred
default_ :: Name -> Name -> Name -> TypeQ
default_ Name
p Name
a Name
b = Name -> [TypeQ] -> TypeQ
classP ''Default ((Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> (Name -> Type) -> Name -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
VarT) [Name
p, Name
a, Name
b])

pTn :: Int -> Q [Dec]
pTn :: Int -> Q [Dec]
pTn Int
n = [Q Dec] -> Q [Dec]
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 = Name -> TypeQ -> Q Dec
sigD (Int -> Name
forall a. Show a => a -> Name
pT Int
n) ([TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTVSpecified ([Name] -> [TyVarBndr]) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ Name
p Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n [Name]
as [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n [Name]
bs)
                               ([TypeQ] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Name -> TypeQ
productProfunctor Name
p])
                               (TypeQ
arrowT TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
mkLeftTy TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
mkRightTy)
                      )
    mkLeftTy :: TypeQ
mkLeftTy = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT Name
tN)
             ([TypeQ] -> TypeQ) -> [TypeQ] -> TypeQ
forall a b. (a -> b) -> a -> b
$ (Name -> Name -> TypeQ) -> [Name] -> [Name] -> [TypeQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
a Name
b -> Name -> TypeQ
varT Name
p TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT Name
a TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT Name
b) (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n [Name]
as) (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n [Name]
bs)
    mkRightTy :: TypeQ
mkRightTy = Name -> TypeQ
varT Name
p TypeQ -> TypeQ -> TypeQ
`appT` (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT Name
tN) ((Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TypeQ
varT ([Name] -> [TypeQ]) -> ([Name] -> [Name]) -> [Name] -> [TypeQ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n ([Name] -> [TypeQ]) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> a -> b
$ [Name]
as)
                       TypeQ -> TypeQ -> TypeQ
`appT` (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT Name
tN) ((Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TypeQ
varT ([Name] -> [TypeQ]) -> ([Name] -> [Name]) -> [Name] -> [TypeQ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n ([Name] -> [TypeQ]) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> a -> b
$ [Name]
bs)
    fun :: Q Dec
fun = Name -> [ClauseQ] -> Q Dec
funD (Int -> Name
forall a. Show a => a -> Name
pT Int
n) [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
bdy) [] ]
    bdy :: ExpQ
bdy = case Int
n of
      Int
0 -> [| const empty |]
      Int
1 -> [| id |]
      Int
2 -> [| uncurry (***!) |]
      Int
_ -> Name -> ExpQ
varE 'chain ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (Int -> Name
forall a. Show a => a -> Name
pT (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
    pT :: a -> Name
pT a
n' = String -> Name
mkName (String
"pT" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n')
    tN :: Name
tN = String -> Name
mkName (Char
'T'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
n)
    as :: [Name]
as = [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'a'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
i | Int
i <- [Int
0::Int ..] ]
    bs :: [Name]
bs = [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'b'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
i | Int
i <- [Int
0::Int ..] ]

mkFlattenNs :: [Int] -> Q [Dec]
mkFlattenNs :: [Int] -> Q [Dec]
mkFlattenNs = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> ([Int] -> Q [[Dec]]) -> [Int] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Q [Dec]) -> [Int] -> Q [[Dec]]
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 = [Q Dec] -> Q [Dec]
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 = Name -> TypeQ -> Q Dec
sigD Name
nm ([TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTVSpecified [Name]
names) ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall a b. (a -> b) -> a -> b
$ TypeQ
arrowT TypeQ -> TypeQ -> TypeQ
`appT` [Name] -> TypeQ
unflatT [Name]
names TypeQ -> TypeQ -> TypeQ
`appT` [Name] -> TypeQ
flatT [Name]
names)
    fun :: Q Dec
fun = Name -> [ClauseQ] -> Q Dec
funD Name
nm [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [[Name] -> PatQ
mkTupPat [Name]
names] (ExpQ -> BodyQ
normalB ExpQ
bdy) [] ]
    bdy :: ExpQ
bdy = [Name] -> ExpQ
mkFlatExp [Name]
names
    unflatT :: [Name] -> TypeQ
unflatT [] = Int -> TypeQ
tupleT Int
0
    unflatT [Name
v] = Name -> TypeQ
varT Name
v
    unflatT (Name
v:[Name]
vs) = Int -> TypeQ
tupleT Int
2 TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT Name
v TypeQ -> TypeQ -> TypeQ
`appT` [Name] -> TypeQ
unflatT [Name]
vs
    flatT :: [Name] -> TypeQ
flatT [] = Int -> TypeQ
tupleT Int
0
    flatT [Name
v] = Name -> TypeQ
varT Name
v
    flatT [Name]
vs = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT ([Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
vs)) ((Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TypeQ
varT [Name]
vs)
    mkTupPat :: [Name] -> PatQ
mkTupPat [] = [PatQ] -> PatQ
tupP []
    mkTupPat [Name
v] = Name -> PatQ
varP Name
v
    mkTupPat (Name
v:[Name]
vs) = [PatQ] -> PatQ
tupP [Name -> PatQ
varP Name
v, [Name] -> PatQ
mkTupPat [Name]
vs]
    mkFlatExp :: [Name] -> ExpQ
mkFlatExp [] = [ExpQ] -> ExpQ
tupE []
    mkFlatExp [Name
v] = Name -> ExpQ
varE Name
v
    mkFlatExp [Name]
vs = [ExpQ] -> ExpQ
tupE ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
vs)
    nm :: Name
nm = String -> Name
mkName (String
"flatten" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
    names :: [Name]
names = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
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 = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> ([Int] -> Q [[Dec]]) -> [Int] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Q [Dec]) -> [Int] -> Q [[Dec]]
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 = [Q Dec] -> Q [Dec]
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 = Name -> TypeQ -> Q Dec
sigD Name
nm ([TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTVSpecified [Name]
names) ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall a b. (a -> b) -> a -> b
$ TypeQ
arrowT TypeQ -> TypeQ -> TypeQ
`appT` [Name] -> TypeQ
flatT [Name]
names TypeQ -> TypeQ -> TypeQ
`appT` [Name] -> TypeQ
unflatT [Name]
names)
    fun :: Q Dec
fun = Name -> [ClauseQ] -> Q Dec
funD Name
nm [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [[Name] -> PatQ
mkTupPat [Name]
names] (ExpQ -> BodyQ
normalB ExpQ
bdy) [] ]
    bdy :: ExpQ
bdy = [Name] -> ExpQ
mkUnflatExp [Name]
names
    unflatT :: [Name] -> TypeQ
unflatT [] = Int -> TypeQ
tupleT Int
0
    unflatT [Name
v] = Name -> TypeQ
varT Name
v
    unflatT (Name
v:[Name]
vs) = Int -> TypeQ
tupleT Int
2 TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT Name
v TypeQ -> TypeQ -> TypeQ
`appT` [Name] -> TypeQ
unflatT [Name]
vs
    flatT :: [Name] -> TypeQ
flatT [] = Int -> TypeQ
tupleT Int
0
    flatT [Name
v] = Name -> TypeQ
varT Name
v
    flatT [Name]
vs = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT ([Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
vs)) ((Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TypeQ
varT [Name]
vs)
    mkTupPat :: [Name] -> PatQ
mkTupPat [] = [PatQ] -> PatQ
tupP []
    mkTupPat [Name
v] = Name -> PatQ
varP Name
v
    mkTupPat [Name]
vs = [PatQ] -> PatQ
tupP ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
vs)
    mkUnflatExp :: [Name] -> ExpQ
mkUnflatExp [] = [ExpQ] -> ExpQ
tupE []
    mkUnflatExp [Name
v] = Name -> ExpQ
varE Name
v
    mkUnflatExp (Name
v:[Name]
vs) = [ExpQ] -> ExpQ
tupE [Name -> ExpQ
varE Name
v, [Name] -> ExpQ
mkUnflatExp [Name]
vs]
    nm :: Name
nm = String -> Name
mkName (String
"unflatten" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
    names :: [Name]
names = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
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 = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> ([Int] -> Q [[Dec]]) -> [Int] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Q [Dec]) -> [Int] -> Q [[Dec]]
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 = [Q Dec] -> Q [Dec]
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 = Name -> TypeQ -> Q Dec
sigD Name
nm ([TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTVSpecified ([Name] -> [TyVarBndr]) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ Name
p Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
as [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
bs)
                           ([TypeQ] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Name -> TypeQ
productProfunctor Name
p])
                           (TypeQ
arrowT TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
mkLeftTy TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
mkRightTy)
                   )
    mkLeftTy :: TypeQ
mkLeftTy = case Int
n of
      Int
1 -> Name -> Name -> TypeQ
mkPT ([Name] -> Name
forall a. [a] -> a
head [Name]
as) ([Name] -> Name
forall a. [a] -> a
head [Name]
bs)
      Int
_ -> (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT Int
n) ((Name -> Name -> TypeQ) -> [Name] -> [Name] -> [TypeQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Name -> TypeQ
mkPT [Name]
as [Name]
bs)
    mkRightTy :: TypeQ
mkRightTy = Name -> TypeQ
varT Name
p TypeQ -> TypeQ -> TypeQ
`appT` [Name] -> TypeQ
mkTupT [Name]
as TypeQ -> TypeQ -> TypeQ
`appT` [Name] -> TypeQ
mkTupT [Name]
bs
    mkTupT :: [Name] -> TypeQ
mkTupT [Name
v] = Name -> TypeQ
varT Name
v
    mkTupT [Name]
vs  = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT Int
n) ((Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TypeQ
varT [Name]
vs)
    mkPT :: Name -> Name -> TypeQ
mkPT Name
a Name
b = Name -> TypeQ
varT Name
p TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT Name
a TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT Name
b
    fun :: Q Dec
fun = Name -> [ClauseQ] -> Q Dec
funD Name
nm [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
bdy) [] ]
    bdy :: ExpQ
bdy = Name -> ExpQ
varE 'convert ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
unflat ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
unflat ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
flat ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
pT
    unflat :: ExpQ
unflat = Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
unflatNm
    flat :: ExpQ
flat = Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
flatNm
    pT :: ExpQ
pT = Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
pTNm
    unflatNm :: String
unflatNm = String
"unflatten" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
    flatNm :: String
flatNm = String
"flatten" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
    pTNm :: String
pTNm = String
"pT" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
    nm :: Name
nm = String -> Name
mkName (Char
'p'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
n)
    p :: Name
p = String -> Name
mkName String
"p"
    as :: [Name]
as = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'a'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
i | Int
i <- [Int
0::Int ..] ]
    bs :: [Name]
bs = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'b'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
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 :: (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 = (a2 -> a1) -> (b1 -> b2) -> p a1 b1 -> p a2 b2
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 (p a1 b1 -> p a2 b2) -> (tp -> p a1 b1) -> tp -> p a2 b2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. tTp -> p a1 b1
c (tTp -> p a1 b1) -> (tp -> tTp) -> tp -> p a1 b1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. tp -> tTp
u'

mkDefaultNs :: [Int] -> Q [Dec]
mkDefaultNs :: [Int] -> Q [Dec]
mkDefaultNs = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> ([Int] -> Q [[Dec]]) -> [Int] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Q [Dec]) -> [Int] -> Q [[Dec]]
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 =
  [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Maybe Overlap -> CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceWithOverlapD
                 (Overlap -> Maybe Overlap
forall a. a -> Maybe a
Just Overlap
Incoherent)
                 ([TypeQ] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Name -> TypeQ
productProfunctor Name
p TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
: TypeQ
x TypeQ -> TypeQ -> TypeQ
~~ [Name] -> TypeQ
mkTupT [Name]
as TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
: [TypeQ]
mkDefs))
                 (Name -> TypeQ
conT ''Default TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT Name
p TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
x TypeQ -> TypeQ -> TypeQ
`appT` [Name] -> TypeQ
mkTupT [Name]
bs)
                 [Q Dec
mkFun]
           , Maybe Overlap -> CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceWithOverlapD
                 (Overlap -> Maybe Overlap
forall a. a -> Maybe a
Just Overlap
Incoherent)
                 ([TypeQ] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Name -> TypeQ
productProfunctor Name
p TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
: TypeQ
x TypeQ -> TypeQ -> TypeQ
~~ [Name] -> TypeQ
mkTupT [Name]
bs TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
: [TypeQ]
mkDefs))
                 (Name -> TypeQ
conT ''Default TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT Name
p TypeQ -> TypeQ -> TypeQ
`appT` [Name] -> TypeQ
mkTupT [Name]
as TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
x)
                 [Q Dec
mkFun]
           ]
  where
    mkDefs :: [TypeQ]
mkDefs = (Name -> Name -> TypeQ) -> [Name] -> [Name] -> [TypeQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
a Name
b -> Name -> Name -> Name -> TypeQ
default_ Name
p Name
a Name
b) [Name]
as [Name]
bs
    mkTupT :: [Name] -> TypeQ
mkTupT = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT Int
n) ([TypeQ] -> TypeQ) -> ([Name] -> [TypeQ]) -> [Name] -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TypeQ
varT
    mkFun :: Q Dec
mkFun = Name -> [ClauseQ] -> Q Dec
funD 'def [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] BodyQ
bdy []]
    bdy :: BodyQ
bdy = ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ case Int
n of
      Int
0 -> Name -> ExpQ
varE 'empty
      Int
_ -> Name -> ExpQ
varE (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'p'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
n) ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
tupE (Int -> ExpQ -> [ExpQ]
forall a. Int -> a -> [a]
replicate Int
n (Name -> ExpQ
varE 'def))
    p :: Name
p = String -> Name
mkName String
"p"
    x :: TypeQ
x = Name -> TypeQ
varT (String -> Name
mkName String
"x")
    TypeQ
t1 ~~ :: TypeQ -> TypeQ -> TypeQ
~~ TypeQ
t2 = [t| $t1 ~ $t2 |]
    as :: [Name]
as = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'a'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
i | Int
i <- [Int
0::Int ..] ]
    bs :: [Name]
bs = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'b'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
i | Int
i <- [Int
0::Int ..] ]

maxTupleSize :: Int
maxTupleSize :: Int
maxTupleSize = Int
62