{-# 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 -> Name -> ExpQ
varE 'id; Int
n -> Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> ExpQ) -> ([Maybe Exp] -> Exp) -> [Maybe Exp] -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Exp] -> Exp
TupE ([Maybe Exp] -> ExpQ) -> [Maybe Exp] -> ExpQ
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Maybe Exp -> [Maybe Exp]
forall a. Int -> a -> [a]
`replicate` Maybe Exp
forall a. Maybe a
Nothing

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

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

strP :: String -> PatQ
strP :: String -> PatQ
strP = Lit -> PatQ
litP (Lit -> PatQ) -> (String -> Lit) -> String -> PatQ
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 = ExpQ -> ((Name, Name) -> ExpQ) -> Maybe (Name, Name) -> ExpQ
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 = ([TypeQ] -> TypeQ)
-> ((Name, Name) -> [TypeQ] -> TypeQ)
-> Maybe (Name, Name)
-> [TypeQ]
-> TypeQ
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 = ([PatQ] -> PatQ)
-> ((Name, Name) -> [PatQ] -> PatQ)
-> Maybe (Name, Name)
-> [PatQ]
-> PatQ
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 = CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataD ([TypeQ] -> CxtQ
cxt []) Name
nm
	(Name -> TyVarBndr
plainTV (Name -> TyVarBndr) -> (String -> Name) -> String -> TyVarBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> TyVarBndr) -> [String] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
as)
	Maybe Kind
forall a. Maybe a
Nothing
	[Name -> [BangTypeQ] -> ConQ
normalC Name
nm'
		([BangTypeQ] -> ConQ) -> [BangTypeQ] -> ConQ
forall a b. (a -> b) -> a -> b
$ BangQ -> TypeQ -> BangTypeQ
bangType (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness)
			(TypeQ -> BangTypeQ) -> (String -> TypeQ) -> String -> BangTypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TypeQ
varT (Name -> TypeQ) -> (String -> Name) -> String -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> BangTypeQ) -> [String] -> [BangTypeQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
as] []
	where as :: [String]
as = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
nb [String]
abc

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

bigTupleE :: Name -> ExpQ
bigTupleE :: Name -> ExpQ
bigTupleE = Name -> ExpQ
conE

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

bigTupP :: Name -> [PatQ] -> PatQ
bigTupP :: Name -> [PatQ] -> PatQ
bigTupP = Name -> [PatQ] -> PatQ
conP

-- OPERATOR

-- Make Operator

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

-- Type Arrow And Partial

infixr 0 .->

(.->) :: TypeQ -> TypeQ -> TypeQ
TypeQ
t .-> :: TypeQ -> TypeQ -> TypeQ
.-> TypeQ
u = TypeQ
arrowT TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
t TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
u

pt :: ExpQ -> ExpQ -> ExpQ
ExpQ
e pt :: ExpQ -> ExpQ -> ExpQ
`pt` ExpQ
op = Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
e) ExpQ
op Maybe ExpQ
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 (Name -> ExpQ -> ExpQ -> ExpQ) -> [Name] -> [ExpQ -> ExpQ -> ExpQ]
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 (Name -> ExpQ -> ExpQ -> ExpQ) -> [Name] -> [ExpQ -> ExpQ -> ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ['(&&), '(||), '(==), '(<), '(+), '(*), 'zip]

-- SHOW S

ss :: String -> ExpQ
ss :: String -> ExpQ
ss String
s = Lit -> ExpQ
litE (String -> Lit
stringL String
s) ExpQ -> ExpQ -> ExpQ
`pt` Name -> ExpQ
varE '(++)

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

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

toLabel :: String -> String -> String
toLabel :: String -> String -> String
toLabel String
sn = (String -> String
lcfirst String
sn String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
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 Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
ucfirst :: String -> String
ucfirst = \case String
"" -> String
""; Char
c : String
cs -> Char -> Char
toUpper Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs