TH.hs

{-# LANGUAGE TemplateHaskell #-}
module STD.Map.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.Map.Template
import STD.MapIterator.Template
import STD.Pair.Template

t_newMap :: (Type, Type) -> String -> Q Exp
t_newMap (typ1, typ2) suffix
  = mkTFunc ((typ1, typ2), suffix, \ n -> "Map_new" <> n, tyf)
  where tyf _
          = let tpk = pure typ1
                tpv = pure typ2
              in [t| IO (Map $( tpk ) $( tpv )) |]

t_begin :: (Type, Type) -> String -> Q Exp
t_begin (typ1, typ2) suffix
  = mkTFunc ((typ1, typ2), suffix, \ n -> "Map_begin" <> n, tyf)
  where tyf _
          = let tpk = pure typ1
                tpv = pure typ2
              in
              [t| Map $( tpk ) $( tpv ) -> IO (MapIterator $( tpk ) $( tpv )) |]

t_end :: (Type, Type) -> String -> Q Exp
t_end (typ1, typ2) suffix
  = mkTFunc ((typ1, typ2), suffix, \ n -> "Map_end" <> n, tyf)
  where tyf _
          = let tpk = pure typ1
                tpv = pure typ2
              in
              [t| Map $( tpk ) $( tpv ) -> IO (MapIterator $( tpk ) $( tpv )) |]

t_insert :: (Type, Type) -> String -> Q Exp
t_insert (typ1, typ2) suffix
  = mkTFunc ((typ1, typ2), suffix, \ n -> "Map_insert" <> n, tyf)
  where tyf _
          = let tpk = pure typ1
                tpv = pure typ2
              in [t| Map $( tpk ) $( tpv ) -> Pair $( tpk ) $( tpv ) -> IO () |]

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

t_deleteMap :: (Type, Type) -> String -> Q Exp
t_deleteMap (typ1, typ2) suffix
  = mkTFunc ((typ1, typ2), suffix, \ n -> "Map_delete" <> n, tyf)
  where tyf _
          = let tpk = pure typ1
                tpv = pure typ2
              in [t| Map $( tpk ) $( tpv ) -> IO () |]

genMapInstanceFor ::
                  IsCPrimitive ->
                    (Q Type, TemplateParamInfo) ->
                      (Q Type, TemplateParamInfo) -> Q [Dec]
genMapInstanceFor 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 "newMap" t_newMap (typ1, typ2) suffix
       f2 <- mkMember "begin" t_begin (typ1, typ2) suffix
       f3 <- mkMember "end" t_end (typ1, typ2) suffix
       f4 <- mkMember "insert" t_insert (typ1, typ2) suffix
       f5 <- mkMember "size" t_size (typ1, typ2) suffix
       f6 <- mkDelete "deleteMap" t_deleteMap (typ1, typ2) suffix
       addModFinalizer
         (addForeignSource LangCxx
            ("\n#include \"MacroPatternMatch.h\"\n\n\n#include \"map\"\n\n\n#define Map_new(callmod, tpk, tpv) \\\nextern \"C\" {\\\nvoid* Map_new_##tpk##_##tpv (  );}\\\ninline void* Map_new_##tpk##_##tpv (  ) {\\\nreturn static_cast<void*>(new std::map<tpk, tpv>());\\\n}\\\nauto a_##callmod##_Map_new_##tpk##_##tpv=Map_new_##tpk##_##tpv;\n\n\n#define Map_begin(callmod, tpk, tpv) \\\nextern \"C\" {\\\nvoid* Map_begin_##tpk##_##tpv ( void* p );}\\\ninline void* Map_begin_##tpk##_##tpv ( void* p ) {\\\nstd::map<tpk,tpv>::iterator* r=new std::map<tpk,tpv>::iterator((static_cast<std::map<tpk, tpv>*>(p))->begin());return static_cast<void*>(r);\\\n}\\\nauto a_##callmod##_Map_begin_##tpk##_##tpv=Map_begin_##tpk##_##tpv;\n\n\n#define Map_end(callmod, tpk, tpv) \\\nextern \"C\" {\\\nvoid* Map_end_##tpk##_##tpv ( void* p );}\\\ninline void* Map_end_##tpk##_##tpv ( void* p ) {\\\nstd::map<tpk,tpv>::iterator* r=new std::map<tpk,tpv>::iterator((static_cast<std::map<tpk, tpv>*>(p))->end());return static_cast<void*>(r);\\\n}\\\nauto a_##callmod##_Map_end_##tpk##_##tpv=Map_end_##tpk##_##tpv;\n\n\n#define Map_insert(callmod, tpk, tpv) \\\nextern \"C\" {\\\nvoid Map_insert_##tpk##_##tpv ( void* p, void* val );}\\\ninline void Map_insert_##tpk##_##tpv ( void* p, void* val ) {\\\n(static_cast<std::map<tpk, tpv>*>(p))->insert(std::move(*(static_cast<std::pair<tpk, tpv>*>(val))));\\\n}\\\nauto a_##callmod##_Map_insert_##tpk##_##tpv=Map_insert_##tpk##_##tpv;\n\n\n#define Map_size(callmod, tpk, tpv) \\\nextern \"C\" {\\\nint Map_size_##tpk##_##tpv ( void* p );}\\\ninline int Map_size_##tpk##_##tpv ( void* p ) {\\\nreturn (static_cast<std::map<tpk, tpv>*>(p))->size();\\\n}\\\nauto a_##callmod##_Map_size_##tpk##_##tpv=Map_size_##tpk##_##tpv;\n\n\n#define Map_delete(callmod, tpk, tpv) \\\nextern \"C\" {\\\nvoid Map_delete_##tpk##_##tpv ( void* p );}\\\ninline void Map_delete_##tpk##_##tpv ( void* p ) {\\\ndelete static_cast<std::map<tpk, tpv>*>(p);\\\n}\\\nauto a_##callmod##_Map_delete_##tpk##_##tpv=Map_delete_##tpk##_##tpv;\n\n\n#define Map_new_s(callmod, tpk, tpv) \\\nextern \"C\" {\\\nvoid* Map_new_##tpk##_##tpv (  );}\\\ninline void* Map_new_##tpk##_##tpv (  ) {\\\nreturn static_cast<void*>(new std::map<tpk, tpv>());\\\n}\\\nauto a_##callmod##_Map_new_##tpk##_##tpv=Map_new_##tpk##_##tpv;\n\n\n#define Map_begin_s(callmod, tpk, tpv) \\\nextern \"C\" {\\\nvoid* Map_begin_##tpk##_##tpv ( void* p );}\\\ninline void* Map_begin_##tpk##_##tpv ( void* p ) {\\\nstd::map<tpk,tpv>::iterator* r=new std::map<tpk,tpv>::iterator((static_cast<std::map<tpk, tpv>*>(p))->begin());return static_cast<void*>(r);\\\n}\\\nauto a_##callmod##_Map_begin_##tpk##_##tpv=Map_begin_##tpk##_##tpv;\n\n\n#define Map_end_s(callmod, tpk, tpv) \\\nextern \"C\" {\\\nvoid* Map_end_##tpk##_##tpv ( void* p );}\\\ninline void* Map_end_##tpk##_##tpv ( void* p ) {\\\nstd::map<tpk,tpv>::iterator* r=new std::map<tpk,tpv>::iterator((static_cast<std::map<tpk, tpv>*>(p))->end());return static_cast<void*>(r);\\\n}\\\nauto a_##callmod##_Map_end_##tpk##_##tpv=Map_end_##tpk##_##tpv;\n\n\n#define Map_insert_s(callmod, tpk, tpv) \\\nextern \"C\" {\\\nvoid Map_insert_##tpk##_##tpv ( void* p, void* val );}\\\ninline void Map_insert_##tpk##_##tpv ( void* p, void* val ) {\\\n(static_cast<std::map<tpk, tpv>*>(p))->insert(std::move(*(static_cast<std::pair<tpk, tpv>*>(val))));\\\n}\\\nauto a_##callmod##_Map_insert_##tpk##_##tpv=Map_insert_##tpk##_##tpv;\n\n\n#define Map_size_s(callmod, tpk, tpv) \\\nextern \"C\" {\\\nint Map_size_##tpk##_##tpv ( void* p );}\\\ninline int Map_size_##tpk##_##tpv ( void* p ) {\\\nreturn (static_cast<std::map<tpk, tpv>*>(p))->size();\\\n}\\\nauto a_##callmod##_Map_size_##tpk##_##tpv=Map_size_##tpk##_##tpv;\n\n\n#define Map_delete_s(callmod, tpk, tpv) \\\nextern \"C\" {\\\nvoid Map_delete_##tpk##_##tpv ( void* p );}\\\ninline void Map_delete_##tpk##_##tpv ( void* p ) {\\\ndelete static_cast<std::map<tpk, tpv>*>(p);\\\n}\\\nauto a_##callmod##_Map_delete_##tpk##_##tpv=Map_delete_##tpk##_##tpv;\n\n\n#define Map_instance(callmod, tpk, tpv) \\\nMap_new(callmod, tpk, tpv)\\\nMap_begin(callmod, tpk, tpv)\\\nMap_end(callmod, tpk, tpv)\\\nMap_insert(callmod, tpk, tpv)\\\nMap_size(callmod, tpk, tpv)\\\nMap_delete(callmod, tpk, tpv)\n\n\n#define Map_instance_s(callmod, tpk, tpv) \\\nMap_new_s(callmod, tpk, tpv)\\\nMap_begin_s(callmod, tpk, tpv)\\\nMap_end_s(callmod, tpk, tpv)\\\nMap_insert_s(callmod, tpk, tpv)\\\nMap_size_s(callmod, tpk, tpv)\\\nMap_delete_s(callmod, tpk, tpv)\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
                   ++
                   "Map_instance" ++
                     (case isCprim of
                          CPrim -> "_s"
                          NonCPrim -> "")
                       ++ "(" ++ intercalate ", " (callmod : params) ++ ")\n"))
       let lst = [f1, f2, f3, f4, f5, f6]
       pure [mkInstance [] (AppT (AppT (con "IMap") typ1) typ2) lst]