{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Data.Tuple.Append.TemplateHaskell
(
defineTupleAddUpto,
defineTupleAppendUpto,
defineSequenceTupleUpTo,
defineUnboxedTupleAppendFunctionsUpto,
tupleAddL,
tupleAddR,
tupleAdd,
tupleAppend,
tupleAppendFor,
sequenceTuple,
sequenceTupleFor,
boxedTupleAddLFun,
boxedTupleAddRFun,
boxedTupleAppendFun,
unboxedTupleAddLFun,
unboxedTupleAddRFun,
unboxedTupleAppendFun,
makeBoxedTupleAddLFun,
makeBoxedTupleAddRFun,
makeBoxedTupleAppendFun,
makeUnboxedTupleAddLFun,
makeUnboxedTupleAddRFun,
makeUnboxedTupleAppendFun,
boxedAddLClause,
boxedAddRClause,
boxedAppendClause,
sequenceClauseA,
sequenceClauseA_,
unboxedAddLClause,
unboxedAddRClause,
unboxedAppendClause,
)
where
import Control.Monad ((<=<))
import Data.Char (chr, ord)
import Data.Tuple.Append.Class (SequenceTuple (sequenceTupleA, sequenceTupleA_), TupleAddL ((<++)), TupleAddR ((++>)), TupleAppend ((+++)))
import Language.Haskell.TH.Lib (DecsQ)
import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))
import Language.Haskell.TH.Syntax
( Body (NormalB),
Clause (Clause),
Cxt,
Dec (FunD, InstanceD, SigD),
Exp (AppE, ConE, TupE, UnboxedTupE, VarE),
Name,
Pat (TildeP, TupP, UnboxedTupP, VarP),
Q,
Type (AppT, ArrowT, ConT, TupleT, UnboxedTupleT, VarT),
mkName,
tupleDataName,
)
_nameZZ :: Name
_nameZZ :: Name
_nameZZ = String -> Name
mkName String
"x"
_varZZ :: Type
_varZZ :: Type
_varZZ = Name -> Type
VarT Name
_nameZZ
_patZZ :: Pat
_patZZ :: Pat
_patZZ = Name -> Pat
VarP Name
_nameZZ
_nameFF :: Name
_nameFF :: Name
_nameFF = String -> Name
mkName String
"f"
_varFF :: Type
_varFF :: Type
_varFF = Name -> Type
VarT Name
_nameFF
_varNames :: Char -> [Name]
_varNames :: Char -> [Name]
_varNames Char
c = forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
c forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
0x2050 forall a. Num a => a -> a -> a
+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1 :: Int ..]
_uNames :: [Name]
_uNames :: [Name]
_uNames = Char -> [Name]
_varNames Char
'u'
_vNames :: [Name]
_vNames :: [Name]
_vNames = Char -> [Name]
_varNames Char
'v'
_tupleVar' :: Int -> [Name] -> Type
_tupleVar' :: Int -> [Name] -> Type
_tupleVar' Int
n [Name]
ns = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT Int
n) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT (forall a. Int -> [a] -> [a]
take Int
n [Name]
ns))
_tupleVar'' :: Int -> Type -> [Name] -> Type
_tupleVar'' :: Int -> Type -> [Name] -> Type
_tupleVar'' Int
n Type
f [Name]
ns = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT Int
n) (forall a b. (a -> b) -> [a] -> [b]
map ((Type
f Type -> Type -> Type
`AppT`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
VarT) (forall a. Int -> [a] -> [a]
take Int
n [Name]
ns))
_utupleVar' :: Int -> [Name] -> Type
_utupleVar' :: Int -> [Name] -> Type
_utupleVar' Int
n [Name]
ns = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
UnboxedTupleT Int
n) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT (forall a. Int -> [a] -> [a]
take Int
n [Name]
ns))
_tupleP'' :: ([Pat] -> Pat) -> [Name] -> Pat
_tupleP'' :: ([Pat] -> Pat) -> [Name] -> Pat
_tupleP'' = (forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP)
_tupleP' :: [Name] -> Pat
_tupleP' :: [Name] -> Pat
_tupleP' = ([Pat] -> Pat) -> [Name] -> Pat
_tupleP'' (Pat -> Pat
TildeP forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> Pat
TupP)
_utupleP' :: [Name] -> Pat
_utupleP' :: [Name] -> Pat
_utupleP' = ([Pat] -> Pat) -> [Name] -> Pat
_tupleP'' [Pat] -> Pat
UnboxedTupP
_tupleRange :: Int -> [Int]
#if MIN_VERSION_ghc_prim(0,7,0)
_tupleRange :: Int -> [Int]
_tupleRange = forall a. Enum a => a -> a -> [a]
enumFromTo Int
0
#else
_tupleRange = (0 :) . enumFromTo 2
#endif
_tupleCheck :: Int -> Bool
#if MIN_VERSION_ghc_prim(0,7,0)
_tupleCheck :: Int -> Bool
_tupleCheck = (Int
0 forall a. Ord a => a -> a -> Bool
<=)
#else
_tupleCheck 0 = True
_tupleCheck n = 2 <= n
#endif
#if MIN_VERSION_template_haskell(2,16,0)
_tupleB' :: ([Maybe Exp] -> Exp) -> [Name] -> Body
_tupleB' :: ([Maybe Exp] -> Exp) -> [Name] -> Body
_tupleB' [Maybe Exp] -> Exp
f = Exp -> Body
NormalB forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Exp] -> Exp
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE)
#else
_tupleB' :: ([Exp] -> Exp) -> [Name] -> Body
_tupleB' f = NormalB . f . map VarE
#endif
_clause :: [Pat] -> Body -> Name -> Dec
_clause :: [Pat] -> Body -> Name -> Dec
_clause [Pat]
ps Body
b = (Name -> [Clause] -> Dec
`FunD` [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
ps Body
b []])
_sequenceExprA :: Int -> [Name] -> Exp
_sequenceExprA :: Int -> [Name] -> Exp
_sequenceExprA Int
n [Name]
xs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
($)) (Name -> Exp
ConE (Int -> Name
tupleDataName Int
n)) [Exp -> Exp]
exps'
where
exps :: [Exp -> Exp]
exps = forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Exp -> Exp
AppE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) ('(<$>) forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat '(<*>)) :: [Exp -> Exp]
exps' :: [Exp -> Exp]
exps' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Exp -> Exp
f Name
x Exp
y -> Exp -> Exp
f Exp
y Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
x) [Exp -> Exp]
exps [Name]
xs :: [Exp -> Exp]
_sequenceExprA_ :: [Name] -> Exp
_sequenceExprA_ :: [Name] -> Exp
_sequenceExprA_ = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Exp -> Exp -> Exp
AppE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(*>))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) (Name -> Exp
VarE 'pure Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE '())
sequenceClauseA ::
Int ->
Name ->
Dec
sequenceClauseA :: Int -> Name -> Dec
sequenceClauseA Int
n = [Pat] -> Body -> Name -> Dec
_clause [[Name] -> Pat
_tupleP' [Name]
vn] (Exp -> Body
NormalB (Int -> [Name] -> Exp
_sequenceExprA Int
n [Name]
vn))
where
vn :: [Name]
vn = forall a. Int -> [a] -> [a]
take Int
n [Name]
_vNames
sequenceClauseA_ ::
Int ->
Name ->
Dec
sequenceClauseA_ :: Int -> Name -> Dec
sequenceClauseA_ Int
n = [Pat] -> Body -> Name -> Dec
_clause [[Name] -> Pat
_tupleP' [Name]
vn] (Exp -> Body
NormalB ([Name] -> Exp
_sequenceExprA_ [Name]
vn))
where
vn :: [Name]
vn = forall a. Int -> [a] -> [a]
take Int
n [Name]
_vNames
#if MIN_VERSION_template_haskell(2,16,0)
_appendClause :: ([Pat] -> Pat) -> ([Maybe Exp] -> Exp) -> Int -> Int -> Name -> Dec
#else
_appendClause :: ([Pat] -> Pat) -> ([Exp] -> Exp) -> Int -> Int -> Name -> Dec
#endif
_appendClause :: ([Pat] -> Pat) -> ([Maybe Exp] -> Exp) -> Int -> Int -> Name -> Dec
_appendClause [Pat] -> Pat
fp [Maybe Exp] -> Exp
fe Int
m Int
n = [Pat] -> Body -> Name -> Dec
_clause [([Pat] -> Pat) -> [Name] -> Pat
_tupleP'' [Pat] -> Pat
fp [Name]
um, ([Pat] -> Pat) -> [Name] -> Pat
_tupleP'' [Pat] -> Pat
fp [Name]
vn] (([Maybe Exp] -> Exp) -> [Name] -> Body
_tupleB' [Maybe Exp] -> Exp
fe ([Name]
um forall a. [a] -> [a] -> [a]
++ [Name]
vn))
where
um :: [Name]
um = forall a. Int -> [a] -> [a]
take Int
m [Name]
_uNames
vn :: [Name]
vn = forall a. Int -> [a] -> [a]
take Int
n [Name]
_vNames
#if MIN_VERSION_template_haskell(2,16,0)
_addLClause :: ([Pat] -> Pat) -> ([Maybe Exp] -> Exp) -> Int -> Name -> Dec
#else
_addLClause :: ([Pat] -> Pat) -> ([Exp] -> Exp) -> Int -> Name -> Dec
#endif
_addLClause :: ([Pat] -> Pat) -> ([Maybe Exp] -> Exp) -> Int -> Name -> Dec
_addLClause [Pat] -> Pat
fp [Maybe Exp] -> Exp
fe Int
n = [Pat] -> Body -> Name -> Dec
_clause [Pat
_patZZ, ([Pat] -> Pat) -> [Name] -> Pat
_tupleP'' [Pat] -> Pat
fp [Name]
vars] (([Maybe Exp] -> Exp) -> [Name] -> Body
_tupleB' [Maybe Exp] -> Exp
fe (Name
_nameZZ forall a. a -> [a] -> [a]
: [Name]
vars))
where
vars :: [Name]
vars = forall a. Int -> [a] -> [a]
take Int
n [Name]
_vNames
#if MIN_VERSION_template_haskell(2,16,0)
_addRClause :: ([Pat] -> Pat) -> ([Maybe Exp] -> Exp) -> Int -> Name -> Dec
#else
_addRClause :: ([Pat] -> Pat) -> ([Exp] -> Exp) -> Int -> Name -> Dec
#endif
_addRClause :: ([Pat] -> Pat) -> ([Maybe Exp] -> Exp) -> Int -> Name -> Dec
_addRClause [Pat] -> Pat
fp [Maybe Exp] -> Exp
fe Int
n = [Pat] -> Body -> Name -> Dec
_clause [([Pat] -> Pat) -> [Name] -> Pat
_tupleP'' [Pat] -> Pat
fp [Name]
vars, Pat
_patZZ] (([Maybe Exp] -> Exp) -> [Name] -> Body
_tupleB' [Maybe Exp] -> Exp
fe ([Name]
vars forall 𝐯 x 𝐯x. TupleAddR 𝐯 x 𝐯x => 𝐯 -> x -> 𝐯x
++> Name
_nameZZ))
where
vars :: [Name]
vars = forall a. Int -> [a] -> [a]
take Int
n [Name]
_vNames
boxedAppendClause ::
Int ->
Int ->
Name ->
Dec
boxedAppendClause :: Int -> Int -> Name -> Dec
boxedAppendClause = ([Pat] -> Pat) -> ([Maybe Exp] -> Exp) -> Int -> Int -> Name -> Dec
_appendClause (Pat -> Pat
TildeP forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> Pat
TupP) [Maybe Exp] -> Exp
TupE
unboxedAppendClause ::
Int ->
Int ->
Name ->
Dec
unboxedAppendClause :: Int -> Int -> Name -> Dec
unboxedAppendClause = ([Pat] -> Pat) -> ([Maybe Exp] -> Exp) -> Int -> Int -> Name -> Dec
_appendClause [Pat] -> Pat
UnboxedTupP [Maybe Exp] -> Exp
UnboxedTupE
boxedAddLClause ::
Int ->
Name ->
Dec
boxedAddLClause :: Int -> Name -> Dec
boxedAddLClause = ([Pat] -> Pat) -> ([Maybe Exp] -> Exp) -> Int -> Name -> Dec
_addLClause (Pat -> Pat
TildeP forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> Pat
TupP) [Maybe Exp] -> Exp
TupE
unboxedAddLClause ::
Int ->
Name ->
Dec
unboxedAddLClause :: Int -> Name -> Dec
unboxedAddLClause = ([Pat] -> Pat) -> ([Maybe Exp] -> Exp) -> Int -> Name -> Dec
_addLClause [Pat] -> Pat
UnboxedTupP [Maybe Exp] -> Exp
UnboxedTupE
boxedAddRClause ::
Int ->
Name ->
Dec
boxedAddRClause :: Int -> Name -> Dec
boxedAddRClause = ([Pat] -> Pat) -> ([Maybe Exp] -> Exp) -> Int -> Name -> Dec
_addRClause (Pat -> Pat
TildeP forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> Pat
TupP) [Maybe Exp] -> Exp
TupE
unboxedAddRClause ::
Int ->
Name ->
Dec
unboxedAddRClause :: Int -> Name -> Dec
unboxedAddRClause = ([Pat] -> Pat) -> ([Maybe Exp] -> Exp) -> Int -> Name -> Dec
_addRClause [Pat] -> Pat
UnboxedTupP [Maybe Exp] -> Exp
UnboxedTupE
_tupleB :: [Name] -> Body
_tupleB :: [Name] -> Body
_tupleB = ([Maybe Exp] -> Exp) -> [Name] -> Body
_tupleB' [Maybe Exp] -> Exp
TupE
_utupleB :: [Name] -> Body
_utupleB :: [Name] -> Body
_utupleB = ([Maybe Exp] -> Exp) -> [Name] -> Body
_tupleB' [Maybe Exp] -> Exp
UnboxedTupE
_arr :: Type -> Type -> Type
_arr :: Type -> Type -> Type
_arr Type
l Type
r = Type
ArrowT Type -> Type -> Type
`AppT` Type
l Type -> Type -> Type
`AppT` Type
r
_tupType :: [Type] -> Type
_tupType :: [Type] -> Type
_tupType [Type]
ns = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ns)) [Type]
ns
_utupType :: [Type] -> Type
_utupType :: [Type] -> Type
_utupType [Type]
ns = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
UnboxedTupleT (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ns)) [Type]
ns
_signature :: Name -> Type -> Type -> Type -> Dec
_signature :: Name -> Type -> Type -> Type -> Dec
_signature Name
nm Type
ta Type
tb Type
tc = Name -> Type -> Dec
SigD Name
nm (Type
ta Type -> Type -> Type
`_arr` (Type
tb Type -> Type -> Type
`_arr` Type
tc))
boxedTupleAppendFun ::
Name ->
[Type] ->
[Type] ->
[Dec]
boxedTupleAppendFun :: Name -> [Type] -> [Type] -> [Dec]
boxedTupleAppendFun Name
nm [Type]
l [Type]
r =
[ Name -> Type -> Type -> Type -> Dec
_signature Name
nm ([Type] -> Type
_tupType [Type]
l) ([Type] -> Type
_tupType [Type]
r) ([Type] -> Type
_tupType ([Type]
l forall a. [a] -> [a] -> [a]
++ [Type]
r)),
Int -> Int -> Name -> Dec
boxedAppendClause (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
l) (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
r) Name
nm
]
unboxedTupleAppendFun ::
Name ->
[Type] ->
[Type] ->
[Dec]
unboxedTupleAppendFun :: Name -> [Type] -> [Type] -> [Dec]
unboxedTupleAppendFun Name
nm [Type]
l [Type]
r =
[ Name -> Type -> Type -> Type -> Dec
_signature Name
nm ([Type] -> Type
_utupType [Type]
l) ([Type] -> Type
_utupType [Type]
r) ([Type] -> Type
_utupType ([Type]
l forall a. [a] -> [a] -> [a]
++ [Type]
r)),
Int -> Int -> Name -> Dec
unboxedAppendClause (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
l) (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
r) Name
nm
]
boxedTupleAddLFun ::
Name ->
Type ->
[Type] ->
[Dec]
boxedTupleAddLFun :: Name -> Type -> [Type] -> [Dec]
boxedTupleAddLFun Name
nm Type
t [Type]
ts =
[ Name -> Type -> Type -> Type -> Dec
_signature Name
nm Type
t ([Type] -> Type
_tupType [Type]
ts) ([Type] -> Type
_tupType (Type
t forall a. a -> [a] -> [a]
: [Type]
ts)),
Int -> Name -> Dec
boxedAddLClause (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts) Name
nm
]
unboxedTupleAddLFun ::
Name ->
Type ->
[Type] ->
[Dec]
unboxedTupleAddLFun :: Name -> Type -> [Type] -> [Dec]
unboxedTupleAddLFun Name
nm Type
t [Type]
ts =
[ Name -> Type -> Type -> Type -> Dec
_signature Name
nm Type
t ([Type] -> Type
_utupType [Type]
ts) ([Type] -> Type
_utupType (Type
t forall a. a -> [a] -> [a]
: [Type]
ts)),
Int -> Name -> Dec
unboxedAddLClause (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts) Name
nm
]
boxedTupleAddRFun ::
Name ->
[Type] ->
Type ->
[Dec]
boxedTupleAddRFun :: Name -> [Type] -> Type -> [Dec]
boxedTupleAddRFun Name
nm [Type]
ts Type
t =
[ Name -> Type -> Type -> Type -> Dec
_signature Name
nm ([Type] -> Type
_tupType [Type]
ts) Type
t ([Type] -> Type
_tupType ([Type]
ts forall 𝐯 x 𝐯x. TupleAddR 𝐯 x 𝐯x => 𝐯 -> x -> 𝐯x
++> Type
t)),
Int -> Name -> Dec
boxedAddRClause (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts) Name
nm
]
unboxedTupleAddRFun ::
Name ->
[Type] ->
Type ->
[Dec]
unboxedTupleAddRFun :: Name -> [Type] -> Type -> [Dec]
unboxedTupleAddRFun Name
nm [Type]
ts Type
t =
[ Name -> Type -> Type -> Type -> Dec
_signature Name
nm ([Type] -> Type
_utupType [Type]
ts) Type
t ([Type] -> Type
_utupType ([Type]
ts forall 𝐯 x 𝐯x. TupleAddR 𝐯 x 𝐯x => 𝐯 -> x -> 𝐯x
++> Type
t)),
Int -> Name -> Dec
unboxedAddRClause (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts) Name
nm
]
makeBoxedTupleAppendFun ::
Name ->
[Type] ->
[Type] ->
DecsQ
makeBoxedTupleAppendFun :: Name -> [Type] -> [Type] -> DecsQ
makeBoxedTupleAppendFun Name
nm [Type]
l = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Type] -> [Type] -> [Dec]
boxedTupleAppendFun Name
nm [Type]
l
makeUnboxedTupleAppendFun ::
Name ->
[Type] ->
[Type] ->
DecsQ
makeUnboxedTupleAppendFun :: Name -> [Type] -> [Type] -> DecsQ
makeUnboxedTupleAppendFun Name
nm [Type]
l = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Type] -> [Type] -> [Dec]
unboxedTupleAppendFun Name
nm [Type]
l
makeBoxedTupleAddLFun ::
Name ->
Type ->
[Type] ->
DecsQ
makeBoxedTupleAddLFun :: Name -> Type -> [Type] -> DecsQ
makeBoxedTupleAddLFun Name
nm Type
t = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type -> [Type] -> [Dec]
boxedTupleAddLFun Name
nm Type
t
makeUnboxedTupleAddLFun ::
Name ->
Type ->
[Type] ->
DecsQ
makeUnboxedTupleAddLFun :: Name -> Type -> [Type] -> DecsQ
makeUnboxedTupleAddLFun Name
nm Type
t = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type -> [Type] -> [Dec]
unboxedTupleAddLFun Name
nm Type
t
makeBoxedTupleAddRFun ::
Name ->
[Type] ->
Type ->
DecsQ
makeBoxedTupleAddRFun :: Name -> [Type] -> Type -> DecsQ
makeBoxedTupleAddRFun Name
nm [Type]
ts = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Type] -> Type -> [Dec]
boxedTupleAddRFun Name
nm [Type]
ts
makeUnboxedTupleAddRFun ::
Name ->
[Type] ->
Type ->
DecsQ
makeUnboxedTupleAddRFun :: Name -> [Type] -> Type -> DecsQ
makeUnboxedTupleAddRFun Name
nm [Type]
ts = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Type] -> Type -> [Dec]
unboxedTupleAddRFun Name
nm [Type]
ts
_simpleInstance'' :: Cxt -> Name -> Type -> Type -> Type -> [Dec] -> Dec
_simpleInstance'' :: [Type] -> Name -> Type -> Type -> Type -> [Dec] -> Dec
_simpleInstance'' [Type]
cxt Name
tc Type
tca Type
tcb Type
tcc = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing [Type]
cxt (Name -> Type
ConT Name
tc Type -> Type -> Type
`AppT` Type
tca Type -> Type -> Type
`AppT` Type
tcb Type -> Type -> Type
`AppT` Type
tcc)
_simpleInstance' :: Name -> Type -> Type -> Type -> [Dec] -> Dec
_simpleInstance' :: Name -> Type -> Type -> Type -> [Dec] -> Dec
_simpleInstance' = [Type] -> Name -> Type -> Type -> Type -> [Dec] -> Dec
_simpleInstance'' []
_simpleInstance :: Name -> Name -> Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstance :: Name -> Name -> Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstance Name
tc Name
f Type
tca Type
tcb Type
tcc Name -> Dec
d = Name -> Type -> Type -> Type -> [Dec] -> Dec
_simpleInstance' Name
tc Type
tca Type
tcb Type
tcc [Name -> Dec
d Name
f]
_simpleInstanceLift :: Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstanceLift :: Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstanceLift = Name -> Name -> Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstance ''TupleAppend '(+++)
_simpleInstanceAppend :: Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstanceAppend :: Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstanceAppend = Name -> Name -> Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstance ''TupleAppend '(+++)
_simpleInstanceAddL :: Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstanceAddL :: Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstanceAddL = Name -> Name -> Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstance ''TupleAddL '(<++)
_simpleInstanceAddR :: Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstanceAddR :: Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstanceAddR = Name -> Name -> Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstance ''TupleAddR '(++>)
_simpleSequenceInstance :: Type -> Type -> [Dec] -> Dec
_simpleSequenceInstance :: Type -> Type -> [Dec] -> Dec
_simpleSequenceInstance = [Type] -> Name -> Type -> Type -> Type -> [Dec] -> Dec
_simpleInstance'' [Name -> Type
ConT ''Prelude.Applicative Type -> Type -> Type
`AppT` Type
_varFF] ''SequenceTuple Type
_varFF
sequenceTuple ::
Int ->
Dec
sequenceTuple :: Int -> Dec
sequenceTuple Int
n = Type -> Type -> [Dec] -> Dec
_simpleSequenceInstance (Int -> Type -> [Name] -> Type
_tupleVar'' Int
n Type
_varFF [Name]
_vNames) (Int -> [Name] -> Type
_tupleVar' Int
n [Name]
_vNames) [Int -> Name -> Dec
sequenceClauseA Int
n 'sequenceTupleA, Int -> Name -> Dec
sequenceClauseA_ Int
n 'sequenceTupleA_]
tupleAppend ::
Int ->
Int ->
Dec
tupleAppend :: Int -> Int -> Dec
tupleAppend Int
m Int
n = Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstanceAppend (Int -> [Name] -> Type
_tupleVar' Int
m [Name]
_uNames) (Int -> [Name] -> Type
_tupleVar' Int
n [Name]
_vNames) (Int -> [Name] -> Type
_tupleVar' (Int
m forall a. Num a => a -> a -> a
+ Int
n) (forall a. Int -> [a] -> [a]
take Int
m [Name]
_uNames forall a. [a] -> [a] -> [a]
++ [Name]
_vNames)) (Int -> Int -> Name -> Dec
boxedAppendClause Int
m Int
n)
tupleAppendFor ::
Int ->
[Dec]
tupleAppendFor :: Int -> [Dec]
tupleAppendFor Int
l = [Int -> Int -> Dec
tupleAppend Int
m Int
n | Int
m <- Int -> [Int]
_tupleRange Int
l, let n :: Int
n = Int
l forall a. Num a => a -> a -> a
- Int
m, Int -> Bool
_tupleCheck Int
n]
sequenceTupleFor ::
Int ->
[Dec]
sequenceTupleFor :: Int -> [Dec]
sequenceTupleFor Int
n = [Int -> Dec
sequenceTuple Int
n | Int -> Bool
_tupleCheck Int
n]
tupleAddL ::
Int ->
Dec
tupleAddL :: Int -> Dec
tupleAddL Int
n = Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstanceAddL Type
_varZZ (Int -> [Name] -> Type
_tupleVar' Int
n [Name]
_vNames) (Int -> [Name] -> Type
_tupleVar' (Int
n forall a. Num a => a -> a -> a
+ Int
1) (Name
_nameZZ forall a. a -> [a] -> [a]
: [Name]
_vNames)) (Int -> Name -> Dec
boxedAddLClause Int
n)
tupleAddR ::
Int ->
Dec
tupleAddR :: Int -> Dec
tupleAddR Int
n = Type -> Type -> Type -> (Name -> Dec) -> Dec
_simpleInstanceAddR (Int -> [Name] -> Type
_tupleVar' Int
n [Name]
_vNames) Type
_varZZ (Int -> [Name] -> Type
_tupleVar' (Int
n forall a. Num a => a -> a -> a
+ Int
1) (forall a. Int -> [a] -> [a]
take Int
n [Name]
_vNames forall 𝐯 x 𝐯x. TupleAddR 𝐯 x 𝐯x => 𝐯 -> x -> 𝐯x
++> Name
_nameZZ)) (Int -> Name -> Dec
boxedAddRClause Int
n)
tupleAdd ::
Int ->
[Dec]
tupleAdd :: Int -> [Dec]
tupleAdd Int
n
| Int -> Bool
_tupleCheck Int
n Bool -> Bool -> Bool
&& Int -> Bool
_tupleCheck (Int
n forall a. Num a => a -> a -> a
+ Int
1) = [Int -> Dec
tupleAddL Int
n, Int -> Dec
tupleAddR Int
n]
| Bool
otherwise = []
_errorQuasiQuoter :: a -> Q b
_errorQuasiQuoter :: forall a b. a -> Q b
_errorQuasiQuoter = forall a b. a -> b -> a
const (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The quasi quoter can only be used to define declarations")
defineTupleAddUpto ::
QuasiQuoter
defineTupleAddUpto :: QuasiQuoter
defineTupleAddUpto = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> DecsQ)
-> QuasiQuoter
QuasiQuoter forall a b. a -> Q b
_errorQuasiQuoter forall a b. a -> Q b
_errorQuasiQuoter forall a b. a -> Q b
_errorQuasiQuoter (Int -> DecsQ
_defineTupleAddUpTo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> a
read)
_defineTupleAddUpTo :: Int -> DecsQ
_defineTupleAddUpTo :: Int -> DecsQ
_defineTupleAddUpTo Int
n = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (a -> b) -> [a] -> [b]
map Int -> Dec
tupleAddL [Int]
ns forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Int -> Dec
tupleAddR [Int]
ns)
where
ns :: [Int]
ns = forall a. [a] -> [a]
reverse (forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Bool
_tupleCheck forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> a
succ) (Int -> [Int]
_tupleRange Int
n))
defineTupleAppendUpto ::
QuasiQuoter
defineTupleAppendUpto :: QuasiQuoter
defineTupleAppendUpto = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> DecsQ)
-> QuasiQuoter
QuasiQuoter forall a b. a -> Q b
_errorQuasiQuoter forall a b. a -> Q b
_errorQuasiQuoter forall a b. a -> Q b
_errorQuasiQuoter (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> [Dec]
tupleAppendFor forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> a
read))
defineSequenceTupleUpTo ::
QuasiQuoter
defineSequenceTupleUpTo :: QuasiQuoter
defineSequenceTupleUpTo = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> DecsQ)
-> QuasiQuoter
QuasiQuoter forall a b. a -> Q b
_errorQuasiQuoter forall a b. a -> Q b
_errorQuasiQuoter forall a b. a -> Q b
_errorQuasiQuoter (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> [Dec]
sequenceTupleFor forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. Enum a => a -> a -> [a]
enumFromTo Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> a
read))
defineUnboxedTupleAppendFunctionsUpto ::
QuasiQuoter
defineUnboxedTupleAppendFunctionsUpto :: QuasiQuoter
defineUnboxedTupleAppendFunctionsUpto = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> DecsQ)
-> QuasiQuoter
QuasiQuoter forall a b. a -> Q b
_errorQuasiQuoter forall a b. a -> Q b
_errorQuasiQuoter forall a b. a -> Q b
_errorQuasiQuoter (Int -> DecsQ
_unboxedTupleConcats forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> a
read)
_unboxedTupleConcats :: Int -> DecsQ
_unboxedTupleConcats :: Int -> DecsQ
_unboxedTupleConcats Int
r = forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
u | Int
m <- [Int
r forall a. Num a => a -> a -> a
- Int
2, Int
r forall a. Num a => a -> a -> a
- Int
3 .. Int
2], Int
n <- [Int
r forall a. Num a => a -> a -> a
- Int
m forall a. Num a => a -> a -> a
- Int
2, Int
r forall a. Num a => a -> a -> a
- Int
m forall a. Num a => a -> a -> a
- Int
3 .. Int
2], Dec
u <- Name -> [Type] -> [Type] -> [Dec]
unboxedTupleAppendFun (String -> Name
mkName (String
"unboxedAppend_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
m forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n)) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT (forall a. Int -> [a] -> [a]
take Int
m [Name]
_uNames)) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT (forall a. Int -> [a] -> [a]
take Int
n [Name]
_vNames))]