diff --git a/casadi-bindings-internal.cabal b/casadi-bindings-internal.cabal --- a/casadi-bindings-internal.cabal +++ b/casadi-bindings-internal.cabal @@ -1,5 +1,5 @@ name: casadi-bindings-internal -version: 0.1.3.0 +version: 0.1.3.1 license: LGPL-3 license-file: LICENSE category: Numerical, Math @@ -16,7 +16,7 @@ extra-tmp-files: Casadi/Callback_stub.h library - build-depends: base >=4.6 && <5, vector >=0.10 + build-depends: base >=4.6 && <5, vector >=0.10, containers default-language: Haskell2010 hs-source-dirs: src @@ -27,7 +27,7 @@ ghc-prof-options: -O2 -prof -fprof-auto -fprof-cafs -rtsopts ghc-options: -O2 - cc-options: -Wall -Wno-delete-non-virtual-dtor -Wno-sign-compare + cc-options: -Wall -Wno-delete-non-virtual-dtor -Wno-sign-compare -std=c++11 C-sources: cbits/hs_tools.cpp cbits/callback.cpp @@ -37,7 +37,6 @@ Casadi.Internal.WrapReturn Casadi.Internal.CppHelpers Casadi.Internal.CToolsImports - Casadi.Internal.CToolsInstances Casadi.Internal.Callback Casadi.Internal.FormatException diff --git a/cbits/hs_tools.cpp b/cbits/hs_tools.cpp --- a/cbits/hs_tools.cpp +++ b/cbits/hs_tools.cpp @@ -1,5 +1,6 @@ #include #include +#include #include "string.h" using namespace std; @@ -23,6 +24,86 @@ delete x; } +////////////////// std::pair ///////////////// +extern "C" std::pair * hs_new_stdpair(void * x, void * y); +std::pair * hs_new_stdpair(void * x, void * y) { + return new std::pair(x, y); +} +extern "C" void * hs_stdpair_fst(std::pair * stdpair); +void * hs_stdpair_fst(std::pair * stdpair) { + return stdpair->first; +} +extern "C" void * hs_stdpair_snd(std::pair * stdpair); +void * hs_stdpair_snd(std::pair * stdpair) { + return stdpair->second; +} +extern "C" void hs_delete_stdpair(std::pair * pair); +void hs_delete_stdpair(std::pair * pair){ + delete pair; +} + +extern "C" std::pair * hs_new_stdpair_int(int x, int y); +std::pair * hs_new_stdpair_int(int x, int y) { + return new std::pair(x, y); +} +extern "C" int hs_stdpair_fst_int(std::pair * stdpair); +int hs_stdpair_fst_int(std::pair * stdpair) { + return stdpair->first; +} +extern "C" int hs_stdpair_snd_int(std::pair * stdpair); +int hs_stdpair_snd_int(std::pair * stdpair) { + return stdpair->second; +} +extern "C" void hs_delete_stdpair_int(std::pair * pair); +void hs_delete_stdpair_int(std::pair * pair){ + delete pair; +} + + +////////////////// std::map ///////////////// +extern "C" std::map * hs_new_dict(std::vector * keys, + std::vector * vals); +std::map * hs_new_dict(std::vector * keys, std::vector * vals) { + std::map * ret = new std::map; + for (int k = 0; k < keys->size(); k++) { + std::string key = *((*keys)[k]); + void * val = (*vals)[k]; + std::pair keyVal(key, val); + ret->insert(keyVal); + } + return ret; +} + +extern "C" int hs_dict_size(std::map * map); +int hs_dict_size(std::map * map) { + return map->size(); +} + +extern "C" void hs_dict_copy(std::map * map, + std::string * keys[], + void * vals[]); +void hs_dict_copy(std::map * map, + std::string * keys[], + void * vals[]) { + int k = 0; + for(std::map::iterator it = map->begin(); it != map->end(); it++) { + std::string * key = new std::string(it->first); + void * val = it->second; + keys[k] = key; + vals[k] = val; + k++; + } +} + +extern "C" void * hs_lookup_dict(std::map * map, std::string* key); +void * hs_lookup_dict(std::map * map, std::string* key) { + return map->at(*key); +} + +extern "C" void hs_delete_dict(std::map *); +void hs_delete_dict(std::map * dict) { + delete dict; +} ////////////////////////// copying vectors to arrays ///////////////////// template diff --git a/src/Casadi/Internal/CToolsImports.hs b/src/Casadi/Internal/CToolsImports.hs --- a/src/Casadi/Internal/CToolsImports.hs +++ b/src/Casadi/Internal/CToolsImports.hs @@ -8,6 +8,41 @@ import Casadi.Internal.MarshalTypes +--------------------------- stdpair ----------------------------------- +foreign import ccall unsafe "hs_new_stdpair" c_newStdPair + :: Ptr a -> Ptr b -> IO (Ptr (StdPair (Ptr a) (Ptr b))) +foreign import ccall unsafe "hs_stdpair_fst" c_stdPairFst + :: Ptr (StdPair (Ptr a) (Ptr b)) -> IO (Ptr a) +foreign import ccall unsafe "hs_stdpair_snd" c_stdPairSnd + :: Ptr (StdPair (Ptr a) (Ptr b)) -> IO (Ptr b) +foreign import ccall unsafe "hs_delete_stdpair" c_deleteStdPair + :: Ptr (StdPair (Ptr a) (Ptr b)) -> IO () + +foreign import ccall unsafe "hs_new_stdpair_int" c_newStdPairInt + :: CInt -> CInt -> IO (Ptr (StdPair CInt CInt)) +foreign import ccall unsafe "hs_stdpair_fst_int" c_stdPairFstInt + :: Ptr (StdPair CInt CInt) -> IO CInt +foreign import ccall unsafe "hs_stdpair_snd_int" c_stdPairSndInt + :: Ptr (StdPair CInt CInt) -> IO CInt +foreign import ccall unsafe "hs_delete_stdpair_int" c_deleteStdPairInt + :: Ptr (StdPair CInt CInt) -> IO () + +--------------------------- stdmap ----------------------------------- +foreign import ccall unsafe "hs_new_dict" c_newDict + :: Ptr (StdVec (Ptr StdString)) -> Ptr (StdVec (Ptr a)) -> IO (Ptr (StdMap StdString (Ptr a))) + +foreign import ccall unsafe "hs_dict_size" c_dictSize + :: Ptr (StdMap StdString (Ptr a)) -> IO CInt + +foreign import ccall unsafe "hs_lookup_dict" c_lookupDict + :: Ptr (StdMap StdString (Ptr a)) -> Ptr StdString -> IO (Ptr a) + +foreign import ccall unsafe "hs_dict_copy" c_dictCopy + :: Ptr (StdMap StdString (Ptr a)) -> Ptr (Ptr StdString) -> Ptr (Ptr a) -> IO () + +foreign import ccall unsafe "hs_delete_dict" c_deleteDict + :: Ptr (StdMap StdString (Ptr a)) -> IO () + --------------------------- ("int","CInt",Nothing,["Int","Bool"]) ----------------------------------- foreign import ccall unsafe "hs_new_vec_int" c_newVecCInt :: Ptr CInt -> CInt -> IO (Ptr (StdVec CInt)) diff --git a/src/Casadi/Internal/CToolsInstances.hs b/src/Casadi/Internal/CToolsInstances.hs deleted file mode 100644 --- a/src/Casadi/Internal/CToolsInstances.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# Language FlexibleInstances #-} -{-# Language MultiParamTypeClasses #-} - -module Casadi.Internal.CToolsInstances where - -import Foreign.C.Types -import Foreign.Ptr ( Ptr ) -import qualified Data.Vector as V - -import Casadi.Internal.MarshalTypes -import Casadi.Internal.Marshal -import Casadi.Internal.CToolsImports - - --- ("int","CInt",Nothing,["Int","Bool"]) -instance Marshal (V.Vector CInt) (Ptr (StdVec CInt)) where - marshal = newStorableVec c_newVecCInt - marshalFree = const c_deleteVecCInt -instance Marshal (V.Vector Int) (Ptr (StdVec CInt)) where - marshal = newStorableVec c_newVecCInt . (V.map hsToC) - marshalFree = const c_deleteVecCInt -instance Marshal (V.Vector Bool) (Ptr (StdVec CInt)) where - marshal = newStorableVec c_newVecCInt . (V.map hsToC) - marshalFree = const c_deleteVecCInt - --- ("voidp","VoidP",Just "(Ptr a)",[]) -instance Marshal (V.Vector (Ptr a)) (Ptr (StdVec (Ptr a))) where - marshal = newStorableVec c_newVecVoidP - marshalFree = const c_deleteVecVoidP - --- ("uchar","CUChar",Nothing,[]) -instance Marshal (V.Vector CUChar) (Ptr (StdVec CUChar)) where - marshal = newStorableVec c_newVecCUChar - marshalFree = const c_deleteVecCUChar - --- ("double","CDouble",Nothing,["Double"]) -instance Marshal (V.Vector CDouble) (Ptr (StdVec CDouble)) where - marshal = newStorableVec c_newVecCDouble - marshalFree = const c_deleteVecCDouble -instance Marshal (V.Vector Double) (Ptr (StdVec CDouble)) where - marshal = newStorableVec c_newVecCDouble . (V.map hsToC) - marshalFree = const c_deleteVecCDouble diff --git a/src/Casadi/Internal/Marshal.hs b/src/Casadi/Internal/Marshal.hs --- a/src/Casadi/Internal/Marshal.hs +++ b/src/Casadi/Internal/Marshal.hs @@ -3,6 +3,7 @@ {-# Language MultiParamTypeClasses #-} {-# Language FlexibleInstances #-} {-# Language FlexibleContexts #-} +{-# Language InstanceSigs #-} module Casadi.Internal.Marshal ( Marshal(..) @@ -14,15 +15,17 @@ import Control.Monad ( when ) import qualified Data.Vector as V +import qualified Data.Map as M import Foreign.C.Types import Foreign.C.String ( withCString ) import Foreign.Ptr ( Ptr ) import Foreign.Marshal ( withArrayLen ) import Foreign.Storable ( Storable ) -import Casadi.Internal.CToolsImports ( c_deleteVecVoidP ) +import Casadi.Internal.CToolsImports +--import Casadi.Internal.CToolsImports ( c_deleteVecVoidP ) import Casadi.Internal.CppHelpers ( newStdVec, readStdVec, c_newStdString, c_deleteStdString ) -import Casadi.Internal.MarshalTypes ( StdVec, StdString, StdPair ) +import Casadi.Internal.MarshalTypes ( StdMap, StdPair, StdVec, StdString ) class Marshal a b where marshal :: a -> IO b @@ -65,6 +68,97 @@ marshal = return . hsToC instance Marshal CSize CSize where marshal = return . hsToC + +-- ("int","CInt",Nothing,["Int","Bool"]) +instance Marshal (V.Vector CInt) (Ptr (StdVec CInt)) where + marshal = newStorableVec c_newVecCInt + marshalFree = const c_deleteVecCInt +instance Marshal (V.Vector Int) (Ptr (StdVec CInt)) where + marshal = newStorableVec c_newVecCInt . (V.map hsToC) + marshalFree = const c_deleteVecCInt +instance Marshal (V.Vector Bool) (Ptr (StdVec CInt)) where + marshal = newStorableVec c_newVecCInt . (V.map hsToC) + marshalFree = const c_deleteVecCInt + +-- ("voidp","VoidP",Just "(Ptr a)",[]) +instance Marshal (V.Vector (Ptr a)) (Ptr (StdVec (Ptr a))) where + marshal = newStorableVec c_newVecVoidP + marshalFree = const c_deleteVecVoidP + +-- ("uchar","CUChar",Nothing,[]) +instance Marshal (V.Vector CUChar) (Ptr (StdVec CUChar)) where + marshal = newStorableVec c_newVecCUChar + marshalFree = const c_deleteVecCUChar + +-- ("double","CDouble",Nothing,["Double"]) +instance Marshal (V.Vector CDouble) (Ptr (StdVec CDouble)) where + marshal = newStorableVec c_newVecCDouble + marshalFree = const c_deleteVecCDouble +instance Marshal (V.Vector Double) (Ptr (StdVec CDouble)) where + marshal = newStorableVec c_newVecCDouble . (V.map hsToC) + marshalFree = const c_deleteVecCDouble + +-- stdpair +instance (Marshal a (Ptr pa), Marshal b (Ptr pb)) + => Marshal (a, b) (Ptr (StdPair (Ptr pa) (Ptr pb))) where + marshal (x,y) = do + px <- marshal x + py <- marshal y + c_newStdPair px py + marshalFree (x,y) stdpair = do + px <- c_stdPairFst stdpair + py <- c_stdPairSnd stdpair + marshalFree x px + marshalFree y py + c_deleteStdPair stdpair + +-- stdpair +instance (Marshal a CInt, Marshal b CInt) + => Marshal (a, b) (Ptr (StdPair CInt CInt)) where + marshal (x,y) = do + px <- marshal x + py <- marshal y + c_newStdPairInt px py + marshalFree (x,y) stdpair = do + cx <- c_stdPairFstInt stdpair + cy <- c_stdPairSndInt stdpair + marshalFree x cx + marshalFree y cy + c_deleteStdPairInt stdpair + +-- stdmap +instance (Marshal a (Ptr pa)) + => Marshal (M.Map String a) (Ptr (StdMap StdString (Ptr pa))) where + marshal m = do + let (keys, vals) = unzip (M.toAscList m) + vecKeys = V.fromList keys + vecKeyPtrs <- V.mapM marshal vecKeys :: IO (V.Vector (Ptr StdString)) + vecValPtrs <- V.mapM marshal (V.fromList vals) :: IO (V.Vector (Ptr pa)) + + stdVecKeys <- newStdVec vecKeyPtrs + :: IO (Ptr (StdVec (Ptr StdString))) + stdVecVals <- newStdVec vecValPtrs + :: IO (Ptr (StdVec (Ptr pa))) + + dict <- c_newDict stdVecKeys stdVecVals + + c_deleteVecVoidP stdVecKeys + c_deleteVecVoidP stdVecVals + + V.zipWithM_ marshalFree vecKeys vecKeyPtrs + + return dict + + marshalFree m dict = do + let (keys, vals) = unzip (M.toAscList m) + vecKeys = V.fromList keys + vecKeyPtrs <- V.mapM marshal vecKeys :: IO (V.Vector (Ptr StdString)) + vecVals <- V.mapM (c_lookupDict dict) vecKeyPtrs :: IO (V.Vector (Ptr pa)) + + V.zipWithM_ marshalFree vecKeys vecKeyPtrs + V.zipWithM_ marshalFree (V.fromList vals) vecVals + c_deleteDict dict + instance Marshal String (Ptr StdString) where marshal str = newStdString str diff --git a/src/Casadi/Internal/MarshalTypes.hs b/src/Casadi/Internal/MarshalTypes.hs --- a/src/Casadi/Internal/MarshalTypes.hs +++ b/src/Casadi/Internal/MarshalTypes.hs @@ -5,9 +5,11 @@ , StdString , StdOstream , StdPair + , StdMap ) where data StdVec a data StdPair a b +data StdMap a b data StdString data StdOstream diff --git a/src/Casadi/Internal/WrapReturn.hs b/src/Casadi/Internal/WrapReturn.hs --- a/src/Casadi/Internal/WrapReturn.hs +++ b/src/Casadi/Internal/WrapReturn.hs @@ -8,6 +8,7 @@ ( WrapReturn(..) ) where +import qualified Data.Map as M import qualified Data.Vector as V import Foreign.C.Types import Foreign.C.String @@ -15,7 +16,7 @@ import Foreign.Storable ( Storable ) import Foreign.Marshal ( mallocArray, free, peekArray ) -import Casadi.Internal.MarshalTypes ( StdVec, StdString ) +import Casadi.Internal.MarshalTypes ( StdMap, StdVec, StdString, StdPair ) import Casadi.Internal.CppHelpers ( readStdVec, c_lengthStdString, c_copyStdString, c_deleteStdString ) import Casadi.Internal.CToolsImports @@ -33,6 +34,47 @@ instance WrapReturn CInt Bool where wrapReturn 0 = return False wrapReturn _ = return True + +instance WrapReturn (Ptr a) b => WrapReturn (Ptr (StdMap StdString (Ptr a))) (M.Map String b) where + wrapReturn stdMap = do + msize <- fmap fromIntegral (c_dictSize stdMap) + keyArray <- mallocArray msize :: IO (Ptr (Ptr StdString)) + valArray <- mallocArray msize :: IO (Ptr (Ptr a)) + + c_dictCopy stdMap keyArray valArray + c_deleteDict stdMap + + keys0 <- peekArray msize keyArray :: IO [Ptr StdString] + vals0 <- peekArray msize valArray :: IO [Ptr a] + + free keyArray + free valArray + + keys <- mapM wrapReturn keys0 :: IO [String] + vals <- mapM wrapReturn vals0 :: IO [b] + + return $ M.fromList (zip keys vals) + + +instance (WrapReturn (Ptr pa) a, WrapReturn (Ptr pb) b) + => WrapReturn (Ptr (StdPair (Ptr pa) (Ptr pb))) (a, b) where + wrapReturn stdPair = do + px <- c_stdPairFst stdPair + py <- c_stdPairSnd stdPair + x <- wrapReturn px + y <- wrapReturn py + c_deleteStdPair stdPair + return (x, y) + +instance (WrapReturn CInt a, WrapReturn CInt b) + => WrapReturn (Ptr (StdPair CInt CInt)) (a, b) where + wrapReturn stdPair = do + px <- c_stdPairFstInt stdPair + py <- c_stdPairSndInt stdPair + x <- wrapReturn px + y <- wrapReturn py + c_deleteStdPairInt stdPair + return (x, y) instance WrapReturn (Ptr a) b => WrapReturn (Ptr (StdVec (Ptr a))) (V.Vector b) where