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