{-# LANGUAGE TemplateHaskell #-}

module FFICXX.Runtime.TH where

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
                                  )
--
import FFICXX.Runtime.CodeGen.Cxx ( HeaderName, Namespace)


-- | 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
showList :: [IsCPrimitive] -> ShowS
$cshowList :: [IsCPrimitive] -> ShowS
show :: IsCPrimitive -> String
$cshow :: IsCPrimitive -> String
showsPrec :: Int -> IsCPrimitive -> ShowS
$cshowsPrec :: Int -> 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
showList :: [TemplateParamInfo] -> ShowS
$cshowList :: [TemplateParamInfo] -> ShowS
show :: TemplateParamInfo -> String
$cshow :: TemplateParamInfo -> String
showsPrec :: Int -> TemplateParamInfo -> ShowS
$cshowsPrec :: Int -> 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
showList :: [FunctionParamInfo] -> ShowS
$cshowList :: [FunctionParamInfo] -> ShowS
show :: FunctionParamInfo -> String
$cshow :: FunctionParamInfo -> String
showsPrec :: Int -> FunctionParamInfo -> ShowS
$cshowsPrec :: Int -> 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 :: (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
newName String
fn'
       Dec
d <- Callconv -> Safety -> String -> Name -> Q Type -> DecQ
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 :: String -> (types -> String -> Q Exp) -> types -> String -> DecQ
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 -> DecQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> DecQ) -> Dec -> DecQ
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 :: String -> (types -> String -> Q Exp) -> types -> String -> DecQ
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 -> DecQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> DecQ) -> Dec -> DecQ
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 :: String -> (types -> String -> Q Exp) -> types -> String -> DecQ
mkDelete = String -> (types -> String -> Q Exp) -> types -> String -> DecQ
forall types.
String -> (types -> String -> Q Exp) -> types -> String -> DecQ
mkMember

-- | 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)