Merge pull request #107 from wavewave/dev/104/tapp-tparam

Support TemplateApp with template parameter

fficxx/lib/FFICXX/Generate/Code/Primitive.hs

@@ -347,9 +347,9 @@ tmplArgToString _ _ (CPT (CPTClassMove c) isconst, varname) =
   case isconst of
     Const   -> "const_" <> ffiClassName c <> "_p " <> varname
     NoConst -> ffiClassName c <> "_p " <> varname
-tmplArgToString _ _ (TemplateApp     _, _v) = error "tmpArgToString: TemplateApp"
-tmplArgToString _ _ (TemplateAppRef  _, _v) = error "tmpArgToString: TemplateAppRef"
-tmplArgToString _ _ (TemplateAppMove _, _v) = error "tmpArgToString: TemplateAppMove"
+tmplArgToString _ _ (TemplateApp     _, v) = "void* " <> v
+tmplArgToString _ _ (TemplateAppRef  _, v) = "void* " <> v
+tmplArgToString _ _ (TemplateAppMove _, v) = "void* " <> v
 tmplArgToString _ _ (TemplateType   _,  v) = "void* " <> v
 tmplArgToString True  _ (TemplateParam _,v) = "Type " <> v
 tmplArgToString False _ (TemplateParam _,v) = "Type ## _p " <> v
@@ -384,6 +384,21 @@ tmplArgToCallString _ (CPT (CPTClassMove c) _,varname) =
   -- TODO: Rewrite this with static_cast.
   "std::move(to_nonconstref<"<>str<>","<>str<>"_t>(*"<>varname<>"))" where str = ffiClassName c
 tmplArgToCallString _ (CT (CRef _) _,varname) = "(*"<> varname<> ")"
+tmplArgToCallString _ (TemplateApp x,varname) =
+  case tapp_tparam x of
+    TArg_TypeParam p -> "static_cast<" <> tclass_oname (tapp_tclass x) <> "<Type>*>(" <> varname <> ")"
+    _ -> -- TODO: Implement this.
+         error "tmplArgToCallString: TemplateApp"
+tmplArgToCallString _ (TemplateAppRef x,varname) =
+  case tapp_tparam x of
+    TArg_TypeParam p -> "*" <> "(static_cast<" <> tclass_oname (tapp_tclass x) <> "<Type>*>(" <> varname <> "))"
+    _ -> -- TODO: Implement this.
+         error "tmplArgToCallString: TemplateAppRef"
+tmplArgToCallString _ (TemplateAppMove x,varname) =
+  case tapp_tparam x of
+    TArg_TypeParam p -> "std::move(*" <> "(static_cast<" <> tclass_oname (tapp_tclass x) <> "<Type>*>(" <> varname <> ")))"
+    _ -> -- TODO: Implement this.
+         error "tmplArgToCallString: TemplateAppMove"
 tmplArgToCallString b (TemplateParam _,varname) =
   case b of
     True  -> varname
@@ -442,9 +457,9 @@ tmplMemFuncArgToString _ (CPT (CPTClassMove c) isconst, varname) =
   case isconst of
     Const   -> "const_" <> ffiClassName c <> "_p " <> varname
     NoConst -> ffiClassName c <> "_p " <> varname
-tmplMemFuncArgToString _ (TemplateApp     _, _v) = error "tmplMemFunArgToString: TemplateApp"
-tmplMemFuncArgToString _ (TemplateAppRef  _, _v) = error "tmplMemFunArgToString: TemplateAppRef"
-tmplMemFuncArgToString _ (TemplateAppMove _, _v) = error "tmplMemFunArgToString: TemplateAppMove"
+tmplMemFuncArgToString _ (TemplateApp     _, v) = "void* " <> v
+tmplMemFuncArgToString _ (TemplateAppRef  _, v) = "void* " <> v
+tmplMemFuncArgToString _ (TemplateAppMove _, v) = "void* " <> v
 tmplMemFuncArgToString _ (TemplateType   _,  v) = "void* " <> v
 tmplMemFuncArgToString _ (TemplateParam _,v) = "Type##_p " <> v
 tmplMemFuncArgToString _ (TemplateParamPointer _,v) = "Type##_p " <> v
