{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module SDL.Raw.Helper (liftF) where
import Control.Monad (replicateM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Language.Haskell.TH
( Body (NormalB),
Callconv (CCall),
Clause (Clause),
Dec (ForeignD, FunD, PragmaD, SigD),
Exp (AppE, VarE),
Foreign (ImportF),
Inline (Inline),
Name,
Pat (VarP),
Phases (AllPhases),
Pragma (InlineP),
Q,
RuleMatch (FunLike),
Safety (Safe),
TyVarBndr (PlainTV),
Type (AppT, ArrowT, ConT, ForallT, SigT, VarT),
mkName,
newName,
#if MIN_VERSION_template_haskell(2,17,0)
Specificity(SpecifiedSpec)
#endif
)
liftF :: String -> String -> Q Type -> Q [Dec]
liftF :: String -> String -> Q Type -> Q [Dec]
liftF String
fname String
cname Q Type
ftype = do
let f' :: Name
f' = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
let f :: Name
f = String -> Name
mkName String
fname
Type
t' <- Q Type
ftype
[Name]
args <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Type -> Int
countArgs Type
t') (Q Name -> Q [Name]) -> Q Name -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x"
[Dec]
sigd <- case [Name]
args of
[] -> ((Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: []) (Dec -> [Dec]) -> (Type -> Dec) -> Type -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type -> Dec
SigD Name
f) (Type -> [Dec]) -> Q Type -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Type -> Q Type
liftType Type
t'
[Name]
_ -> [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
[[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ Foreign -> Dec
ForeignD (Foreign -> Dec) -> Foreign -> Dec
forall a b. (a -> b) -> a -> b
$ Callconv -> Safety -> String -> Name -> Type -> Foreign
ImportF Callconv
CCall Safety
Safe String
cname Name
f' Type
t',
Pragma -> Dec
PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
f Inline
Inline RuleMatch
FunLike Phases
AllPhases
],
[Dec]
sigd,
[ Name -> [Clause] -> Dec
FunD
Name
f
[ [Pat] -> Body -> [Dec] -> Clause
Clause
((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
args)
(Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ 'liftIO Name -> [Exp] -> Exp
`applyTo` [Name
f' Name -> [Exp] -> Exp
`applyTo` (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
args])
[]
]
]
]
countArgs :: Type -> Int
countArgs :: Type -> Int
countArgs = Int -> Type -> Int
forall p. Num p => p -> Type -> p
count Int
0
where
count :: Num p => p -> Type -> p
count :: p -> Type -> p
count !p
n = \case
(AppT (AppT Type
ArrowT Type
_) Type
t) -> p -> Type -> p
forall p. Num p => p -> Type -> p
count (p
n p -> p -> p
forall a. Num a => a -> a -> a
+ p
1) Type
t
(ForallT [TyVarBndr]
_ Cxt
_ Type
t) -> p -> Type -> p
forall p. Num p => p -> Type -> p
count p
n Type
t
(SigT Type
t Type
_) -> p -> Type -> p
forall p. Num p => p -> Type -> p
count p
n Type
t
Type
_ -> p
n
applyTo :: Name -> [Exp] -> Exp
applyTo :: Name -> [Exp] -> Exp
applyTo Name
f [] = Name -> Exp
VarE Name
f
applyTo Name
f [Exp]
es = [Exp] -> Exp -> Exp
forall (t :: * -> *). Foldable t => t Exp -> Exp -> Exp
loop ([Exp] -> [Exp]
forall a. [a] -> [a]
tail [Exp]
es) (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
f) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
forall a. [a] -> a
head [Exp]
es
where
loop :: Foldable t => t Exp -> Exp -> Exp
loop :: t Exp -> Exp -> Exp
loop t Exp
as Exp
e = (Exp -> Exp -> Exp) -> Exp -> t Exp -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE Exp
e t Exp
as
liftType :: Type -> Q Type
liftType :: Type -> Q Type
liftType = \case
AppT Type
_ Type
t -> do
Name
m <- String -> Q Name
newName String
"m"
Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$
[TyVarBndr] -> Cxt -> Type -> Type
ForallT
#if MIN_VERSION_template_haskell(2,17,0)
[PlainTV m SpecifiedSpec]
#else
[Name -> TyVarBndr
PlainTV Name
m]
#endif
[Type -> Type -> Type
AppT (Name -> Type
ConT ''MonadIO) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
VarT Name
m]
(Type -> Type -> Type
AppT (Name -> Type
VarT Name
m) Type
t)
Type
t -> Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t