{-# LANGUAGE TemplateHaskell #-}
module STD.Pair.TH where
import Data.Char
import Data.List
import Data.Monoid
import Foreign.C.Types
import Foreign.Ptr
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import FFICXX.Runtime.CodeGen.Cxx
import FFICXX.Runtime.TH
import STD.Pair.Template

t_newPair :: (Type, Type) -> String -> Q Exp
t_newPair :: (Type, Type) -> String -> Q Exp
t_newPair (Type
typ1, Type
typ2) String
suffix
  = forall types.
(types, String, String -> String, types -> Q Type) -> Q Exp
mkTFunc ((Type
typ1, Type
typ2), String
suffix, \ String
n -> String
"Pair_new" forall a. Semigroup a => a -> a -> a
<> String
n, forall {m :: * -> *} {p}. Quote m => p -> m Type
tyf)
  where tyf :: p -> m Type
tyf p
_
          = let tp1 :: m Type
tp1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ1
                tp2 :: m Type
tp2 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ2
              in [t| $( tp1 ) -> $( tp2 ) -> IO (Pair $( tp1 ) $( tp2 )) |]

t_deletePair :: (Type, Type) -> String -> Q Exp
t_deletePair :: (Type, Type) -> String -> Q Exp
t_deletePair (Type
typ1, Type
typ2) String
suffix
  = forall types.
(types, String, String -> String, types -> Q Type) -> Q Exp
mkTFunc ((Type
typ1, Type
typ2), String
suffix, \ String
n -> String
"Pair_delete" forall a. Semigroup a => a -> a -> a
<> String
n, forall {m :: * -> *} {p}. Quote m => p -> m Type
tyf)
  where tyf :: p -> m Type
tyf p
_
          = let tp1 :: m Type
tp1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ1
                tp2 :: m Type
tp2 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ2
              in [t| Pair $( tp1 ) $( tp2 ) -> IO () |]

t_first_get :: (Type, Type) -> String -> Q Exp
t_first_get :: (Type, Type) -> String -> Q Exp
t_first_get (Type
typ1, Type
typ2) String
suffix
  = forall types.
(types, String, String -> String, types -> Q Type) -> Q Exp
mkTFunc ((Type
typ1, Type
typ2), String
suffix, \ String
n -> String
"Pair_first_get" forall a. Semigroup a => a -> a -> a
<> String
n, forall {m :: * -> *} {p}. Quote m => p -> m Type
tyf)
  where tyf :: p -> m Type
tyf p
_
          = let tp1 :: m Type
tp1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ1
                tp2 :: m Type
tp2 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ2
              in [t| Pair $( tp1 ) $( tp2 ) -> IO $( tp1 ) |]

t_first_set :: (Type, Type) -> String -> Q Exp
t_first_set :: (Type, Type) -> String -> Q Exp
t_first_set (Type
typ1, Type
typ2) String
suffix
  = forall types.
(types, String, String -> String, types -> Q Type) -> Q Exp
mkTFunc ((Type
typ1, Type
typ2), String
suffix, \ String
n -> String
"Pair_first_set" forall a. Semigroup a => a -> a -> a
<> String
n, forall {m :: * -> *} {p}. Quote m => p -> m Type
tyf)
  where tyf :: p -> m Type
tyf p
_
          = let tp1 :: m Type
tp1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ1
                tp2 :: m Type
tp2 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ2
              in [t| Pair $( tp1 ) $( tp2 ) -> $( tp1 ) -> IO () |]

t_second_get :: (Type, Type) -> String -> Q Exp
t_second_get :: (Type, Type) -> String -> Q Exp
t_second_get (Type
typ1, Type
typ2) String
suffix
  = forall types.
(types, String, String -> String, types -> Q Type) -> Q Exp
mkTFunc
      ((Type
typ1, Type
typ2), String
suffix, \ String
n -> String
"Pair_second_get" forall a. Semigroup a => a -> a -> a
<> String
n, forall {m :: * -> *} {p}. Quote m => p -> m Type
tyf)
  where tyf :: p -> m Type
tyf p
_
          = let tp1 :: m Type
tp1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ1
                tp2 :: m Type
tp2 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ2
              in [t| Pair $( tp1 ) $( tp2 ) -> IO $( tp2 ) |]

t_second_set :: (Type, Type) -> String -> Q Exp
t_second_set :: (Type, Type) -> String -> Q Exp
t_second_set (Type
typ1, Type
typ2) String
suffix
  = forall types.
(types, String, String -> String, types -> Q Type) -> Q Exp
mkTFunc
      ((Type
typ1, Type
typ2), String
suffix, \ String
n -> String
"Pair_second_set" forall a. Semigroup a => a -> a -> a
<> String
n, forall {m :: * -> *} {p}. Quote m => p -> m Type
tyf)
  where tyf :: p -> m Type
tyf p
_
          = let tp1 :: m Type
tp1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ1
                tp2 :: m Type
tp2 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ2
              in [t| Pair $( tp1 ) $( tp2 ) -> $( tp2 ) -> IO () |]

genPairInstanceFor ::
                   IsCPrimitive ->
                     (Q Type, TemplateParamInfo) ->
                       (Q Type, TemplateParamInfo) -> Q [Dec]
genPairInstanceFor :: IsCPrimitive
-> (Q Type, TemplateParamInfo)
-> (Q Type, TemplateParamInfo)
-> Q [Dec]
genPairInstanceFor IsCPrimitive
isCprim (Q Type
qtyp1, TemplateParamInfo
param1) (Q Type
qtyp2, TemplateParamInfo
param2)
  = do let params :: [String]
params = forall a b. (a -> b) -> [a] -> [b]
map TemplateParamInfo -> String
tpinfoSuffix [TemplateParamInfo
param1, TemplateParamInfo
param2]
       let suffix :: String
suffix
             = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\ TemplateParamInfo
x -> String
"_" forall a. [a] -> [a] -> [a]
++ TemplateParamInfo -> String
tpinfoSuffix TemplateParamInfo
x) [TemplateParamInfo
param1, TemplateParamInfo
param2]
       String
