implement mutable graph

haskell-igraph.cabal

@@ -26,6 +26,7 @@ library
     IGraph.Internal.Clique
     IGraph.Internal.Community
     IGraph
+    IGraph.Mutable
     IGraph.Clique
     IGraph.Community
     IGraph.Read
@@ -36,6 +37,7 @@ library
     , bytestring >=0.9
     , cereal
     , bytestring-lexing
+    , primitive
 
   extra-libraries:     igraph
   hs-source-dirs:      src

src/IGraph.hs

 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 module IGraph where
 
-import Foreign hiding (new)
+import Control.Monad.ST (runST)
+import Control.Monad.Primitive
 import Data.Maybe
 
+import IGraph.Mutable
 import IGraph.Internal.Graph
-import IGraph.Internal.Initialization
-import IGraph.Internal.Data
 import IGraph.Internal.Attribute
-import System.IO.Unsafe (unsafePerformIO)
 
--- constants
-vertexAttr :: String
-vertexAttr = "vertex_attribute"
-
-edgeAttr :: String
-edgeAttr = "edge_attribute"
-
-data U
-data D
-
-type LEdge a = (Int, Int, a)
+type family Mutable (gr :: * -> * -> * -> *) :: * -> * -> * -> * -> *
+type instance Mutable LGraph = MLGraph
 
 -- | graph with labeled nodes and edges
 data LGraph d v e = LGraph
     { _graph :: IGraphPtr }
 
-class Graph gr d where
-    empty :: gr d v e
-    empty = new 0
-
-    new :: Int -> gr d v e
-
+class MGraph (Mutable gr) d => Graph gr d where
     mkGraph :: (Show v, Show e) => (Int, Maybe [v]) -> ([(Int, Int)], Maybe [e]) -> gr d v e
