{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Foreign.C.Struct.Parts (
	tupleE, tupT, tupP', intE, strP,
	(.->), pt, (.$), (...), (.<$>), (.<*>), (.>>=),
	(.&&), (.||), (.==), (.<), (.+), (.*), zp, ss, (..+),
	toLabel, lcfirst,

	bigTupleData, bigTupleE, bigTupT, bigTupP,
	sbTupleE, sbTupT, sbTupP ) where

import Language.Haskell.TH (
	ExpQ, Exp(TupE), varE, litE, infixE, TypeQ, appT, arrowT, tupleT,
	PatQ, litP, tupP, Name, integerL, stringL,
	varT, mkName,
	dataD, cxt, bangType, bang, noSourceUnpackedness, noSourceStrictness,
	plainTV, normalC, DecQ, conE, conT, conP )
import Data.Char (toLower, toUpper)

---------------------------------------------------------------------------

-- * TEMPLATE
--	+ TUPLE AND LITERAL
--	+ OPERATOR
--		- Make Operator
--		- TYPE ARROW
--		- FUNCTION APPLICATION
--		- NORMAL OPERATOR
--		- PARTIAL AND ZIP
--	+ SHOW S
-- * CHARACTER

---------------------------------------------------------------------------
-- TEMPLATE
---------------------------------------------------------------------------

-- TUPLE AND LITERAL

tupleE :: Int -> ExpQ
tupleE :: Int -> ExpQ
tupleE = \case Int
1 -> forall (m :: * -> *). Quote m => Name -> m Exp
varE 'id; Int
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Exp] -> Exp
TupE forall a b. (a -> b) -> a -> b
$ Int
n forall a. Int -> a -> [a]
`replicate` forall a. Maybe a
Nothing

tupT :: [TypeQ] -> TypeQ
tupT :: [TypeQ] -> TypeQ
tupT = \case [TypeQ
t] -> TypeQ
t; [TypeQ]
ts -> 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 a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeQ]
ts) [TypeQ]
ts

tupP' :: [PatQ] -> PatQ
tupP' :: [PatQ] -> PatQ
tupP' = \case [PatQ
p] -> PatQ
p; [PatQ]
ps -> forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [PatQ]
ps

intE :: Integer -> ExpQ
intE :: Integer -> ExpQ
intE = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL

strP :: String -> PatQ
strP :: String -> PatQ
strP = forall (m :: * -> *). Quote m => Lit -> m Pat
litP forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL

sbTupleE :: Maybe (Name, Name) -> Int -> ExpQ
sbTupleE :: Maybe (Name, Name) -> Int -> ExpQ
sbTupleE Maybe (Name, Name)
mnm Int
nb = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> ExpQ
tupleE Int
nb) (\(Name
_, Name
tpl') -> Name -> ExpQ
bigTupleE Name
tpl') Maybe (Name, Name)
mnm

sbTupT :: Maybe (Name, Name) -> [TypeQ] -> TypeQ
sbTupT :: Maybe (Name, Name) -> [TypeQ] -> TypeQ
sbTupT = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TypeQ] -> TypeQ
tupT (\(Name
tpl, Name
_) ->Name -> [TypeQ] -> TypeQ
bigTupT Name
tpl)

sbTupP :: Maybe (Name, Name) -> [PatQ] -> PatQ
sbTupP :: Maybe (Name, Name) -> [PatQ] -> PatQ
sbTupP = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [PatQ] -> PatQ
tupP' (\(Name
_, Name
tpl') -> Name -> [PatQ] -> PatQ
bigTupP Name
tpl')

bigTupleData :: Name -> Name -> Int -> DecQ
bigTupleData :: Name -> Name -> Int -> DecQ
bigTupleData Name
nm Name
nm' Int
nb = forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) Name
nm
	(Name -> TyVarBndr ()
plainTV forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
as)
	forall a. Maybe a
Nothing
	[forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC Name
nm'
		forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Bang -> m Type -> m BangType
bangType (forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness)
			forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => Name -> m Type
varT forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
as] []
	where as :: [String]
as = forall a. Int -> [a] -> [a]
take Int
nb [String]
abc

abc :: [String]
abc :: [String]
abc = ((forall a. a -> [a] -> [a]
: []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char
'a' .. Char
'z']) forall a. [a] -> [a] -> [a]
++ [ String
as forall a. [a] -> [a] -> [a]
++ [Char
a] | String
as <- [String]
abc, Char
a <- [Char
'a' .. Char
'z'] ]