callmod_ <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Loc -> String
loc_module Q Loc
location
       let callmod :: String
callmod = String -> String
dot2_ String
callmod_
       Type
typ1 <- Q Type
qtyp1
       Type
typ2 <- Q Type
qtyp2
       Dec
f1 <- forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkNew String
"newPair" (Type, Type) -> String -> Q Exp
t_newPair (Type
typ1, Type
typ2) String
suffix
       Dec
f2 <- forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkDelete String
"deletePair" (Type, Type) -> String -> Q Exp
t_deletePair (Type
typ1, Type
typ2) String
suffix
       Dec
vf1 <- forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkMember String
"first_get" (Type, Type) -> String -> Q Exp
t_first_get (Type
typ1, Type
typ2) String
suffix
       Dec
vf2 <- forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkMember String
"first_set" (Type, Type) -> String -> Q Exp
t_first_set (Type
typ1, Type
typ2) String
suffix
       Dec
vf3 <- forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkMember String
"second_get" (Type, Type) -> String -> Q Exp
t_second_get (Type
typ1, Type
typ2) String
suffix
       Dec
vf4 <- forall types.
String -> (types -> String -> Q Exp) -> types -> String -> Q Dec
mkMember String
"second_set" (Type, Type) -> String -> Q Exp
t_second_set (Type
typ1, Type
typ2) String
suffix
       Q () -> Q ()