@@ -511,7 +526,12 @@ convertCpp2HS _c (TemplateParam p)         = mkTVar p
 convertCpp2HS _c (TemplateParamPointer p)  = mkTVar p
 
 -- |
-convertCpp2HS4Tmpl :: Type () -> Maybe Class -> Type () -> Types -> Type ()
+convertCpp2HS4Tmpl
+  :: Type ()    -- ^ self
+  -> Maybe Class
+  -> Type ()    -- ^ type paramemter splice
+  -> Types
+  -> Type ()
 convertCpp2HS4Tmpl _ _c _ Void                  = unit_tycon
 convertCpp2HS4Tmpl _ (Just c) _ SelfType        = tycon ((fst.hsClassName) c)
 convertCpp2HS4Tmpl _ Nothing _ SelfType         = error "convertCpp2HS4Tmpl : SelfType but no class "
@@ -520,12 +540,27 @@ convertCpp2HS4Tmpl _ _c _ (CPT (CPTClass c') _)     = (tycon . fst . hsClassName
 convertCpp2HS4Tmpl _ _c _ (CPT (CPTClassRef c') _)  = (tycon . fst . hsClassName) c'
 convertCpp2HS4Tmpl _ _c _ (CPT (CPTClassCopy c') _) = (tycon . fst . hsClassName) c'
 convertCpp2HS4Tmpl _ _c _ (CPT (CPTClassMove c') _) = (tycon . fst . hsClassName) c'
-convertCpp2HS4Tmpl e _c _ (TemplateApp _ )          = e
-convertCpp2HS4Tmpl e _c _ (TemplateAppRef _)        = e
-convertCpp2HS4Tmpl e _c _ (TemplateAppMove _)       = e
+convertCpp2HS4Tmpl e c s x@(TemplateApp p) =
+  case tapp_tparam p of
+    TArg_TypeParam _ -> let t = tapp_tclass p
+                            (hname,_) = hsTemplateClassName t
+                        in tyapp (tycon hname) s
+    _ -> convertCpp2HS c x
+convertCpp2HS4Tmpl e c s x@(TemplateAppRef p) =
+  case tapp_tparam p of
+    TArg_TypeParam _ -> let t = tapp_tclass p
+                            (hname,_) = hsTemplateClassName t
+                        in tyapp (tycon hname) s
+    _ -> convertCpp2HS c x
+convertCpp2HS4Tmpl e c s x@(TemplateAppMove p) =
+  case tapp_tparam p of
+    TArg_TypeParam _ -> let t = tapp_tclass p
+                            (hname,_) = hsTemplateClassName t
+                        in tyapp (tycon hname) s
+    _ -> convertCpp2HS c x
 convertCpp2HS4Tmpl e _c _ (TemplateType _)          = e
-convertCpp2HS4Tmpl _ _c t (TemplateParam _)         = t
-convertCpp2HS4Tmpl _ _c t (TemplateParamPointer _)  = t
+convertCpp2HS4Tmpl _ _c s (TemplateParam _)         = s
+convertCpp2HS4Tmpl _ _c s (TemplateParamPointer _)  = s
 
 
 hsFuncXformer :: Function -> String
@@ -640,7 +675,7 @@ functionSignatureT t TFunDelete =
 
 
 
-
+-- TODO: rename this and combine this with functionSignatureTMF
 functionSignatureTT :: TemplateClass -> TemplateFunction -> Type ()
 functionSignatureTT t f = foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp])
  where
@@ -657,7 +692,7 @@ functionSignatureTT t f = foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp])
       TFunNew {..} -> map (convertCpp2HS4Tmpl e Nothing spl . fst) tfun_new_args
       TFunDelete -> [e]
 
-
+-- TODO: rename this and combine this with functionSignatureTT
 functionSignatureTMF :: Class -> TemplateMemberFunction -> Type ()
 functionSignatureTMF c f = foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp])
   where

fficxx/lib/FFICXX/Generate/Dependency.hs

@@ -61,6 +61,11 @@ getparents = either (const []) (map Right . class_parents)
 -- TODO: replace tclass_name with appropriate FFI name when supported.
 getFFIName = either tclass_name ffiClassName
 
+
+getPkgName :: Either TemplateClass Class -> CabalName
+getPkgName = cabal_pkgname . getcabal
+
+
 -- |
 extractClassFromType :: Types -> [Either TemplateClass Class]
 extractClassFromType Void                     = []
@@ -151,6 +156,12 @@ extractClassDepForTmplFun TFunDelete =
     Dep4Func [] []
 
 
+extractClassDep4TmplMemberFun :: TemplateMemberFunction -> Dep4Func
+extractClassDep4TmplMemberFun (TemplateMemberFunction {..}) =
+  Dep4Func (extractClassFromType tmf_ret) (concatMap (extractClassFromType.fst) tmf_args)
+
+
+
 extractClassDepForTopLevelFunction :: TopLevelFunction -> Dep4Func
 extractClassDepForTopLevelFunction f =
     Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)
@@ -162,50 +173,82 @@ extractClassDepForTopLevelFunction f =
                  TopLevelVariable {..} -> []
 
 
--- |
+-- TODO: Confirm the answer below is correct.
+-- NOTE: Q: Why returnDependency only?
+--       A: Difference between argument and return:
+--          for a member function f,
+--          we have (f :: (IA a, IB b) => a -> b -> IO C
+--          return class is concrete and argument class is constraint.
 mkModuleDepRaw :: Either TemplateClass Class -> [Either TemplateClass Class]
-mkModuleDepRaw x@(Right c)
-  = (nub . filter (/= x) . concatMap (returnDependency.extractClassDep) . class_funcs) c
-mkModuleDepRaw x@(Left t)
-  = (nub . filter (/= x) . concatMap (returnDependency.extractClassDepForTmplFun) . tclass_funcs) t
-
-
--- |
+mkModuleDepRaw x@(Right c) =
+  nub $
+    filter (/= x) $
+         concatMap (returnDependency . extractClassDep) (class_funcs c)
+      ++ concatMap (returnDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs c)
+mkModuleDepRaw x@(Left t) =
+  (nub . filter (/= x) . concatMap (returnDependency.extractClassDepForTmplFun) . tclass_funcs) t
+
+
+
+isNotInSamePackageWith
+  :: Either TemplateClass Class
+  -> Either TemplateClass Class
+  -> Bool
+isNotInSamePackageWith x y = (x /= y) && (getPkgName x /= getPkgName y)
+
+-- x is in the sam
+isInSamePackageButNotInheritedBy
+  :: Either TemplateClass Class -- ^ y
+  -> Either TemplateClass Class -- ^ x
+  -> Bool
+isInSamePackageButNotInheritedBy x y =
+  x /= y && not (x `elem` getparents y) && (getPkgName x == getPkgName y)
+
+
+-- TODO: Confirm the following answer
+-- NOTE: Q: why returnDependency is not considered?
+--       A: See explanation in mkModuleDepRaw
 mkModuleDepHighNonSource :: Either TemplateClass Class -> [Either TemplateClass Class]
 mkModuleDepHighNonSource y@(Right c) =
-  let fs = class_funcs c
-      pkgname = (cabal_pkgname . class_cabal) c
-      extclasses = (filter (\x-> x /= y && ((/= pkgname) . cabal_pkgname . getcabal) x) . concatMap (argumentDependency.extractClassDep)) fs
+  let extclasses = filter (`isNotInSamePackageWith` y) $
+                        concatMap (argumentDependency.extractClassDep) (class_funcs c)
+                     ++ concatMap (argumentDependency.extractClassDep4TmplMemberFun) (class_tmpl_funcs c)
       parents = map Right (class_parents c)
   in  nub (parents <> extclasses)
 mkModuleDepHighNonSource y@(Left t) =
   let fs = tclass_funcs t
-      pkgname = (cabal_pkgname . tclass_cabal) t
-      extclasses = (filter (\x-> x /= y && ((/= pkgname) . cabal_pkgname . getcabal) x) . concatMap (argumentDependency.extractClassDepForTmplFun)) fs
+      extclasses = filter (`isNotInSamePackageWith` y) $
+                     concatMap (argumentDependency.extractClassDepForTmplFun) fs
   in  nub extclasses
 
 
--- |
+-- TODO: Confirm the following answer
+-- NOTE: Q: why returnDependency is not considered?
+--       A: See explanation in mkModuleDepRaw
 mkModuleDepHighSource :: Either TemplateClass Class -> [Either TemplateClass Class]
 mkModuleDepHighSource y@(Right c) =
-  let fs = class_funcs c
-      pkgname = (cabal_pkgname . class_cabal) c
-      -- TODO: QUESTION: why returnDependency is not considered?
-  in  nub . filter (\x-> x /= y && not (x `elem` getparents y) && (((== pkgname) . cabal_pkgname . getcabal) x)) . concatMap (argumentDependency.extractClassDep) $ fs
+  nub $
+    filter (`isInSamePackageButNotInheritedBy` y) $
+         concatMap (argumentDependency . extractClassDep) (class_funcs c)
+      ++ concatMap (argumentDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs c)
 mkModuleDepHighSource y@(Left t) =
   let fs = tclass_funcs t
-      pkgname = (cabal_pkgname . tclass_cabal) t
-  in  nub . filter (\x-> x /= y && not (x `elem` getparents y) && (((== pkgname) . cabal_pkgname . getcabal) x)) . concatMap (argumentDependency.extractClassDepForTmplFun) $ fs
+  in nub $
+       filter (`isInSamePackageButNotInheritedBy` y) $
+         concatMap (argumentDependency . extractClassDepForTmplFun) fs
 
 -- |
 mkModuleDepCpp :: Either TemplateClass Class -> [Either TemplateClass Class]
 mkModuleDepCpp y@(Right c) =
   let fs = class_funcs c
       vs = class_vars c
+      tmfs = class_tmpl_funcs c
   in  nub . filter (/= y)  $
            concatMap (returnDependency.extractClassDep) fs
         <> concatMap (argumentDependency.extractClassDep) fs
         <> concatMap (extractClassFromType . var_type) vs
+        <> concatMap (returnDependency.extractClassDep4TmplMemberFun) tmfs
+        <> concatMap (argumentDependency.extractClassDep4TmplMemberFun) tmfs
         <> getparents y
 mkModuleDepCpp y@(Left t) =
   let fs = tclass_funcs t
@@ -218,9 +261,12 @@ mkModuleDepCpp y@(Left t) =
 mkModuleDepFFI1 :: Either TemplateClass Class -> [Either TemplateClass Class]
 mkModuleDepFFI1 (Right c) = let fs = class_funcs c
                                 vs = class_vars c
+                                tmfs = class_tmpl_funcs c
                             in    concatMap (returnDependency.extractClassDep) fs
                                <> concatMap (argumentDependency.extractClassDep) fs
                                <> concatMap (extractClassFromType . var_type) vs
+                               <> concatMap (returnDependency.extractClassDep4TmplMemberFun) tmfs
+                               <> concatMap (argumentDependency.extractClassDep4TmplMemberFun) tmfs
 mkModuleDepFFI1 (Left t)  = let fs = tclass_funcs t
                             in    concatMap (returnDependency.extractClassDepForTmplFun) fs
                                <> concatMap (argumentDependency.extractClassDepForTmplFun) fs
@@ -320,8 +366,8 @@ mkPkgCppFileName c =
 mkPkgIncludeHeadersInH :: Class -> [HeaderName]
 mkPkgIncludeHeadersInH c =
     let pkgname = (cabal_pkgname . class_cabal) c
-        extclasses = filter ((/= pkgname) . cabal_pkgname . getcabal) . mkModuleDepCpp $ Right c
-        extheaders = nub . map ((<>"Type.h") . unCabalName . cabal_pkgname . getcabal) $ extclasses
+        extclasses = filter ((/= pkgname) . getPkgName) . mkModuleDepCpp $ Right c
+        extheaders = nub . map ((<>"Type.h") . unCabalName . getPkgName) $ extclasses
     in map mkPkgHeaderFileName (class_allparents c) <> map HdrName extheaders
 
 
@@ -367,10 +413,10 @@ mkTIH pkgname getImports cihs fs =
              let y = find (\x -> (ffiClassName . cihClass) x == getFFIName c) cihs
              in y:ys
       -- NOTE: The remaining class dependencies outside the current package
-      extclasses = filter ((/= pkgname) . cabal_pkgname . getcabal) tl_cs
+      extclasses = filter ((/= pkgname) . getPkgName) tl_cs
       extheaders = map HdrName $
                      nub $
-                       map ((<>"Type.h") . unCabalName . cabal_pkgname . getcabal)  extclasses
+                       map ((<>"Type.h") . unCabalName . getPkgName)  extclasses
 
   in
      TopLevelImportHeader {

fficxx/lib/FFICXX/Generate/Name.hs

@@ -36,6 +36,7 @@ hsClassName c =
 
 hsClassNameForTArg :: TemplateArgType -> String
 hsClassNameForTArg (TArg_Class c) = fst (hsClassName c)
+hsClassNameForTArg (TArg_TypeParam p) = p
 hsClassNameForTArg (TArg_Other s) = s
 
 hsTemplateClassName :: TemplateClass -> (String, String)  -- ^ High-level, 'Raw'-level

fficxx/lib/FFICXX/Generate/Type/Class.hs

@@ -53,6 +53,7 @@ data IsConst = Const | NoConst
 --   in vector<float>.
 --   For now, this distinguishes Class and non-Class.
 data TemplateArgType = TArg_Class Class
+                     | TArg_TypeParam String
                      | TArg_Other String
                      deriving Show
 

test/template-member/Gen.hs

@@ -46,6 +46,7 @@ string =
 
 t_vector = TmplCls stdcxx_cabal "Vector" "std::vector" "t" [ ]
 
+t_unique_ptr = TmplCls stdcxx_cabal "UniquePtr" "std::unique_ptr" "t" [ ]
 
 
 
@@ -88,6 +89,21 @@ classA cabal =
         , tmf_args = [ (TemplateParamPointer "t", "x") ]
         , tmf_alias = Nothing
         }
+      , TemplateMemberFunction {
+          tmf_param = "t"
+        , tmf_ret = void_
+        , tmf_name = "method2"
+        , tmf_args = [ (TemplateAppMove
+                          (TemplateAppInfo {
+                             tapp_tclass = t_unique_ptr
+                           , tapp_tparam = TArg_TypeParam "t"
+                           , tapp_CppTypeForParam = "std::unique_ptr<Type>"
+                           })
+                       , "x"
+                       )
+                     ]
+        , tmf_alias = Nothing
+        }
       ]
   }
 

