TH.hs

{-# LANGUAGE TemplateHaskell #-}
module STD.Vector.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.Vector.Template
import STD.VectorIterator.Template

t_newVector :: Type -> String -> Q Exp
t_newVector typ1 suffix
  = mkTFunc (typ1, suffix, \ n -> "Vector_new" <> n, tyf)
  where tyf _ = let tp1 = pure typ1 in [t| IO (Vector $( tp1 )) |]

t_begin :: Type -> String -> Q Exp
t_begin typ1 suffix
  = mkTFunc (typ1, suffix, \ n -> "Vector_begin" <> n, tyf)
  where tyf _
          = let tp1 = pure typ1 in
              [t| Vector $( tp1 ) -> IO (VectorIterator $( tp1 )) |]

t_end :: Type -> String -> Q Exp
t_end typ1 suffix
  = mkTFunc (typ1, suffix, \ n -> "Vector_end" <> n, tyf)
  where tyf _
          = let tp1 = pure typ1 in
              [t| Vector $( tp1 ) -> IO (VectorIterator $( tp1 )) |]

t_push_back :: Type -> String -> Q Exp
t_push_back typ1 suffix
  = mkTFunc (typ1, suffix, \ n -> "Vector_push_back" <> n, tyf)
  where tyf _
          = let tp1 = pure typ1 in
              [t| Vector $( tp1 ) -> $( tp1 ) -> IO () |]

t_pop_back :: Type -> String -> Q Exp
t_pop_back typ1 suffix
  = mkTFunc (typ1, suffix, \ n -> "Vector_pop_back" <> n, tyf)
  where tyf _
          = let tp1 = pure typ1 in [t| Vector $( tp1 ) -> IO () |]

t_at :: Type -> String -> Q Exp
t_at typ1 suffix
  = mkTFunc (typ1, suffix, \ n -> "Vector_at" <> n, tyf)
  where tyf _
          = let tp1 = pure typ1 in
              [t| Vector $( tp1 ) -> CInt -> IO $( tp1 ) |]

t_size :: Type -> String -> Q Exp
t_size typ1 suffix
  = mkTFunc (typ1, suffix, \ n -> "Vector_size" <> n, tyf)
  where tyf _
          = let tp1 = pure typ1 in [t| Vector $( tp1 ) -> IO CInt |]

t_deleteVector :: Type -> String -> Q Exp
t_deleteVector typ1 suffix
  = mkTFunc (typ1, suffix, \ n -> "Vector_delete" <> n, tyf)
  where tyf _
          = let tp1 = pure typ1 in [t| Vector $( tp1 ) -> IO () |]

genVectorInstanceFor ::
                     IsCPrimitive -> (Q Type, TemplateParamInfo) -> Q [Dec]
genVectorInstanceFor isCprim (qtyp1, param1)
  = do let params = map tpinfoSuffix [param1]
       let suffix = concatMap (\ x -> "_" ++ tpinfoSuffix x) [param1]
       callmod_ <- fmap loc_module location
       let callmod = dot2_ callmod_
       typ1 <- qtyp1
       f1 <- mkNew "newVector" t_newVector typ1 suffix
       f2 <- mkMember "begin" t_begin typ1 suffix
       f3 <- mkMember "end" t_end typ1 suffix
       f4 <- mkMember "push_back" t_push_back typ1 suffix
       f5 <- mkMember "pop_back" t_pop_back typ1 suffix
       f6 <- mkMember "at" t_at typ1 suffix
       f7 <- mkMember "size" t_size typ1 suffix
       f8 <- mkDelete "deleteVector" t_deleteVector typ1 suffix
       addModFinalizer
         (addForeignSource LangCxx
            ("\n#include \"MacroPatternMatch.h\"\n\n\n#include \"vector\"\n\n\n#define Vector_new(callmod, tp1) \\\nextern \"C\" {\\\nvoid* Vector_new_##tp1 (  );}\\\ninline void* Vector_new_##tp1 (  ) {\\\nreturn static_cast<void*>(new std::vector<tp1>());\\\n}\\\nauto a_##callmod##_Vector_new_##tp1=Vector_new_##tp1;\n\n\n#define Vector_begin(callmod, tp1) \\\nextern \"C\" {\\\nvoid* Vector_begin_##tp1 ( void* p );}\\\ninline void* Vector_begin_##tp1 ( void* p ) {\\\nstd::vector<tp1>::iterator* r=new std::vector<tp1>::iterator((static_cast<std::vector<tp1>*>(p))->begin());return static_cast<void*>(r);\\\n}\\\nauto a_##callmod##_Vector_begin_##tp1=Vector_begin_##tp1;\n\n\n#define Vector_end(callmod, tp1) \\\nextern \"C\" {\\\nvoid* Vector_end_##tp1 ( void* p );}\\\ninline void* Vector_end_##tp1 ( void* p ) {\\\nstd::vector<tp1>::iterator* r=new std::vector<tp1>::iterator((static_cast<std::vector<tp1>*>(p))->end());return static_cast<void*>(r);\\\n}\\\nauto a_##callmod##_Vector_end_##tp1=Vector_end_##tp1;\n\n\n#define Vector_push_back(callmod, tp1) \\\nextern \"C\" {\\\nvoid Vector_push_back_##tp1 ( void* p, tp1##_p x );}\\\ninline void Vector_push_back_##tp1 ( void* p, tp1##_p x ) {\\\n(static_cast<std::vector<tp1>*>(p))->push_back(*(from_nonconst_to_nonconst<tp1, tp1##_t>(x)));\\\n}\\\nauto a_##callmod##_Vector_push_back_##tp1=Vector_push_back_##tp1;\n\n\n#define Vector_pop_back(callmod, tp1) \\\nextern \"C\" {\\\nvoid Vector_pop_back_##tp1 ( void* p );}\\\ninline void Vector_pop_back_##tp1 ( void* p ) {\\\n(static_cast<std::vector<tp1>*>(p))->pop_back();\\\n}\\\nauto a_##callmod##_Vector_pop_back_##tp1=Vector_pop_back_##tp1;\n\n\n#define Vector_at(callmod, tp1) \\\nextern \"C\" {\\\ntp1##_p Vector_at_##tp1 ( void* p, int n );}\\\ninline tp1##_p Vector_at_##tp1 ( void* p, int n ) {\\\nreturn from_nonconst_to_nonconst<tp1##_t, tp1>((tp1*)&((static_cast<std::vector<tp1>*>(p))->at(n)));\\\n}\\\nauto a_##callmod##_Vector_at_##tp1=Vector_at_##tp1;\n\n\n#define Vector_size(callmod, tp1) \\\nextern \"C\" {\\\nint Vector_size_##tp1 ( void* p );}\\\ninline int Vector_size_##tp1 ( void* p ) {\\\nreturn (static_cast<std::vector<tp1>*>(p))->size();\\\n}\\\nauto a_##callmod##_Vector_size_##tp1=Vector_size_##tp1;\n\n\n#define Vector_delete(callmod, tp1) \\\nextern \"C\" {\\\nvoid Vector_delete_##tp1 ( void* p );}\\\ninline void Vector_delete_##tp1 ( void* p ) {\\\ndelete static_cast<std::vector<tp1>*>(p);\\\n}\\\nauto a_##callmod##_Vector_delete_##tp1=Vector_delete_##tp1;\n\n\n#define Vector_new_s(callmod, tp1) \\\nextern \"C\" {\\\nvoid* Vector_new_##tp1 (  );}\\\ninline void* Vector_new_##tp1 (  ) {\\\nreturn static_cast<void*>(new std::vector<tp1>());\\\n}\\\nauto a_##callmod##_Vector_new_##tp1=Vector_new_##tp1;\n\n\n#define Vector_begin_s(callmod, tp1) \\\nextern \"C\" {\\\nvoid* Vector_begin_##tp1 ( void* p );}\\\ninline void* Vector_begin_##tp1 ( void* p ) {\\\nstd::vector<tp1>::iterator* r=new std::vector<tp1>::iterator((static_cast<std::vector<tp1>*>(p))->begin());return static_cast<void*>(r);\\\n}\\\nauto a_##callmod##_Vector_begin_##tp1=Vector_begin_##tp1;\n\n\n#define Vector_end_s(callmod, tp1) \\\nextern \"C\" {\\\nvoid* Vector_end_##tp1 ( void* p );}\\\ninline void* Vector_end_##tp1 ( void* p ) {\\\nstd::vector<tp1>::iterator* r=new std::vector<tp1>::iterator((static_cast<std::vector<tp1>*>(p))->end());return static_cast<void*>(r);\\\n}\\\nauto a_##callmod##_Vector_end_##tp1=Vector_end_##tp1;\n\n\n#define Vector_push_back_s(callmod, tp1) \\\nextern \"C\" {\\\nvoid Vector_push_back_##tp1 ( void* p, tp1 x );}\\\ninline void Vector_push_back_##tp1 ( void* p, tp1 x ) {\\\n(static_cast<std::vector<tp1>*>(p))->push_back(x);\\\n}\\\nauto a_##callmod##_Vector_push_back_##tp1=Vector_push_back_##tp1;\n\n\n#define Vector_pop_back_s(callmod, tp1) \\\nextern \"C\" {\\\nvoid Vector_pop_back_##tp1 ( void* p );}\\\ninline void Vector_pop_back_##tp1 ( void* p ) {\\\n(static_cast<std::vector<tp1>*>(p))->pop_back();\\\n}\\\nauto a_##callmod##_Vector_pop_back_##tp1=Vector_pop_back_##tp1;\n\n\n#define Vector_at_s(callmod, tp1) \\\nextern \"C\" {\\\ntp1 Vector_at_##tp1 ( void* p, int n );}\\\ninline tp1 Vector_at_##tp1 ( void* p, int n ) {\\\nreturn (static_cast<std::vector<tp1>*>(p))->at(n);\\\n}\\\nauto a_##callmod##_Vector_at_##tp1=Vector_at_##tp1;\n\n\n#define Vector_size_s(callmod, tp1) \\\nextern \"C\" {\\\nint Vector_size_##tp1 ( void* p );}\\\ninline int Vector_size_##tp1 ( void* p ) {\\\nreturn (static_cast<std::vector<tp1>*>(p))->size();\\\n}\\\nauto a_##callmod##_Vector_size_##tp1=Vector_size_##tp1;\n\n\n#define Vector_delete_s(callmod, tp1) \\\nextern \"C\" {\\\nvoid Vector_delete_##tp1 ( void* p );}\\\ninline void Vector_delete_##tp1 ( void* p ) {\\\ndelete static_cast<std::vector<tp1>*>(p);\\\n}\\\nauto a_##callmod##_Vector_delete_##tp1=Vector_delete_##tp1;\n\n\n#define Vector_instance(callmod, tp1) \\\nVector_new(callmod, tp1)\\\nVector_begin(callmod, tp1)\\\nVector_end(callmod, tp1)\\\nVector_push_back(callmod, tp1)\\\nVector_pop_back(callmod, tp1)\\\nVector_at(callmod, tp1)\\\nVector_size(callmod, tp1)\\\nVector_delete(callmod, tp1)\n\n\n#define Vector_instance_s(callmod, tp1) \\\nVector_new_s(callmod, tp1)\\\nVector_begin_s(callmod, tp1)\\\nVector_end_s(callmod, tp1)\\\nVector_push_back_s(callmod, tp1)\\\nVector_pop_back_s(callmod, tp1)\\\nVector_at_s(callmod, tp1)\\\nVector_size_s(callmod, tp1)\\\nVector_delete_s(callmod, tp1)\n\n"
               ++
               let headers = concatMap tpinfoCxxHeaders [param1]
                   f x = renderCMacro (Include x)
                 in concatMap f headers
                 ++
                 let nss = concatMap tpinfoCxxNamespaces [param1]
                     f x = renderCStmt (UsingNamespace x)
                   in concatMap f nss
                   ++
                   "Vector_instance" ++
                     (case isCprim of
                          CPrim -> "_s"
                          NonCPrim -> "")
                       ++ "(" ++ intercalate ", " (callmod : params) ++ ")\n"))
       let lst = [f1, f2, f3, f4, f5, f6, f7, f8]
       pure [mkInstance [] (AppT (con "IVector") typ1) lst]