packages feed

cplusplus-th (empty) → 1.0.0.0

raw patch · 9 files changed

+384/−0 lines, 9 filesdep +QuickCheckdep +basedep +bytestringbuild-type:Customsetup-changed

Dependencies added: QuickCheck, base, bytestring, containers, process, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, National ICT Australia Limited (NICTA)++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Maxwell Swadling nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,82 @@+cplusplus-th+============++`cplusplus-th` allows you to foreign import C++ functions that are+compatible with the `ccall` calling convention. It also includes+some standard library abstractions.++Example+-------++With the following C++ function in the object file `cbits/string.o`:++```c+++namespace haskell {+string* fromCString(char const* x, int length) {+  return new string(x, length);+}+}+```++We can import it into Haskell with:++```haskell+cplusplus "haskell::fromCString(char const*, int)" "cbits/string.o"+          [t|CString -> Int -> IO Std__basic_string|]+```++Building+--------++It works by looking up the symbol in the object file.+When using cabal, it is recommended you include the C++ file in+your `c-sources` and compile it in a build hook. For example:++```haskell+import Distribution.Simple+import Distribution.Simple.Setup+import Distribution.Simple.Program+import Distribution.Simple.Program.Types+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription++cc_flags = ["-stdlib=libc++", "-o", "cbits/string.o", "-c", "cbits/string.cc"]++main :: IO ()+main = defaultMainWithHooks simpleUserHooks {+    buildHook = buildCPlusPlus+  }++buildCPlusPlus :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()+buildCPlusPlus pkg buildInfo hooks flags = do+  let verb = fromFlag (buildVerbosity flags)+  clang <- findProgramLocation verb "clang++"+  let clang' = case clang of+                Just x -> x+                Nothing -> error "clang++ not on path"+  runProgram verb (simpleConfiguredProgram "clang++" (FoundOnSystem clang')) cc_flags+  buildHook simpleUserHooks pkg buildInfo hooks flags+```++Standard Library+----------------++`Foreign.CPlusPlusStdLib` exports the following type class:++```haskell+class CPlusPlusLand a {- haskell side -} b {- c++ side -} where+  to :: a -> IO b+  from :: b -> IO a+```++To avoid orphan instances, it implements instances for+some numeric types, `String` and `ByteString`.++Compatability+-------------++- Static functions are simply the arguments.+- Static member functions take the object as the first argument.+- Functions via a vtable are not possible.+- Inline functions are not possible.+- instantiating templates is not possible.
+ Setup.hs view
@@ -0,0 +1,23 @@+import Distribution.Simple+import Distribution.Simple.Setup+import Distribution.Simple.Program+import Distribution.Simple.Program.Types+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription++cc_flags = ["-stdlib=libc++", "-o", "cbits/hsstring.o", "-c", "cbits/hsstring.cc"]++main :: IO ()+main = defaultMainWithHooks simpleUserHooks {+    buildHook = buildCPlusPlus+  }++buildCPlusPlus :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()+buildCPlusPlus pkg buildInfo hooks flags = do+  let verb = fromFlag (buildVerbosity flags)+  clang <- findProgramLocation verb "clang++"+  let clang' = case clang of+                Just x -> x+                Nothing -> error "clang++ not on path"+  runProgram verb (simpleConfiguredProgram "clang++" (FoundOnSystem clang')) cc_flags+  buildHook simpleUserHooks pkg buildInfo hooks flags
+ cbits/hsstring.cc view
@@ -0,0 +1,27 @@+#include <stdlib.h>+#include <string>+#include <iostream>+#include <fstream>++using namespace std;++namespace haskell {++string* fromCString(char const* x, int length) {+  return new string(x, length);+}++char const* toCString(string const &x) {+  return x.c_str();+}++int cstringLen(string const &x) {+  return x.length();+}++// TODO: replace with an FFI call to libc+++void deleteString(string const *x) {+  delete x;+}++}
+ cplusplus-th.cabal view
@@ -0,0 +1,37 @@+name:                cplusplus-th+version:             1.0.0.0+synopsis:            C++ Foreign Import Generation+description:         +  <<http://i.imgur.com/Ns5hntl.jpg>>+  .+  cplusplus-th allows you to foreign import C++ functions that are+  compatible with the ccall calling convention. It also includes+  some standard library abstractions.+homepage:            https://github.com/nicta/cplusplus-th+license:             BSD3+license-file:        LICENSE+author:              Maxwell Swadling+maintainer:          maxwell.swadling@nicta.com.au+copyright:           Copyright (c) 2014, National ICT Australia Limited (NICTA)+category:            Foreign+build-type:          Custom+extra-source-files:  README.md+cabal-version:       >=1.10++library+  exposed-modules:     Foreign.CPlusPlus, Foreign.CPlusPlusStdLib, Foreign.NM+  other-extensions:    TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables, OverlappingInstances, UndecidableInstances, FunctionalDependencies+  build-depends:       base >=4.6 && <4.8, template-haskell, bytestring >=0.10 && <0.11, process >=1.2 && <1.3, containers == 0.5.*+  hs-source-dirs:      src+  extra-libraries:     c+++  c-sources:           cbits/hsstring.cc+  ghc-options:         -Wall+  default-language:    Haskell2010++test-suite tests+  type:                exitcode-stdio-1.0+  main-is:             Tests.hs+  cpp-options:         -DTESTING+  build-depends:       base, QuickCheck == 2.7.6, process+  hs-source-dirs:      tests, src+  default-language:    Haskell2010
+ src/Foreign/CPlusPlus.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}+module Foreign.CPlusPlus where++import Data.List+import Data.Char+import Foreign.NM+import Language.Haskell.TH++cplusplus :: String -> FilePath -> Q Type -> Q [Dec]+cplusplus name objfile t = do+  -- we drop the last _ so we can call things reserved names.+  let nameLit = let (Just i) = findIndex (== '(') name+                    (left, lst:right) = splitAt (pred i) name+                in if lst == '_' then (left ++ right) else name+  let (x:xs) = map (\y -> if y `elem` ":<>, " then '_' else y) $ takeWhile (/= '(') name+  let hsname = mkName $ toLower x:xs+  cname <- runIO $ lookupSymbol objfile nameLit+  let cname' = case cname of+                Just v -> v+                Nothing -> error $ "symbol \"" ++ nameLit ++ "\" missing from object file"+  t' <- runQ t+  return $ [ForeignD (ImportF cCall unsafe (drop 1 cname') hsname t')]
+ src/Foreign/CPlusPlusStdLib.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables, OverlappingInstances, UndecidableInstances, FunctionalDependencies #-}+module Foreign.CPlusPlusStdLib where++import Data.Int+import Data.Word+import qualified Data.ByteString as B+import Foreign.C+import Foreign.Ptr+import Foreign.Concurrent+import Foreign.CPlusPlus+import Foreign.ForeignPtr hiding (addForeignPtrFinalizer)++data Std__basic_string_mem+type Std__basic_string = Ptr Std__basic_string_mem++cplusplus "haskell::fromCString(char const*, int)" "cbits/hsstring.o" [t|CString -> Int -> IO Std__basic_string|]+cplusplus "haskell::toCString(std::__1::basic_string<char, std::__1::char_traits<char>, std::__1::allocator<char> > const&)" "cbits/hsstring.o" [t|Std__basic_string -> IO CString|]+cplusplus "haskell::cstringLen(std::__1::basic_string<char, std::__1::char_traits<char>, std::__1::allocator<char> > const&)" "cbits/hsstring.o" [t|Std__basic_string -> IO Int|]+-- TODO: ffi this from the libc++?+cplusplus "haskell::deleteString(std::__1::basic_string<char, std::__1::char_traits<char>, std::__1::allocator<char> > const*)" "cbits/hsstring.o" [t|Std__basic_string -> IO ()|]++class CPlusPlusLand a {- haskell side -} b {- c++ side -} where+  to :: a -> IO b+  from :: b -> IO a++instance CPlusPlusLand Int Int where+  to = return+  from = return++instance CPlusPlusLand Int CInt where+  to = return . fromIntegral+  from = return . fromIntegral++instance CPlusPlusLand Int64 CLLong where+  to = return . fromIntegral+  from = return . fromIntegral++instance CPlusPlusLand Int32 CInt where+  to = return . fromIntegral+  from = return . fromIntegral++instance CPlusPlusLand Word32 CUInt where+  to = return . fromIntegral+  from = return . fromIntegral++instance CPlusPlusLand Bool CChar where+  to False = return 0+  to True = return 1+  from 0 = return False+  from _ = return True++instance CPlusPlusLand a b => CPlusPlusLand [a] [b] where+  to = mapM to+  from = mapM from++instance CPlusPlusLand a b => CPlusPlusLand (Maybe a) (Maybe b) where+  to (Just x) = fmap Just $ to x+  to Nothing = return Nothing+  from (Just x) = fmap Just $ from x+  from Nothing = return Nothing++instance CPlusPlusLand String (Ptr Std__basic_string_mem) where+  to x = withCStringLen x $ \(y, len) -> haskell__fromCString y len+  from x = haskell__toCString x >>= \p -> haskell__cstringLen x >>= \len -> peekCStringLen (p, len)++instance CPlusPlusLand B.ByteString (Ptr Std__basic_string_mem) where+  to x = B.useAsCStringLen x $ \(p, len) -> haskell__fromCString p len+  from x = haskell__toCString x >>= \p -> haskell__cstringLen x >>= \len -> B.packCStringLen (p, len)++retainForeign :: ForeignPtr a -> Ptr Std__basic_string_mem -> IO ()+retainForeign p v = addForeignPtrFinalizer p (haskell__deleteString v)++-- Setting / Getting maybes+setMaybePtr :: (Ptr a -> IO ()) -> (IO ()) -> Ptr a -> IO ()+setMaybePtr isSet notSet p+  | p == nullPtr = notSet+  | otherwise    = isSet p++setMaybeVal :: (a -> IO ()) -> IO () -> Maybe a -> IO ()+setMaybeVal _f unset Nothing = unset+setMaybeVal f _unset (Just x) = f x++getMaybeVal :: (IO a) -> (IO Bool) -> IO (Maybe a)+getMaybeVal val isSet = do+  x <- isSet+  if x then fmap Just val else return Nothing++getMaybePtr :: (IO (Ptr a)) -> (IO Bool) -> IO (Ptr a)+getMaybePtr deref isSet = do+  r <- isSet+  if r+    then deref+    else return nullPtr
+ src/Foreign/NM.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE CPP #-}+module Foreign.NM (+    lookupSymbol+#ifdef TESTING+  , readFunctions'+  , Function(..)+#endif+  ) where++import Prelude hiding (lookup)+import Data.Map (lookup, fromList)+import Data.Char+import Data.List hiding (lookup)+import Data.Maybe+import Numeric+import System.Process++data Function = Function {+    _addr :: Int+  , cname :: String+  , prettyName :: String+  }+  deriving (Show, Eq)++lookupSymbol :: String -> String -> IO (Maybe String)+lookupSymbol filename func = do+  functions <- readFunctions filename+  return $ fmap cname $ find ((==) func . prettyName) functions++readFunctions :: String -> IO [Function]+readFunctions filename = do+  nm <- readProcess "nm" [filename] ""+  filt <- readProcess "c++filt" [] nm+  return $ readFunctions' nm filt++readFunctions' :: String -> String -> [Function]+readFunctions' nm filt =+  let addrLen = length $ takeWhile (/= ' ') $ head $ lines nm+      f = catMaybes . map (splitLine addrLen) . lines+      filt' = fromList $ f filt+  in catMaybes $ map (\(a, v) -> lookup a filt' >>= Just . Function a v) (f nm)++-- for 64 bit, the addrLen is 16 chars+-- for 32 bit, it is 8+splitLine :: Int -> String -> Maybe (Int, String)+splitLine addrLen l =+  let (h, t) = fmap n $ splitAt addrLen l+      [(v, "")] = readHex h+      n :: String -> String+      n (' ':_:' ':x) = x+      n (' ':x) = x+      n _ = error "invalid nm output"+      eh = isSuffixOf "(.eh)" t+  in if all isHexDigit h && not eh+      then Just (v, t)+      else Nothing
+ tests/Tests.hs view
@@ -0,0 +1,14 @@+module Main where++import Foreign.NM++import Test.QuickCheck+import Test.QuickCheck.Monadic++main = quickCheckWith stdArgs $ once $ monadicIO $ do+  x <- run $ do+    nm <- readFile "tests/nm.linux"+    filt <- readFile "tests/filt.linux"+    return $ readFunctions' nm filt+  assert $ x == [Function {_addr = 0, cname = "GCC_except_table1", prettyName = "GCC_except_table1"},Function {_addr = 44, cname = "GCC_except_table4", prettyName = "GCC_except_table4"},Function {_addr = 448, cname = "_GLOBAL__I_a", prettyName = "global constructors keyed to a"},Function {_addr = 304, cname = "_ZN7haskell10cstringLenERKSs", prettyName = "haskell::cstringLen(std::basic_string<char, std::char_traits<char>, std::allocator<char> > const&)"},Function {_addr = 64, cname = "_ZN7haskell11fromCStringEPKci", prettyName = "haskell::fromCString(char const*, int)"},Function {_addr = 336, cname = "_ZN7haskell12deleteStringEPKSs", prettyName = "haskell::deleteString(std::basic_string<char, std::char_traits<char>, std::allocator<char> > const*)"},Function {_addr = 272, cname = "_ZN7haskell9toCStringERKSs", prettyName = "haskell::toCString(std::basic_string<char, std::char_traits<char>, std::allocator<char> > const&)"},Function {_addr = 0, cname = "_ZStL8__ioinit", prettyName = "GCC_except_table1"},Function {_addr = 0, cname = "__cxx_global_var_init", prettyName = "GCC_except_table1"}]+