{-# LANGUAGE TemplateHaskell #-}

module FFICXX.Runtime.Function.TH where

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

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
forall (m :: * -> *). Quote m => String -> m Name
newName String
fn
    Dec
d <- Callconv -> Safety -> String -> Name -> Q Type -> Q Dec
forall (m :: * -> *).
Quote m =>
Callconv -> Safety -> String -> Name -> m Type -> m 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 a. a -> Q a
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 -> Q Type) -> Q Exp
forall types.
(types, String, String -> String, types -> Q Type) -> 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 -> Q Type
forall {m :: * -> *} {p}. Quote m => p -> m Type
tyf)
  where
    tyf :: p -> m Type
tyf p
_n =
      let t :: m Type
t = Type -> m Type
forall a. a -> m a
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 -> Q Type) -> Q Exp
forall types.
(types, String, String -> String, types -> Q Type) -> 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 -> Q Type
forall {m :: * -> *} {p}. Quote m => p -> m Type
tyf)
  where
    tyf :: p -> m Type
tyf p
_n =
      let t :: m Type
t = Type -> m Type
forall a. a -> m a
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 -> Q Type) -> Q Exp
forall types.
(types, String, String -> String, types -> Q Type) -> 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 -> Q Type
forall {m :: * -> *} {p}. Quote m => p -> m Type
tyf)
  where
    tyf :: p -> m Type
tyf p
_n =
      let t :: m Type
t = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ
       in [t|Function $(t) -> IO ()|]

genFunctionInstanceFor :: Q Type -> FunctionParamInfo -> Q [Dec]
genFunctionInstanceFor :: Q Type -> FunctionParamInfo -> Q [Dec]
genFunctionInstanceFor Q Type
qtyp FunctionParamInfo
param =
  do
    let suffix :: String
suffix = FunctionParamInfo -> String
fpinfoSuffix FunctionParamInfo
param
    Type
typ <- Q Type
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 a. a -> Q a
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]
      ]