{-# LANGUAGE TemplateHaskell #-}
module FFICXX.Runtime.Function.TH where

import Data.List                  ( intercalate )
import Data.Maybe                 ( fromMaybe )
import Foreign.Ptr                ( FunPtr )
import Language.Haskell.TH        ( forImpD, safe )
import Language.Haskell.TH.Syntax ( Body(NormalB), Callconv(CCall), Clause(..)
                                  , Exp(..), Dec(..), ForeignSrcLang(LangCxx)
                                  , Q, Type(..)
                                  , addForeignSource
                                  , addModFinalizer
                                  , addTopDecls
                                  , mkNameS
                                  , newName
                                  )
--
import FFICXX.Runtime.CodeGen.Cxx ( CMacro(..), CStatement(..), renderCMacro, renderCStmt )
import FFICXX.Runtime.TH          ( FunctionParamInfo(..)
                                  , con, mkInstance, mkMember, mkNew, mkTFunc
                                  )
import FFICXX.Runtime.Function.Template ( Function )


mkWrapper :: (Type,String) -> Q Dec
mkWrapper :: (Type, String) -> Q Dec
mkWrapper (Type
typ,String
suffix)
  = do let fn :: String
fn = String
"wrap_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
suffix
       Name
n <- String -> Q Name
newName String
fn
       Dec
d <- Callconv -> Safety -> String -> Name -> TypeQ -> Q Dec
forImpD Callconv
CCall Safety
safe String
"wrapper" Name
n [t| $(pure typ) -> IO (FunPtr ($(pure typ))) |]
       [Dec] -> Q ()
addTopDecls [Dec
d]
       Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
         Name -> [Clause] -> Dec
FunD (String -> Name
mkNameS String
"wrapFunPtr") [ [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB (Name -> Exp
VarE Name
n)) [] ]


t_newFunction :: Type -> String -> Q Exp
t_newFunction :: Type -> String -> Q Exp
t_newFunction Type
typ String
suffix
  = (Type, String, String -> String, Type -> TypeQ) -> Q Exp
forall types.
(types, String, String -> String, types -> TypeQ) -> Q Exp
mkTFunc (Type
typ, String
suffix, \ String
n -> String
"Function_new_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
n, Type -> TypeQ
forall p. p -> TypeQ
tyf)
  where tyf :: p -> TypeQ
tyf p
_n =
          let t :: TypeQ
t = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ
          in [t| FunPtr $( t ) -> IO (Function $( t )) |]

t_call :: Type -> String -> Q Exp
t_call :: Type -> String -> Q Exp
t_call Type
typ String
suffix
  = (Type, String, String -> String, Type -> TypeQ) -> Q Exp
forall types.
(types, String, String -> String, types -> TypeQ) -> Q Exp
mkTFunc (Type
typ, String
suffix, \ String
n -> String
"Function_call_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
n, Type -> TypeQ
forall p. p -> TypeQ
tyf)
  where tyf :: p -> TypeQ
tyf p
_n =
          let t :: TypeQ
t = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ
          in [t| Function $( t ) -> $( t ) |]

t_deleteFunction :: Type -> String -> Q Exp
t_deleteFunction :: Type -> String -> Q Exp
t_deleteFunction Type
typ String
suffix
  = (Type, String, String -> String, Type -> TypeQ) -> Q Exp
forall types.
(types, String, String -> String, types -> TypeQ) -> Q Exp
mkTFunc (Type
typ, String
suffix, \ String
n -> String
"Function_delete_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
n, Type -> TypeQ
forall p. p -> TypeQ
tyf)
  where tyf :: p -> TypeQ
tyf p
_n =
          let t :: TypeQ
t = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ
          in [t| Function $( t ) -> IO () |]


genFunctionInstanceFor :: Q Type -> FunctionParamInfo -> Q [Dec]
genFunctionInstanceFor :: TypeQ -> FunctionParamInfo -> Q [Dec]
genFunctionInstanceFor TypeQ
qtyp FunctionParamInfo
param
  = do let suffix :: String
suffix = FunctionParamInfo -> String
fpinfoSuffix FunctionParamInfo
param
       Type
typ <- TypeQ
qtyp
       Dec
f1 <- String -> (Type -> String -> Q Exp) -> Type -> String -> Q Dec
forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkNew String
"newFunction" Type -> String -> Q Exp
t_newFunction Type
typ String
suffix
       Dec
f2 <- String -> (Type -> String -> Q Exp) -> Type -> String -> Q Dec
forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkMember String
"call" Type -> String -> Q Exp
t_call Type
typ String
suffix
       Dec
f3 <- String -> (Type -> String -> Q Exp) -> Type -> String -> Q Dec
forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkMember String
"deleteFunction" Type -> String -> Q Exp
t_deleteFunction Type
typ String
suffix
       Dec
wrap <- (Type, String) -> Q Dec
mkWrapper (Type
typ,String
suffix)
       Q () -> Q ()
addModFinalizer
         (ForeignSrcLang -> String -> Q ()
addForeignSource ForeignSrcLang
LangCxx
           (String
"\n#include \"functional\"\n\n\n#include \"Function.h\"\n\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ (let headers :: [HeaderName]
headers = FunctionParamInfo -> [HeaderName]
fpinfoCxxHeaders FunctionParamInfo
param
                    f :: HeaderName -> String
f HeaderName
x = CMacro Identity -> String
renderCMacro (HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
Include HeaderName
x)
                in (HeaderName -> String) -> [HeaderName] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HeaderName -> String
f [HeaderName]
headers
               )
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ (let nss :: [Namespace]
nss = FunctionParamInfo -> [Namespace]
fpinfoCxxNamespaces FunctionParamInfo
param
                    f :: Namespace -> String
f Namespace
x = CStatement Identity -> String
renderCStmt (Namespace -> CStatement Identity
forall (f :: * -> *). Namespace -> CStatement f
UsingNamespace Namespace
x)
                in (Namespace -> String) -> [Namespace] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Namespace -> String
f [Namespace]
nss
               )
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ (let retstr :: String
retstr = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"void" (FunctionParamInfo -> Maybe String
fpinfoCxxRetType FunctionParamInfo
param)
                    argstr :: String
argstr = let args :: [(String, String)]
args = FunctionParamInfo -> [(String, String)]
fpinfoCxxArgTypes FunctionParamInfo
param
                                 vs :: String
vs = case [(String, String)]
args of
                                        [] -> String
"(,)"
                                        [(String, String)]
_ -> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                                               ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
t,String
x) -> String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") [(String, String)]
args
                             in String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
                in String
"Function(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suffix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
retstr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
argstr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")\n"
               )
           )
         )
       let lst :: [Dec]
lst = [Dec
f1,Dec
f2,Dec
f3]
       [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Cxt -> Type -> [Dec] -> Dec
mkInstance [] (Type -> Type -> Type
AppT (String -> Type
con String
"IFunction") Type
typ) [Dec]
lst
              , Cxt -> Type -> [Dec] -> Dec
mkInstance [] (Type -> Type -> Type
AppT (String -> Type
con String
"FunPtrWrapper") Type
typ) [Dec
wrap]
              ]