test/template-member/app.hs

@@ -1,14 +1,21 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Main where
 
+import STD.UniquePtr.Template
+import STD.UniquePtr.TH
+
 import TestPkg.A
 import TestPkg.A.Implementation
 import TestPkg.T1
 import TestPkg.T2
 
+$(genUniquePtrInstanceFor [t|T1|] "T1")
+
 $(genInstanceFor_a_method [t|T1|] "T1")
 $(genInstanceFor_a_method [t|T2|] "T2")
 
+$(genInstanceFor_a_method2 [t|T1|] "T1")
+
 main :: IO ()
 main = do
   a <- newA
@@ -17,4 +24,7 @@ main = do
   t2 <- newT2
   a_method_T1 a t1
   a_method_T2 a t2
+
+  ptr <- newUniquePtr t1
+  a_method2_T1 a ptr
   pure ()

test/template-member/build.sh

@@ -13,7 +13,7 @@ cd testpkg && cabal clean && cd ..
 cabal sandbox delete && cabal sandbox init && cabal sandbox add-source testpkg && cabal install testpkg
 
 g++ -c stub.cc -I${BASEDIR}/stdcxx-0.5/include -I${BASEDIR}/fficxx-runtime-0.5/include -Itestpkg/csrc
-cabal exec -- ghc -c TH.hs
+#cabal exec -- ghc -c TH.hs
 cabal exec -- ghc -c app.hs
 cabal exec -- ghc app.hs stub.o
 

test/template-member/main.cpp

@@ -1,4 +1,5 @@
 #include "test.h"
+#include <memory>
 
 int main( int argc, char** argv ) {
 
@@ -9,4 +10,9 @@ int main( int argc, char** argv ) {
 
     a-> method<T1>( t1 );
 
+    std::unique_ptr<T1> ptr(t1);
+
+    a->method2<T1>(std::move(ptr));
+
+
 }

test/template-member/stub.cc

@@ -1,8 +1,16 @@
 #include <MacroPatternMatch.h>
+#include <memory>
+#include "UniquePtr.h"
 #include "testpkgType.h"
 #include "TestPkgA.h"
 #include "test.h"
 
+using namespace std;
+
 a_method(T1)
 
 a_method(T2)
+
+UniquePtr_instance(T1)
+
+a_method2(T1)