{-# 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 ) where

import Language.Haskell.TH (
	ExpQ, Exp(TupE), varE, litE, infixE, TypeQ, appT, arrowT, tupleT,
	PatQ, litP, tupP, Name, integerL, stringL )
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

-- 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