addModFinalizer
         (ForeignSrcLang -> String -> Q ()
addForeignSource ForeignSrcLang
LangCxx
            (String
"\n#include \"MacroPatternMatch.h\"\n\n\n#include \"utility\"\n\n\n#define Pair_new(callmod, tp1, tp2) \\\nextern \"C\" {\\\nvoid* Pair_new_##tp1##_##tp2 ( tp1##_p x, tp2##_p y );}\\\ninline void* Pair_new_##tp1##_##tp2 ( tp1##_p x, tp2##_p y ) {\\\nreturn static_cast<void*>(new std::pair<tp1, tp2>(*(from_nonconst_to_nonconst<tp1, tp1##_t>(x)), *(from_nonconst_to_nonconst<tp2, tp2##_t>(y))));\\\n}\\\nauto a_##callmod##_Pair_new_##tp1##_##tp2=Pair_new_##tp1##_##tp2;\n\n\n#define Pair_delete(callmod, tp1, tp2) \\\nextern \"C\" {\\\nvoid Pair_delete_##tp1##_##tp2 ( void* p );}\\\ninline void Pair_delete_##tp1##_##tp2 ( void* p ) {\\\ndelete static_cast<std::pair<tp1, tp2>*>(p);\\\n}\\\nauto a_##callmod##_Pair_delete_##tp1##_##tp2=Pair_delete_##tp1##_##tp2;\n\n\n#define Pair_new_s(callmod, tp1, tp2) \\\nextern \"C\" {\\\nvoid* Pair_new_##tp1##_##tp2 ( tp1 x, tp2 y );}\\\ninline void* Pair_new_##tp1##_##tp2 ( tp1 x, tp2 y ) {\\\nreturn static_cast<void*>(new std::pair<tp1, tp2>(x, y));\\\n}\\\nauto a_##callmod##_Pair_new_##tp1##_##tp2=Pair_new_##tp1##_##tp2;\n\n\n#define Pair_delete_s(callmod, tp1, tp2) \\\nextern \"C\" {\\\nvoid Pair_delete_##tp1##_##tp2 ( void* p );}\\\ninline void Pair_delete_##tp1##_##tp2 ( void* p ) {\\\ndelete static_cast<std::pair<tp1, tp2>*>(p);\\\n}\\\nauto a_##callmod##_Pair_delete_##tp1##_##tp2=Pair_delete_##tp1##_##tp2;\n\n\n#define Pair_first_get(callmod, tp1, tp2) \\\nextern \"C\" {\\\ntp1##_p Pair_first_get_##tp1##_##tp2 ( void* p );}\\\ninline tp1##_p Pair_first_get_##tp1##_##tp2 ( void* p ) {\\\nreturn from_nonconst_to_nonconst<tp1##_t, tp1>((tp1*)&((static_cast<std::pair<tp1, tp2>*>(p))->first));\\\n}\\\nauto a_##callmod##_Pair_first_get_##tp1##_##tp2=Pair_first_get_##tp1##_##tp2;\n\n\n#define Pair_first_set(callmod, tp1, tp2) \\\nextern \"C\" {\\\nvoid Pair_first_set_##tp1##_##tp2 ( void* p, tp1##_p value );}\\\ninline void Pair_first_set_##tp1##_##tp2 ( void* p, tp1##_p value ) {\\\n((static_cast<std::pair<tp1, tp2>*>(p))->first)=value;\\\n}\\\nauto a_##callmod##_Pair_first_set_##tp1##_##tp2=Pair_first_set_##tp1##_##tp2;\n\n\n#define Pair_second_get(callmod, tp1, tp2) \\\nextern \"C\" {\\\ntp2##_p Pair_second_get_##tp1##_##tp2 ( void* p );}\\\ninline tp2##_p Pair_second_get_##tp1##_##tp2 ( void* p ) {\\\nreturn from_nonconst_to_nonconst<tp2##_t, tp2>((tp2*)&((static_cast<std::pair<tp1, tp2>*>(p))->second));\\\n}\\\nauto a_##callmod##_Pair_second_get_##tp1##_##tp2=Pair_second_get_##tp1##_##tp2;\n\n\n#define Pair_second_set(callmod, tp1, tp2) \\\nextern \"C\" {\\\nvoid Pair_second_set_##tp1##_##tp2 ( void* p, tp2##_p value );}\\\ninline void Pair_second_set_##tp1##_##tp2 ( void* p, tp2##_p value ) {\\\n((static_cast<std::pair<tp1, tp2>*>(p))->second)=value;\\\n}\\\nauto a_##callmod##_Pair_second_set_##tp1##_##tp2=Pair_second_set_##tp1##_##tp2;\n\n\n#define Pair_first_get_s(callmod, tp1, tp2) \\\nextern \"C\" {\\\ntp1 Pair_first_get_##tp1##_##tp2 ( void* p );}\\\ninline tp1 Pair_first_get_##tp1##_##tp2 ( void* p ) {\\\nreturn (static_cast<std::pair<tp1, tp2>*>(p))->first;\\\n}\\\nauto a_##callmod##_Pair_first_get_##tp1##_##tp2=Pair_first_get_##tp1##_##tp2;\n\n\n#define Pair_first_set_s(callmod, tp1, tp2) \\\nextern \"C\" {\\\nvoid Pair_first_set_##tp1##_##tp2 ( void* p, tp1 value );}\\\ninline void Pair_first_set_##tp1##_##tp2 ( void* p, tp1 value ) {\\\n((static_cast<std::pair<tp1, tp2>*>(p))->first)=value;\\\n}\\\nauto a_##callmod##_Pair_first_set_##tp1##_##tp2=Pair_first_set_##tp1##_##tp2;\n\n\n#define Pair_second_get_s(callmod, tp1, tp2) \\\nextern \"C\" {\\\ntp2 Pair_second_get_##tp1##_##tp2 ( void* p );}\\\ninline tp2 Pair_second_get_##tp1##_##tp2 ( void* p ) {\\\nreturn (static_cast<std::pair<tp1, tp2>*>(p))->second;\\\n}\\\nauto a_##callmod##_Pair_second_get_##tp1##_##tp2=Pair_second_get_##tp1##_##tp2;\n\n\n#define Pair_second_set_s(callmod, tp1, tp2) \\\nextern \"C\" {\\\nvoid Pair_second_set_##tp1##_##tp2 ( void* p, tp2 value );}\\\ninline void Pair_second_set_##tp1##_##tp2 ( void* p, tp2 value ) {\\\n((static_cast<std::pair<tp1, tp2>*>(p))->second)=value;\\\n}\\\nauto a_##callmod##_Pair_second_set_##tp1##_##tp2=Pair_second_set_##tp1##_##tp2;\n\n\n#define Pair_instance(callmod, tp1, tp2) \\\nPair_new(callmod, tp1, tp2)\\\nPair_delete(callmod, tp1, tp2)\\\nPair_first_get(callmod, tp1, tp2)\\\nPair_first_set(callmod, tp1, tp2)\\\nPair_second_get(callmod, tp1, tp2)\\\nPair_second_set(callmod, tp1, tp2)\n\n\n#define Pair_instance_s(callmod, tp1, tp2) \\\nPair_new_s(callmod, tp1, tp2)\\\nPair_delete_s(callmod, tp1, tp2)\\\nPair_first_get_s(callmod, tp1, tp2)\\\nPair_first_set_s(callmod, tp1, tp2)\\\nPair_second_get_s(callmod, tp1, tp2)\\\nPair_second_set_s(callmod, tp1, tp2)\n\n"
               forall a. [a] -> [a] -> [a]
++
               let headers :: [HeaderName]
headers = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TemplateParamInfo -> [HeaderName]
tpinfoCxxHeaders [TemplateParamInfo
param1, TemplateParamInfo
param2]
                   f :: HeaderName -> String
f HeaderName
x = CMacro Identity -> String
renderCMacro (forall (f :: * -> *). HeaderName -> CMacro f
Include HeaderName
x)
                 in forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HeaderName -> String
f [HeaderName]
headers
                 forall a. [a] -> [a] -> [a]
++
                 let nss :: [Namespace]
nss = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TemplateParamInfo -> [Namespace]
tpinfoCxxNamespaces [TemplateParamInfo
param1, TemplateParamInfo
param2]
                     f :: Namespace -> String
f Namespace
x = CStatement Identity -> String
renderCStmt (forall (f :: * -> *). Namespace -> CStatement f
UsingNamespace Namespace
x)
                   in forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Namespace -> String
f [Namespace]
nss
                   forall a. [a] -> [a] -> [a]
++
                   String
"Pair_instance" forall a. [a] -> [a] -> [a]
++
                     (case IsCPrimitive
isCprim of
                          IsCPrimitive
CPrim -> String
"_s"
                          IsCPrimitive
NonCPrim -> String
"")
                       forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (String
callmod forall a. a -> [a] -> [a]
: [String]
params) forall a. [a] -> [a] -> [a]
++ String
")\n"))
       let lst :: [Dec]
lst = [Dec
f1, Dec
f2, Dec
vf1, Dec
vf2, Dec
vf3, Dec
vf4]
       forall (f :: * -> *) a. Applicative f => a -> f a
pure [Cxt -> Type -> [Dec] -> Dec
mkInstance [] (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (String -> Type
con String
"IPair") Type
typ1) Type
typ2) [Dec]
lst]