{-# LANGUAGE TemplateHaskell #-}

module FFICXX.Runtime.TH where

--
import FFICXX.Runtime.CodeGen.Cxx (HeaderName, Namespace)
import Language.Haskell.TH (forImpD, safe, varE)
import Language.Haskell.TH.Syntax
  ( Body (NormalB),
    Callconv (CCall),
    Clause (..),
    Cxt,
    Dec (..),
    Exp (..),
    Pat (..),
    Q,
    Type (..),
    addTopDecls,
    mkNameS,
    newName,
  )

-- | Primitive C type like int, double should be treated differently than
--   Non-primitive type. The primitive type detection is not yet automatic.
--   So we manually mark template instantiation with this boolean parameter.
data IsCPrimitive
  = CPrim
  | NonCPrim
  deriving (Int -> IsCPrimitive -> ShowS
[IsCPrimitive] -> ShowS
IsCPrimitive -> String
(Int -> IsCPrimitive -> ShowS)
-> (IsCPrimitive -> String)
-> ([IsCPrimitive] -> ShowS)
-> Show IsCPrimitive
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IsCPrimitive -> ShowS
showsPrec :: Int -> IsCPrimitive -> ShowS
$cshow :: IsCPrimitive -> String
show :: IsCPrimitive -> String
$cshowList :: [IsCPrimitive] -> ShowS
showList :: [IsCPrimitive] -> ShowS
Show)

-- | template parameter: A,B,.. in T<A,B..>
data TemplateParamInfo = TPInfo
  { TemplateParamInfo -> String
tpinfoCxxType :: String,
    -- , tpinfoIsCPrimitive  :: IsCPrimitive  -- ^ whether the parameter is C-primitive type
    TemplateParamInfo -> [HeaderName]
tpinfoCxxHeaders :: [HeaderName],
    TemplateParamInfo -> [Namespace]
tpinfoCxxNamespaces :: [Namespace],
    TemplateParamInfo -> String
tpinfoSuffix :: String
  }
  deriving (Int -> TemplateParamInfo -> ShowS
[TemplateParamInfo] -> ShowS
TemplateParamInfo -> String
(Int -> TemplateParamInfo -> ShowS)
-> (TemplateParamInfo -> String)
-> ([TemplateParamInfo] -> ShowS)
-> Show TemplateParamInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TemplateParamInfo -> ShowS
showsPrec :: Int -> TemplateParamInfo -> ShowS
$cshow :: TemplateParamInfo -> String
show :: TemplateParamInfo -> String
$cshowList :: [TemplateParamInfo] -> ShowS
showList :: [TemplateParamInfo] -> ShowS
Show)

-- | function pointer parameter A(B,C,..) in std::function<A(B,C,..)>
data FunctionParamInfo = FPInfo
  { FunctionParamInfo -> [(String, String)]
fpinfoCxxArgTypes :: [(String, String)],
    FunctionParamInfo -> Maybe String
fpinfoCxxRetType :: Maybe String,
    FunctionParamInfo -> [HeaderName]
fpinfoCxxHeaders :: [HeaderName],
    FunctionParamInfo -> [Namespace]
fpinfoCxxNamespaces :: [Namespace],
    FunctionParamInfo -> String
fpinfoSuffix :: String
  }
  deriving (Int -> FunctionParamInfo -> ShowS
[FunctionParamInfo] -> ShowS
FunctionParamInfo -> String
(Int -> FunctionParamInfo -> ShowS)
-> (FunctionParamInfo -> String)
-> ([FunctionParamInfo] -> ShowS)
-> Show FunctionParamInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FunctionParamInfo -> ShowS
showsPrec :: Int -> FunctionParamInfo -> ShowS
$cshow :: FunctionParamInfo -> String
show :: FunctionParamInfo -> String
$cshowList :: [FunctionParamInfo] -> ShowS
showList :: [FunctionParamInfo] -> ShowS
Show)

con :: String -> Type
con :: String -> Type
con = Name -> Type
ConT (Name -> Type) -> (String -> Name) -> String -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkNameS

-- |
mkInstance :: Cxt -> Type -> [Dec] -> Dec
mkInstance :: Cxt -> Type -> [Dec] -> Dec
mkInstance = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing

-- |
mkTFunc :: (types, String, String -> String, types -> Q Type) -> Q Exp
mkTFunc :: forall types. (types, String, ShowS, types -> Q Type) -> Q Exp
mkTFunc (types
typs, String
suffix, ShowS
nf, types -> Q Type
tyf) =
  do
    let fn :: String
fn = ShowS
nf String
suffix
    let fn' :: String
fn' = String
"c_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fn
    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
fn Name
n (types -> Q Type
tyf types
typs)
    [Dec] -> Q ()
addTopDecls [Dec
d]
    [|$(varE n)|]

-- |
mkMember :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkMember :: forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkMember String
fname types -> String -> Q Exp
f types
typ String
suffix = do
  let x :: Name
x = String -> Name
mkNameS String
"x"
  Exp
e <- types -> String -> Q Exp
f types
typ String
suffix
  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
fname) [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
x] (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE Exp
e (Name -> Exp
VarE Name
x))) []]

-- |
mkNew :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkNew :: forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkNew String
fname types -> String -> Q Exp
f types
typ String
suffix = do
  Exp
e <- types -> String -> Q Exp
f types
typ String
suffix
  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
fname)
      [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
e) []]

-- |
mkDelete :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkDelete :: forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkDelete = String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkMember

-- |
mkFunc :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkFunc :: forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkFunc String
fname types -> String -> Q Exp
f types
typ String
suffix = do
  let x :: Name
x = String -> Name
mkNameS String
"x"
  Exp
e <- types -> String -> Q Exp
f types
typ String
suffix
  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
fname) [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
x] (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE Exp
e (Name -> Exp
VarE Name
x))) []]

-- | utility function for converting '.' to '_'
dot2_ :: String -> String
dot2_ :: ShowS
dot2_ = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' then Char
'_' else Char
c)