{-# OPTIONS -Wall -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Unused LANGUAGE pragma" #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TupleSections #-}
module Raylib.Internal.TH (genLenses, genNative) where
import Control.Lens (makeLensesFor)
import Control.Monad (zipWithM)
#ifdef WEB_FFI
import Language.Haskell.TH
( Body (NormalB),
Clause (Clause),
Con (RecC),
Dec (DataD, FunD, SigD),
DecsQ,
Exp (AppE, LitE, VarE),
Info (TyConI),
Lit (StringL),
Name,
TypeQ,
mkName,
nameBase,
reify,
)
import Raylib.Internal.Web.Native (callRaylibFunction)
#else
import Language.Haskell.TH
( Con (RecC),
Dec (DataD, ForeignD),
DecsQ,
Info (TyConI),
Name,
TypeQ,
mkName,
nameBase,
reify, Foreign (ImportF), Callconv (CCall), Safety (Safe, Unsafe),
)
#endif
genLenses :: [Name] -> DecsQ
genLenses :: [Name] -> DecsQ
genLenses [Name]
names = do
[Info]
infos <- (Name -> Q Info) -> [Name] -> Q [Info]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> Q Info
reify [Name]
names
[[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Info -> DecsQ) -> [Name] -> [Info] -> Q [[Dec]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name -> Info -> DecsQ
genLensesForType [Name]
names [Info]
infos
where
genLensesForType :: Name -> Info -> DecsQ
genLensesForType Name
name (TyConI (DataD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ [RecC Name
_ [VarBangType]
ctors] [DerivClause]
_)) =
[(String, String)] -> Name -> DecsQ
makeLensesFor [(String, String)]
mapping Name
name
where
mapping :: [(String, String)]
mapping = (VarBangType -> (String, String))
-> [VarBangType] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
a, Bang
_, Kind
_) -> let fName :: String
fName = Name -> String
nameBase Name
a in (String
fName, Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: String
fName)) [VarBangType]
ctors
genLensesForType Name
_ Info
_ = String -> DecsQ
forall a. HasCallStack => String -> a
error String
"(genLenses) Received a name that does not refer to a valid type!"
genNative ::
[(String, String, String, TypeQ, Bool)] ->
DecsQ
genNative :: [(String, String, String, TypeQ, Bool)] -> DecsQ
genNative [(String, String, String, TypeQ, Bool)]
funs = do
[(String, String, String, Kind, Bool)]
funs' <- ((String, String, String, TypeQ, Bool)
-> Q (String, String, String, Kind, Bool))
-> [(String, String, String, TypeQ, Bool)]
-> Q [(String, String, String, Kind, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(String
a, String
b, String
c, TypeQ
d, Bool
e) -> (String
a,String
b,String
c,,Bool
e) (Kind -> (String, String, String, Kind, Bool))
-> TypeQ -> Q (String, String, String, Kind, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
d) [(String, String, String, TypeQ, Bool)]
funs
[Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, String, String, Kind, Bool)] -> [Dec]
genNative' [(String, String, String, Kind, Bool)]
funs')
where
genNative' :: [(String, String, String, Kind, Bool)] -> [Dec]
genNative' [] = []
#ifdef WEB_FFI
genNative' ((hsName, cName, _, funType, _) : xs) =
[
SigD name funType,
FunD
name
[Clause [] (NormalB (AppE (VarE 'callRaylibFunction) (LitE (StringL ('_' : cName))))) []]
] ++ genNative' xs
where
name = mkName hsName
#else
genNative' ((String
hsName, String
cName, String
cFile, Kind
funType, Bool
isSafe) : [(String, String, String, Kind, Bool)]
xs) =
Foreign -> Dec
ForeignD (Callconv -> Safety -> String -> Name -> Kind -> Foreign
ImportF Callconv
CCall (if Bool
isSafe then Safety
Safe else Safety
Unsafe) (String
cFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cName) (String -> Name
mkName String
hsName) Kind
funType) Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [(String, String, String, Kind, Bool)] -> [Dec]
genNative' [(String, String, String, Kind, Bool)]
xs
#endif