{-# 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)
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
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)
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
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
<$> ['($), '(.), '(<$>), '(<*>), '(>>=)]
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]
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
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