{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Data.Curry.TH (crr, unc) where

import Language.Haskell.TH

crr :: Int -> DecsQ
crr :: Int -> DecsQ
crr Int
n = (\Dec
a Dec
b -> [Dec
a, Dec
b])
	(Dec -> Dec -> [Dec]) -> Q Dec -> Q (Dec -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [String] -> Q Dec
crrSig Int
n (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
n ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
cycle' [Char
'a' .. Char
'z'])
	Q (Dec -> [Dec]) -> Q Dec -> DecsQ
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> [String] -> Q Dec
crrFun Int
n (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
n ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
cycle' (String
"xyz" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
reverse [Char
'a' .. Char
'w']))

cycle' :: [Char] -> [String]
cycle' :: String -> [String]
cycle' String
cs = [String] -> [String] -> [String]
go ((Char -> String -> String
forall a. a -> [a] -> [a]
: String
"") (Char -> String) -> String -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
cs) ((Char -> String -> String
forall a. a -> [a] -> [a]
: String
"") (Char -> String) -> String -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
cs)
	where
	go :: [String] -> [String] -> [String]
go [String]
ws [] = let ws' :: [String]
ws' = [ Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
w | Char
c <- String
cs, String
w <- [String]
ws ] in [String] -> [String] -> [String]
go [String]
ws' [String]
ws'
	go [String]
ws (String
s : [String]
ss) = String
s String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String] -> [String]
go [String]
ws [String]
ss

crrSig :: Int -> [String] -> Q Dec
crrSig :: Int -> [String] -> Q Dec
crrSig Int
n [String]
ss = String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [String]
ss Q [Name] -> ([Name] -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Name]
vs -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"rslt" Q Name -> (Name -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
r -> Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"crr" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
	(Q Type -> Q Dec) -> ([Q Type] -> Q Type) -> [Q Type] -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Q Type -> Q Type -> Q Type
arrT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
r) ([Q Type] -> Q Dec) -> [Q Type] -> Q Dec
forall a b. (a -> b) -> a -> b
$ ([Q Type] -> Q Type
tupT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> [Name] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vs) Q Type -> Q Type -> Q Type
`arrT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
r) Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> [Name] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vs)

crrFun :: Int -> [String] -> Q Dec
crrFun :: Int -> [String] -> Q Dec
crrFun Int
n [String]
ss = String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f" Q Name -> (Name -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
f -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [String]
ss Q [Name] -> ([Name] -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Name]
vs ->
	Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"crr" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n) [
		[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f Q Pat -> [Q Pat] -> [Q Pat]
forall a. a -> [a] -> [a]
: (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> Q Pat) -> [Name] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vs))
			(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vs))
			[] ]

unc :: Int -> DecsQ
unc :: Int -> DecsQ
unc Int
n = (\Dec
a Dec
b -> [Dec
a, Dec
b])
	(Dec -> Dec -> [Dec]) -> Q Dec -> Q (Dec -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [String] -> Q Dec
uncSig Int
n (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
n ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
cycle' [Char
'a' .. Char
'z'])
	Q (Dec -> [Dec]) -> Q Dec -> DecsQ
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> [String] -> Q Dec
uncFun Int
n (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
n ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
cycle' (String
"xyz" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
reverse [Char
'a' .. Char
'w']))

uncSig :: Int -> [String] -> Q Dec
uncSig :: Int -> [String] -> Q Dec
uncSig Int
n [String]
ss = String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [String]
ss Q [Name] -> ([Name] -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Name]
vs -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"rslt" Q Name -> (Name -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
r -> Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"unc" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
	(Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$ ((Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Q Type -> Q Type -> Q Type
arrT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
r) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> [Name] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vs) Q Type -> Q Type -> Q Type
`arrT` [Q Type] -> Q Type
tupT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> [Name] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vs) Q Type -> Q Type -> Q Type
`arrT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
r

uncFun :: Int -> [String] -> Q Dec
uncFun :: Int -> [String] -> Q Dec
uncFun Int
n [String]
ss = String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f" Q Name -> (Name -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
f -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [String]
ss Q [Name] -> ([Name] -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Name]
vs ->
	Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"unc" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n) [
		[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> Q Pat) -> [Name] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vs]
			(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) ([Q Exp] -> Q Body) -> [Q Exp] -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vs)
			[] ]

infixr 9 `arrT`

arrT :: TypeQ -> TypeQ -> TypeQ
Q Type
t1 arrT :: Q Type -> Q Type -> Q Type
`arrT` Q Type
t2 = Q Type
forall (m :: * -> *). Quote m => m Type
arrowT Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t1 Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t2

tupT :: [TypeQ] -> TypeQ
tupT :: [Q Type] -> Q Type
tupT [Q Type]
ts = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Int -> Q Type
forall (m :: * -> *). Quote m => Int -> m Type
tupleT (Int -> Q Type) -> Int -> Q Type
forall a b. (a -> b) -> a -> b
$ [Q Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
ts) [Q Type]
ts