bigTupleE :: Name -> ExpQ
bigTupleE :: Name -> ExpQ
bigTupleE = forall (m :: * -> *). Quote m => Name -> m Exp
conE

bigTupT :: Name -> [TypeQ] -> TypeQ
bigTupT :: Name -> [TypeQ] -> TypeQ
bigTupT Name
nm = 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
nm)

bigTupP :: Name -> [PatQ] -> PatQ
bigTupP :: Name -> [PatQ] -> PatQ
bigTupP = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP

-- OPERATOR

-- Make Operator

mkop :: Name -> ExpQ -> ExpQ -> ExpQ
mkop :: Name -> ExpQ -> ExpQ -> ExpQ
mkop Name
op ExpQ
e ExpQ
f = forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just ExpQ
e) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
op) (forall a. a -> Maybe a
Just ExpQ
f)

-- Type Arrow And Partial

infixr 0 .->

(.->) :: TypeQ -> TypeQ -> TypeQ
TypeQ
t .-> :: TypeQ -> TypeQ -> TypeQ
.-> TypeQ
u = forall (m :: * -> *). Quote m => m Type
arrowT forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` TypeQ
t forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` TypeQ
u

pt :: ExpQ -> ExpQ -> ExpQ
ExpQ
e pt :: ExpQ -> ExpQ -> ExpQ
`pt` ExpQ
op = forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just ExpQ
e) ExpQ
op forall a. Maybe a
Nothing

-- Function Application

infixr 0 .$
infixl 1 .>>=
infixl 4 .<$>, .<*>
infixr 8 ...

(.$), (...), (.<$>), (.<*>), (.>>=) :: ExpQ -> ExpQ -> ExpQ
[ExpQ -> ExpQ -> ExpQ
(.$), ExpQ -> ExpQ -> ExpQ
(...), ExpQ -> ExpQ -> ExpQ
(.<$>), ExpQ -> ExpQ -> ExpQ
(.<*>), ExpQ -> ExpQ -> ExpQ
(.>>=)] =
	Name -> ExpQ -> ExpQ -> ExpQ
mkop forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ['($), '(.), '(<$>), '(<*>), '(>>=)]

-- Normal Operator

infixr 2 .||
infixr 3 .&&
infix 4 .==, .<

(.&&), (.||), (.==), (.<), (.+), (.*), zp :: ExpQ -> ExpQ -> ExpQ
[ExpQ -> ExpQ -> ExpQ
(.&&), ExpQ -> ExpQ -> ExpQ
(.||), ExpQ -> ExpQ -> ExpQ
(.==), ExpQ -> ExpQ -> ExpQ
(.<), ExpQ -> ExpQ -> ExpQ
(.+), ExpQ -> ExpQ -> ExpQ
(.*), ExpQ -> ExpQ -> ExpQ
zp] =
	Name -> ExpQ -> ExpQ -> ExpQ
mkop forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ['(&&), '(||), '(==), '(<), '(+), '(*), 'zip]

-- SHOW S

ss :: String -> ExpQ
ss :: String -> ExpQ
ss String
s = forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
s) ExpQ -> ExpQ -> ExpQ
`pt` forall (m :: * -> *). Quote m => Name -> m Exp
varE '(++)

(..+) :: String -> String -> ExpQ
String
s1 ..+ :: String -> String -> ExpQ
..+ String
s2 = String -> ExpQ
ss forall a b. (a -> b) -> a -> b
$ String
s1 forall a. [a] -> [a] -> [a]
++ String
s2

---------------------------------------------------------------------------
-- CHARACTER
---------------------------------------------------------------------------

toLabel :: String -> String -> String
toLabel :: String -> String -> String
toLabel String
sn = (String -> String
lcfirst String
sn forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
ucfirst

lcfirst, ucfirst :: String -> String
lcfirst :: String -> String
lcfirst = \case String
"" -> String
""; Char
c : String
cs -> Char -> Char
toLower Char
c forall a. a -> [a] -> [a]
: String
cs
ucfirst :: String -> String
ucfirst = \case String
"" -> String
""; Char
c : String
cs -> Char -> Char
toUpper Char
c forall a. a -> [a] -> [a]
: String
cs