-    mkGraph (n, vattr) (es,eattr) = unsafePerformIO $ do
-        let g = empty
-            addV | isNothing vattr = addVertices n g
+    mkGraph (n, vattr) (es,eattr) = runST $ do
+        g <- new 0
+        let addV | isNothing vattr = addVertices n g
                  | otherwise = addLVertices n (fromJust vattr) g
             addE | isNothing eattr = addEdges es g
                  | otherwise = addLEdges (zip' es (fromJust eattr)) g
         addV
         addE
-        return g
+        unsafeFreeze g
       where
         zip' a b | length a /= length b = error "incorrect length"
                  | otherwise = zipWith (\(x,y) z -> (x,y,z)) a b
@@ -50,49 +37,16 @@ class Graph gr d where
 
     edgeLab :: Read e => (Int, Int) -> gr d v e -> e
 
-    addVertices :: Int -> gr d v e -> IO ()
-
-    addLVertices :: Show v
-                 => Int  -- ^ the number of new vertices add to the graph
-                 -> [v]  -- ^ vertices' labels
-                 -> gr d v e -> IO ()
-
-    addEdges :: [(Int, Int)] -> gr d v e -> IO ()
+    unsafeFreeze :: PrimMonad m => Mutable gr (PrimState m) d v e -> m (gr d v e)
 
-    addLEdges :: Show e => [LEdge e] -> gr d v e -> IO ()
+    unsafeThaw :: PrimMonad m => gr d v e -> m (Mutable gr (PrimState m) d v e)
 
 
 instance Graph LGraph U where
-    new n = unsafePerformIO $ igraphInit >>= igraphNew n False >>= return . LGraph
-
     vertexLab i (LGraph g) = read $ igraphCattributeVAS g vertexAttr i
 
     edgeLab (fr,to) (LGraph g) = read $ igraphCattributeEAS g edgeAttr $ igraphGetEid g fr to True True
 
-    addVertices n (LGraph g) = igraphAddVertices g n nullPtr
-
-    addLVertices n labels (LGraph g)
-        | n /= length labels = error "addLVertices: incorrect number of labels"
-        | otherwise = do
-            let attr = makeAttributeRecord vertexAttr labels
-            alloca $ \ptr -> do
-                poke ptr attr
-                vptr <- listToVectorP [castPtr ptr]
-                igraphAddVertices g n (castPtr vptr)
-
-    addEdges es (LGraph g) = do
-        vec <- listToVector xs
-        igraphAddEdges g vec nullPtr
-      where
-        xs = concatMap ( \(a,b) -> [fromIntegral a, fromIntegral b] ) es
-
-    addLEdges es (LGraph g) = do
-        vec <- listToVector $ concat xs
-        let attr = makeAttributeRecord edgeAttr vs
-        alloca $ \ptr -> do
-            poke ptr attr
-            vptr <- listToVectorP [castPtr ptr]
-            igraphAddEdges g vec (castPtr vptr)
-      where
-        (xs, vs) = unzip $ map ( \(a,b,v) -> ([fromIntegral a, fromIntegral b], v) ) es
+    unsafeFreeze (MLGraph g) = return $ LGraph g
 
+    unsafeThaw (LGraph g) = return $ MLGraph g

src/IGraph/Community.hs

@@ -12,12 +12,13 @@ import Data.Ord
 import Data.Function (on)
 
 import IGraph
+import IGraph.Mutable (U)
 import IGraph.Internal.Data
 import IGraph.Internal.Community
 import IGraph.Internal.Arpack
 
-communityLeadingEigenvector :: LGraph d v e
-                            -> (LGraph d v e -> Maybe [Double])  -- ^ extract weights
+communityLeadingEigenvector :: LGraph U v e
+                            -> (LGraph U v e -> Maybe [Double])  -- ^ extract weights
                             -> Int  -- ^ number of steps
                             -> [[Int]]
 communityLeadingEigenvector g@(LGraph gr) fn step = unsafePerformIO $ do

src/IGraph/Mutable.hs

+{-# LANGUAGE MultiParamTypeClasses #-}
+module IGraph.Mutable where
+
+import Foreign
+import Control.Monad.Primitive
+
+import IGraph.Internal.Graph
+import IGraph.Internal.Data
+import IGraph.Internal.Attribute
+import IGraph.Internal.Initialization
+
+-- constants
+vertexAttr :: String
+vertexAttr = "vertex_attribute"
+
+edgeAttr :: String
+edgeAttr = "edge_attribute"
+
+type LEdge a = (Int, Int, a)
+
+class MGraph gr d where
+    new :: PrimMonad m => Int -> m (gr (PrimState m) d v e)
+
+    addVertices :: PrimMonad m => Int -> gr (PrimState m) d v e -> m ()
+
+    addLVertices :: (Show v, PrimMonad m)
+                 => Int  -- ^ the number of new vertices add to the graph
+                 -> [v]  -- ^ vertices' labels
+                 -> gr (PrimState m) d v e -> m ()
+
+    addEdges :: PrimMonad m => [(Int, Int)] -> gr (PrimState m) d v e -> m ()
+
+    addLEdges :: (PrimMonad m, Show e) => [LEdge e] -> gr (PrimState m) d v e -> m ()
+
+-- | Mutable labeled graph
+newtype MLGraph m d v e = MLGraph IGraphPtr
+
+data U
+data D
+
+instance MGraph MLGraph U where
+    new n = unsafePrimToPrim $ igraphInit >>= igraphNew n False >>= return . MLGraph
+
+    addVertices n (MLGraph g) = unsafePrimToPrim $ igraphAddVertices g n nullPtr
+
+    addLVertices n labels (MLGraph g)
+        | n /= length labels = error "addLVertices: incorrect number of labels"
+        | otherwise = unsafePrimToPrim $ do
+            let attr = makeAttributeRecord vertexAttr labels
+            alloca $ \ptr -> do
+                poke ptr attr
+                vptr <- listToVectorP [castPtr ptr]
+                igraphAddVertices g n (castPtr vptr)
+
+    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]
+            igraphAddEdges g vec (castPtr vptr)
+      where
+        (xs, vs) = unzip $ map ( \(a,b,v) -> ([fromIntegral a, fromIntegral b], v) ) es

test.hs

@@ -3,6 +3,7 @@ import Control.Monad
 import Data.Serialize
 import qualified Data.ByteString.Internal as B
 import IGraph
+import IGraph.Mutable
 import IGraph.Read
 import IGraph.Clique
 import IGraph.Community