TH.hs

{-# 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 (typ1, typ2) suffix
  = mkTFunc ((typ1, typ2), suffix, \ n -> "Pair_new" <> n, tyf)
  where tyf _
          = let tp1 = pure typ1
                tp2 = pure typ2
              in [t| $( tp1 ) -> $( tp2 ) -> IO (Pair $( tp1 ) $( tp2 )) |]

t_deletePair :: (Type, Type) -> String -> Q Exp
t_deletePair (typ1, typ2) suffix
  = mkTFunc ((typ1, typ2), suffix, \ n -> "Pair_delete" <> n, tyf)
  where tyf _
          = let tp1 = pure typ1
                tp2 = pure typ2
              in [t| Pair $( tp1 ) $( tp2 ) -> IO () |]

t_first_get :: (Type, Type) -> String -> Q Exp
t_first_get (typ1, typ2) suffix
  = mkTFunc ((typ1, typ2), suffix, \ n -> "Pair_first_get" <> n, tyf)
  where tyf _
          = let tp1 = pure typ1
                tp2 = pure typ2
              in [t| Pair $( tp1 ) $( tp2 ) -> IO $( tp1 ) |]

t_first_set :: (Type, Type) -> String -> Q Exp
t_first_set (typ1, typ2) suffix
  = mkTFunc ((typ1, typ2), suffix, \ n -> "Pair_first_set" <> n, tyf)
  where tyf _
          = let tp1 = pure typ1
                tp2 = pure typ2
              in [t| Pair $( tp1 ) $( tp2 ) -> $( tp1 ) -> IO () |]

t_second_get :: (Type, Type) -> String -> Q Exp
t_second_get (typ1, typ2) suffix
  = mkTFunc
      ((typ1, typ2), suffix, \ n -> "Pair_second_get" <> n, tyf)
  where tyf _
          = let tp1 = pure typ1
                tp2 = pure typ2
              in [t| Pair $( tp1 ) $( tp2 ) -> IO $( tp2 ) |]

t_second_set :: (Type, Type) -> String -> Q Exp
t_second_set (typ1, typ2) suffix
  = mkTFunc
      ((typ1, typ2), suffix, \ n -> "Pair_second_set" <> n, tyf)
  where tyf _
          = let tp1 = pure typ1
                tp2 = pure typ2
              in [t| Pair $( tp1 ) $( tp2 ) -> $( tp2 ) -> IO () |]

genPairInstanceFor ::
                   IsCPrimitive ->
                     (Q Type, TemplateParamInfo) ->
                       (Q Type, TemplateParamInfo) -> Q [Dec]
genPairInstanceFor isCprim (qtyp1, param1) (qtyp2, param2)
  = do let params = map tpinfoSuffix [param1, param2]
       let suffix
             = concatMap (\ x -> "_" ++ tpinfoSuffix x) [param1, param2]
       callmod_ <- fmap loc_module location
       let callmod = dot2_ callmod_
       typ1 <- qtyp1
       typ2 <- qtyp2
       f1 <- mkNew "newPair" t_newPair (typ1, typ2) suffix
       f2 <- mkDelete "deletePair" t_deletePair (typ1, typ2) suffix
       vf1 <- mkMember "first_get" t_first_get (typ1, typ2) suffix
       vf2 <- mkMember "first_set" t_first_set (typ1, typ2) suffix
       vf3 <- mkMember "second_get" t_second_get (typ1, typ2) suffix
       vf4 <- mkMember "second_set" t_second_set (typ1, typ2) suffix
       addModFinalizer
         (addForeignSource LangCxx
            ("\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"
               ++
               let headers = concatMap tpinfoCxxHeaders [param1, param2]
                   f x = renderCMacro (Include x)
                 in concatMap f headers
                 ++
                 let nss = concatMap tpinfoCxxNamespaces [param1, param2]
                     f x = renderCStmt (UsingNamespace x)
                   in concatMap f nss
                   ++
                   "Pair_instance" ++
                     (case isCprim of
                          CPrim -> "_s"
                          NonCPrim -> "")
                       ++ "(" ++ intercalate ", " (callmod : params) ++ ")\n"))
       let lst = [f1, f2, vf1, vf2, vf3, vf4]
       pure [mkInstance [] (AppT (AppT (con "IPair") typ1) typ2) lst]