fix some pointer issue

cbits/bytestring.c

@@ -45,7 +45,7 @@ int bsvector_set(bsvector_t *sv, long int idx, const bytestring_t *value) {
   assert(sv->data != 0);
 
   if (sv->data[idx] != 0) {
-    //destroy_bytestring(sv->data[idx]);
+    destroy_bytestring(sv->data[idx]);
   }
   sv->data[idx] = new_bytestring(value->len);
 
@@ -305,7 +305,6 @@ int bsvector_index(const bsvector_t *v, bsvector_t *newv,
 
 long int bsvector_size(const bsvector_t *sv) {
   assert(sv != 0);
-  assert(sv->data != 0);
   return sv->len;
 }
 

haskell-igraph.cabal

@@ -36,6 +36,7 @@ library
     IGraph.Internal.Community
     IGraph.Internal.Layout
     IGraph
+    IGraph.Types
     IGraph.Mutable
     IGraph.Clique
     IGraph.Structure
@@ -92,6 +93,7 @@ test-suite tests
   build-depends:
       base
     , haskell-igraph
+    , cereal
     , data-ordlist
     , matrices
     , tasty

src/IGraph.hs

@@ -44,15 +44,7 @@ import           IGraph.Internal.Constants
 import           IGraph.Internal.Graph
 import           IGraph.Internal.Selector
 import           IGraph.Mutable
-
-type Node = Int
-type Edge = (Node, Node)
-
--- | graph with labeled nodes and edges
-data LGraph d v e = LGraph
-    { _graph       :: IGraphPtr
-    , _labelToNode :: M.HashMap v [Node]
-    }
+import           IGraph.Types
 
 class MGraph d => Graph d where
     isDirected :: LGraph d v e -> Bool
@@ -125,6 +117,21 @@ instance Graph D where
     isDirected = const True
     isD = const True
 
+instance (Graph d, Serialize v, Serialize e, Hashable v, Eq v) => Serialize (LGraph d v e) where
+    put gr = do
+        put nlabs
+        put es
+        put elabs
+      where
+        nlabs = map (nodeLab gr) $ nodes gr
+        es = edges gr
+        elabs = map (edgeLab gr) es
+    get = do
+        nlabs <- get
+        es <- get
+        elabs <- get
+        return $ mkGraph nlabs $ zip es elabs
+
 empty :: (Graph d, Hashable v, Serialize v, Eq v, Serialize e)
       => LGraph d v e
 empty = runST $ new 0 >>= unsafeFreeze
@@ -236,8 +243,8 @@ nmap fn gr = unsafePerformIO $ do
     (MLGraph g) <- thaw gr
     forM_ (nodes gr) $ \i -> do
         let label = fn (i, nodeLab gr i)
-        bs <- unsafeToBS label
-        with bs (igraphHaskellAttributeVASSet g vertexAttr i)
+        asBS label $ \bs ->
+            with bs (igraphHaskellAttributeVASSet g vertexAttr i)
     unsafeFreeze (MLGraph g)
 
 -- | Map a function over the edge labels in a graph
@@ -248,6 +255,6 @@ emap fn gr = unsafePerformIO $ do
     forM_ (edges gr) $ \(fr, to) -> do
         let label = fn ((fr,to), edgeLabByEid gr i)
             i = igraphGetEid g fr to True True
-        bs <- unsafeToBS label
-        with bs (igraphHaskellAttributeEASSet g edgeAttr i)
+        asBS label $ \bs ->
+            with bs (igraphHaskellAttributeEASSet g edgeAttr i)
     unsafeFreeze (MLGraph g)

src/IGraph/Community.hs

@@ -4,32 +4,31 @@ module IGraph.Community
     , findCommunity
     ) where
 
-import Control.Monad
-import Control.Applicative ((<$>))
-import Foreign
-import Foreign.C.Types
-import System.IO.Unsafe (unsafePerformIO)
-import Data.List
-import Data.Ord
-import Data.Function (on)
-import Data.Default.Class
+import           Control.Applicative       ((<$>))
+import           Control.Monad
+import           Data.Default.Class
+import           Data.Function             (on)
+import           Data.List
+import           Data.Ord
+import           Foreign
+import           Foreign.C.Types
+import           System.IO.Unsafe          (unsafePerformIO)
 
-import IGraph
-import IGraph.Mutable (U)
-import IGraph.Internal.Data
-import IGraph.Internal.Constants
-import IGraph.Internal.Community
-import IGraph.Internal.Arpack
+import           IGraph
+import           IGraph.Internal.Arpack
+import           IGraph.Internal.Community
+import           IGraph.Internal.Constants
+import           IGraph.Internal.Data
 
 data CommunityOpt = CommunityOpt
-    { _method :: CommunityMethod
-    , _weights :: Maybe [Double]
-    , _nIter :: Int  -- ^ [LeadingEigenvector] number of iterations, default is 10000
-    , _nSpins :: Int  -- ^ [Spinglass] number of spins, default is 25
+    { _method    :: CommunityMethod
+    , _weights   :: Maybe [Double]
+    , _nIter     :: Int  -- ^ [LeadingEigenvector] number of iterations, default is 10000
+    , _nSpins    :: Int  -- ^ [Spinglass] number of spins, default is 25
     , _startTemp :: Double  -- ^ [Spinglass] the temperature at the start
-    , _stopTemp :: Double  -- ^ [Spinglass] the algorithm stops at this temperature
-    , _coolFact :: Double  -- ^ [Spinglass] the cooling factor for the simulated annealing
-    , _gamma :: Double  -- ^ [Spinglass] the gamma parameter of the algorithm. 
+    , _stopTemp  :: Double  -- ^ [Spinglass] the algorithm stops at this temperature
+    , _coolFact  :: Double  -- ^ [Spinglass] the cooling factor for the simulated annealing
+    , _gamma     :: Double  -- ^ [Spinglass] the gamma parameter of the algorithm.
     }
 
 data CommunityMethod = LeadingEigenvector
@@ -52,7 +51,7 @@ findCommunity gr opt = unsafePerformIO $ do
     result <- igraphVectorNew 0
     ws <- case _weights opt of
         Just w -> listToVector w
-        _ -> liftM VectorPtr $ newForeignPtr_ $ castPtr nullPtr
+        _      -> liftM VectorPtr $ newForeignPtr_ $ castPtr nullPtr
 
     case _method opt of
         LeadingEigenvector -> do
@@ -60,7 +59,7 @@ findCommunity gr opt = unsafePerformIO $ do
             igraphCommunityLeadingEigenvector (_graph gr) ws nullPtr result
                                               (_nIter opt) ap nullPtr False
                                               nullPtr nullPtr nullPtr
-                                              nullFunPtr nullPtr  
+                                              nullFunPtr nullPtr
         Spinglass ->
             igraphCommunitySpinglass (_graph gr) ws nullPtr nullPtr result
                                      nullPtr (_nSpins opt) False (_startTemp opt)
@@ -70,4 +69,3 @@ findCommunity gr opt = unsafePerformIO $ do
 
     liftM ( map (fst . unzip) . groupBy ((==) `on` snd)
           . sortBy (comparing snd) . zip [0..] ) $ vectorPtrToList result
-

src/IGraph/Internal/Attribute.chs

@@ -20,14 +20,17 @@ import System.IO.Unsafe (unsafePerformIO)
 
 -- The returned object will not be trackced by Haskell's GC. It should be freed
 -- by foreign codes.
-unsafeToBS :: Serialize a => a -> IO BSLen
-unsafeToBS x = unsafeUseAsCStringLen bs $ \(ptr, n) -> do
-    newPtr <- mallocBytes n
-    copyBytes newPtr ptr n
-    return $ BSLen (newPtr, n)
+asBS :: Serialize a => a -> (BSLen -> IO b) -> IO b
+asBS x fn = unsafeUseAsCStringLen (encode x) (fn . BSLen)
+{-# INLINE asBS #-}
+
+asBSVector :: Serialize a => [a] -> (BSVectorPtr -> IO b) -> IO b
+asBSVector values fn = loop [] values
   where
-    bs = encode x
-{-# INLINE unsafeToBS #-}
+    loop acc (x:xs) = unsafeUseAsCStringLen (encode x) $ \ptr ->
+        loop (BSLen ptr : acc) xs
+    loop acc _ = listToBSVector (reverse acc) >>= fn
+{-# INLINE asBSVector #-}
 
 fromBS :: Serialize a => Ptr BSLen -> IO a
 fromBS ptr = do
@@ -38,15 +41,11 @@ fromBS ptr = do
         Right r -> return r
 {-# INLINE fromBS #-}
 
-makeAttributeRecord :: Serialize a
-                    => String    -- ^ name of the attribute
-                    -> [a]       -- ^ values of the attribute
-                    -> AttributeRecord
-makeAttributeRecord name xs = unsafePerformIO $ do
-    ptr <- newCAString name
-    value <- mapM unsafeToBS xs >>= listToBSVector
-    return $ AttributeRecord ptr 2 value
-{-# INLINE makeAttributeRecord #-}
+mkStrRec :: CString    -- ^ name of the attribute
+         -> BSVectorPtr       -- ^ values of the attribute
+         -> AttributeRecord
+mkStrRec name xs = AttributeRecord name 2 xs
+{-# INLINE mkStrRec #-}
 
 data AttributeRecord = AttributeRecord CString Int BSVectorPtr
 

src/IGraph/Internal/Graph.chs

@@ -12,19 +12,27 @@ import System.IO.Unsafe (unsafePerformIO)
 
 #include "haskell_igraph.h"
 
-{#pointer *igraph_t as IGraphPtr foreign finalizer igraph_destroy newtype#}
-
--- | create a igraph object and attach a finalizer
-igraphNew :: Int -> Bool -> HasInit -> IO IGraphPtr
-igraphNew n directed _ = igraphNew' n directed
-
+--------------------------------------------------------------------------------
 -- Graph Constructors and Destructors
+--------------------------------------------------------------------------------
+
+{#pointer *igraph_t as IGraphPtr foreign finalizer igraph_destroy newtype#}
 
 {#fun igraph_empty as igraphNew' { +, `Int', `Bool' } -> `IGraphPtr' #}
 
 {#fun igraph_copy as ^ { +, `IGraphPtr' } -> `IGraphPtr' #}
 
+-- | Create a igraph object and attach a finalizer
+igraphNew :: Int -> Bool -> HasInit -> IO IGraphPtr
+igraphNew n directed _ = do
+    IGraphPtr ptr <- igraphNew' n directed
+    addForeignPtrFinalizer igraph_destroy ptr
+    return $ IGraphPtr ptr
+
+
+--------------------------------------------------------------------------------
 -- Basic Query Operations
+--------------------------------------------------------------------------------
 
 {#fun pure igraph_vcount as ^ { `IGraphPtr' } -> `Int' #}
 

src/IGraph/Mutable.hs

 {-# LANGUAGE MultiParamTypeClasses #-}
-module IGraph.Mutable where
+module IGraph.Mutable
+    ( MGraph(..)
+    , MLGraph(..)
+    , setEdgeAttr
+    , setNodeAttr
+    , edgeAttr
+    , vertexAttr
+    )where
 
 import           Control.Monad                  (when)
 import           Control.Monad.Primitive
 import qualified Data.ByteString.Char8          as B
 import           Data.Serialize                 (Serialize)
 import           Foreign
+import           Foreign.C.String               (CString, withCString)
 
 import           IGraph.Internal.Attribute
 import           IGraph.Internal.Data
 import           IGraph.Internal.Graph
 import           IGraph.Internal.Initialization
 import           IGraph.Internal.Selector
+import           IGraph.Types
 
--- constants
 vertexAttr :: String
 vertexAttr = "vertex_attribute"
 
 edgeAttr :: String
 edgeAttr = "edge_attribute"
 
-type LEdge a = (Int, Int, a)
+withVertexAttr :: (CString -> IO a) -> IO a
+withVertexAttr = withCString vertexAttr
+{-# INLINE withVertexAttr #-}
 
--- | Mutable labeled graph
-newtype MLGraph m d v e = MLGraph IGraphPtr
+withEdgeAttr :: (CString -> IO a) -> IO a
+withEdgeAttr = withCString edgeAttr
+{-# INLINE withEdgeAttr #-}
 
 class MGraph d where
     new :: PrimMonad m => Int -> m (MLGraph (PrimState m) d v e)
@@ -37,10 +48,10 @@ class MGraph d where
               -> MLGraph (PrimState m) d v e -> m ()
     addLNodes n labels (MLGraph g)
         | n /= length labels = error "addLVertices: incorrect number of labels"
-        | otherwise = unsafePrimToPrim $ do
-            with (makeAttributeRecord vertexAttr labels) $ \ptr -> do
+        | otherwise = unsafePrimToPrim $ withVertexAttr $ \vattr ->
+            asBSVector labels $ \bsvec -> with (mkStrRec vattr bsvec) $ \ptr -> do
                 vptr <- listToVectorP [castPtr ptr]
-                withVectorPPtr vptr $ \p -> igraphAddVertices g n $ castPtr p
+                withVectorPPtr vptr (igraphAddVertices g n . castPtr)
 
     delNodes :: PrimMonad m => [Int] -> MLGraph (PrimState m) d v e -> m ()
     delNodes ns (MLGraph g) = unsafePrimToPrim $ do
@@ -50,33 +61,26 @@ class MGraph d where
         return ()
 
     addEdges :: PrimMonad m => [(Int, Int)] -> MLGraph (PrimState m) d v e -> m ()
-
-    addLEdges :: (PrimMonad m, Serialize e) => [LEdge e] -> MLGraph (PrimState m) d v e -> m ()
-
-    delEdges :: PrimMonad m => [(Int, Int)] -> MLGraph (PrimState m) d v e -> m ()
-
-data U = U
-data D = D
-
-instance MGraph U where
-    new n = unsafePrimToPrim $ igraphInit >>= igraphNew n False >>= return . MLGraph
-
     addEdges es (MLGraph g) = unsafePrimToPrim $ do
         vec <- listToVector xs
         igraphAddEdges g vec nullPtr
       where
         xs = concatMap ( \(a,b) -> [fromIntegral a, fromIntegral b] ) es
 
-    addLEdges es (MLGraph g) = unsafePrimToPrim $ do
-        vec <- listToVector $ concat xs
-        let attr = makeAttributeRecord edgeAttr vs
-        alloca $ \ptr -> do
-            poke ptr attr
+    addLEdges :: (PrimMonad m, Serialize e) => [LEdge e] -> MLGraph (PrimState m) d v e -> m ()
+    addLEdges es (MLGraph g) = unsafePrimToPrim $ withEdgeAttr $ \eattr ->
+        asBSVector vs $ \bsvec -> with (mkStrRec eattr bsvec) $ \ptr -> do
+            vec <- listToVector $ concat xs
             vptr <- listToVectorP [castPtr ptr]
-            withVectorPPtr vptr $ \p -> igraphAddEdges g vec $ castPtr p
+            withVectorPPtr vptr (igraphAddEdges g vec . castPtr)
       where
         (xs, vs) = unzip $ map ( \(a,b,v) -> ([fromIntegral a, fromIntegral b], v) ) es
 
+    delEdges :: PrimMonad m => [(Int, Int)] -> MLGraph (PrimState m) d v e -> m ()
+
+instance MGraph U where
+    new n = unsafePrimToPrim $ igraphInit >>= igraphNew n False >>= return . MLGraph
+
     delEdges es (MLGraph g) = unsafePrimToPrim $ do
         vptr <- listToVector $ map fromIntegral eids
         esptr <- igraphEsVector vptr
@@ -88,22 +92,6 @@ instance MGraph U where
 instance MGraph D where
     new n = unsafePrimToPrim $ igraphInit >>= igraphNew n True >>= return . MLGraph
 
-    addEdges es (MLGraph g) = unsafePrimToPrim $ do
-        vec <- listToVector xs
-        igraphAddEdges g vec nullPtr
-      where
-        xs = concatMap ( \(a,b) -> [fromIntegral a, fromIntegral b] ) es
-
-    addLEdges es (MLGraph g) = unsafePrimToPrim $ do
-        vec <- listToVector $ concat xs
-        let attr = makeAttributeRecord edgeAttr vs
-        alloca $ \ptr -> do
-            poke ptr attr
-            vptr <- listToVectorP [castPtr ptr]
-            withVectorPPtr vptr $ \p -> igraphAddEdges g vec $ castPtr p
-      where
-        (xs, vs) = unzip $ map ( \(a,b,v) -> ([fromIntegral a, fromIntegral b], v) ) es
-
     delEdges es (MLGraph g) = unsafePrimToPrim $ do
         vptr <- listToVector $ map fromIntegral eids
         esptr <- igraphEsVector vptr
@@ -117,10 +105,9 @@ setNodeAttr :: (PrimMonad m, Serialize v)
             -> v
             -> MLGraph (PrimState m) d v e
             -> m ()
-setNodeAttr nodeId x (MLGraph gr) = unsafePrimToPrim $ do
-    v <- unsafeToBS x
-    with v $ \vptr -> do
-        err <- igraphHaskellAttributeVASSet gr vertexAttr nodeId vptr
+setNodeAttr nodeId x (MLGraph gr) = unsafePrimToPrim $ asBS x $ \bs ->
+    with bs $ \bsptr -> do
+        err <- igraphHaskellAttributeVASSet gr vertexAttr nodeId bsptr
         when (err /= 0) $ error "Fail to set node attribute!"
 
 setEdgeAttr :: (PrimMonad m, Serialize v)
@@ -128,8 +115,7 @@ setEdgeAttr :: (PrimMonad m, Serialize v)
             -> v
             -> MLGraph (PrimState m) d v e
             -> m ()
-setEdgeAttr edgeId x (MLGraph gr) = unsafePrimToPrim $ do
-    v <- unsafeToBS x
-    with v $ \vptr -> do
-        err <- igraphHaskellAttributeEASSet gr edgeAttr edgeId vptr
+setEdgeAttr edgeId x (MLGraph gr) = unsafePrimToPrim $ asBS x $ \bs ->
+    with bs $ \bsptr -> do
+        err <- igraphHaskellAttributeEASSet gr edgeAttr edgeId bsptr
         when (err /= 0) $ error "Fail to set edge attribute!"

src/IGraph/Types.hs

+
+module IGraph.Types where
+
+import qualified Data.HashMap.Strict   as M
+
+import           IGraph.Internal.Graph
+
+type Node = Int
+type Edge = (Node, Node)
+type LEdge a = (Int, Int, a)
+
+data U = U
+data D = D
+
+-- | Mutable labeled graph
+newtype MLGraph m d v e = MLGraph IGraphPtr
+
+-- | graph with labeled nodes and edges
+data LGraph d v e = LGraph
+    { _graph       :: IGraphPtr
+    , _labelToNode :: M.HashMap v [Node]
+    }

tests/Test/Attributes.hs

@@ -7,6 +7,7 @@ import           Control.Monad.ST
 import           Data.List
 import           Data.List.Ordered         (nubSort)
 import           Data.Maybe
+import           Data.Serialize
 import           Foreign
 import           System.IO.Unsafe
 import           Test.Tasty
@@ -14,24 +15,18 @@ import           Test.Tasty.HUnit
 import           Test.Utils
 
 import           IGraph
+import           IGraph.Exporter.GEXF
 import           IGraph.Internal.Attribute
 import           IGraph.Mutable
 import           IGraph.Structure
 
 tests :: TestTree
 tests = testGroup "Attribute tests"
-    [ bsTest
-    , nodeLabelTest
+    [ nodeLabelTest
     , labelTest
+    , serializeTest
     ]
 
-bsTest :: TestTree
-bsTest = testCase "BS" $ do
-    let values = [1..10000] :: [Int]
-    bs <- mapM unsafeToBS values
-    values' <- forM bs $ \b -> with b $ \ptr -> fromBS ptr
-    assertBool "" $ values == values'
-
 nodeLabelTest :: TestTree
 nodeLabelTest = testCase "node label test" $ do
     let ns = sort $ map show [38..7000]
@@ -45,3 +40,17 @@ labelTest = testCase "edge label test" $ do
         gr = fromLabeledEdges es :: LGraph D Int String
         es' = sort $ map (\(a,b) -> ((nodeLab gr a, nodeLab gr b), edgeLab gr (a,b))) $ edges gr
     assertBool "" $ es == es'
+
+serializeTest :: TestTree
+serializeTest = testCase "serialize test" $ do
+    dat <- randEdges 1000 10000
+    let es = map ( \(a, b) -> (
+            ( defaultNodeAttributes{_nodeZindex=a}
+            , defaultNodeAttributes{_nodeZindex=b}), defaultEdgeAttributes) ) dat
+        gr = fromLabeledEdges es :: LGraph D NodeAttr EdgeAttr
+        gr' :: LGraph D NodeAttr EdgeAttr
+        gr' = case decode $ encode gr of
+            Left msg -> error msg
+            Right r  -> r
+        es' = map (\(a,b) -> ((nodeLab gr' a, nodeLab gr' b), edgeLab gr' (a,b))) $ edges gr'
+    assertBool "" $ sort (map show es) == sort (map show es')