haggle (empty) → 0.1.0.0

raw patch · 20 files changed

+3237/−0 lines, 20 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, containers, deepseq, fgl, haggle, hashable, monad-primitive, primitive, ref-tf, test-framework, test-framework-hunit, test-framework-quickcheck2, vector

Files

• ChangeLog +3/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• haggle.cabal +68/−0
• src/Data/Graph/Haggle.hs +385/−0
• src/Data/Graph/Haggle/Algorithms/DFS.hs +213/−0
• src/Data/Graph/Haggle/Algorithms/Dominators.hs +149/−0
• src/Data/Graph/Haggle/BiDigraph.hs +243/−0
• src/Data/Graph/Haggle/Classes.hs +211/−0
• src/Data/Graph/Haggle/Digraph.hs +266/−0
• src/Data/Graph/Haggle/EdgeLabelAdapter.hs +215/−0
• src/Data/Graph/Haggle/Internal/Adapter.hs +395/−0
• src/Data/Graph/Haggle/Internal/Basic.hs +74/−0
• src/Data/Graph/Haggle/Internal/BitSet.hs +49/−0
• src/Data/Graph/Haggle/LabelAdapter.hs +14/−0
• src/Data/Graph/Haggle/PatriciaTree.hs +165/−0
• src/Data/Graph/Haggle/SimpleBiDigraph.hs +239/−0
• src/Data/Graph/Haggle/VertexLabelAdapter.hs +262/−0
• src/Data/Graph/Haggle/VertexMap.hs +99/−0
• tests/GraphTests.hs +155/−0

@@ -0,0 +1,3 @@+0.1.0.0+-------+- Initial release

@@ -0,0 +1,30 @@+Copyright (c) 2013, Tristan Ravitch++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 Tristan Ravitch 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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,68 @@+name: haggle+version: 0.1.0.0+synopsis: A graph library offering mutable, immutable, and inductive graphs+description: This library provides mutable (in ST or IO), immutable, and inductive graphs.+             There are multiple graphs implementations provided to support different use+             cases and time/space tradeoffs.  It is a design goal of haggle to be flexible+             and allow users to "pay as they go".  Node and edge labels are optional.  Haggle+             also aims to be safer than fgl: there are no partial functions in the API.++license: BSD3+license-file: LICENSE+author: Tristan Ravitch+maintainer: tristan@ravit.ch+category: Data Structures, Graphs+build-type: Simple+cabal-version: >=1.10+tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1+extra-source-files: ChangeLog++library+  default-language: Haskell2010+  hs-source-dirs: src+  ghc-options: -Wall+  if impl(ghc > 8)+     ghc-options: -Wno-compat+  exposed-modules: Data.Graph.Haggle,+                   Data.Graph.Haggle.BiDigraph,+                   Data.Graph.Haggle.Classes,+                   Data.Graph.Haggle.Digraph,+                   Data.Graph.Haggle.SimpleBiDigraph,+                   Data.Graph.Haggle.PatriciaTree,+                   Data.Graph.Haggle.LabelAdapter,+                   Data.Graph.Haggle.VertexLabelAdapter,+                   Data.Graph.Haggle.EdgeLabelAdapter,+                   Data.Graph.Haggle.VertexMap,+                   Data.Graph.Haggle.Algorithms.DFS,+                   Data.Graph.Haggle.Algorithms.Dominators+  other-modules: Data.Graph.Haggle.Internal.Adapter,+                 Data.Graph.Haggle.Internal.Basic,+                 Data.Graph.Haggle.Internal.BitSet+  build-depends: base >= 4.5 && < 5,+                 ref-tf >= 0.4 && < 0.5,+                 vector >= 0.9 && < 0.13,+                 primitive >= 0.4 && < 0.9,+                 containers >= 0.4,+                 hashable < 1.4,+                 deepseq >= 1 && < 2,+                 monad-primitive++test-suite GraphTests+  type: exitcode-stdio-1.0+  default-language: Haskell2010+  main-is: GraphTests.hs+  hs-source-dirs: tests+  ghc-options: -Wall+  build-depends: haggle,+                 base >= 4.5,+                 containers,+                 fgl,+                 HUnit,+                 QuickCheck > 2.4,+                 test-framework,+                 test-framework-hunit,+                 test-framework-quickcheck2++source-repository head+  type: git+  location: https://github.com/travitch/haggle

@@ -0,0 +1,385 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+-- | Haggle is a Haskell graph library.+--+-- The main idea behind haggle is that graphs are constructed with mutation+-- (either in 'IO' or 'ST').  After the graph is constructed, it is frozen+-- into an immutable graph.  This split is a major difference between+-- haggle and the other major Haskell graph library, fgl, which is+-- formulated in terms of inductive graphs that can always be modified+-- in a purely-functional way.  Supporting the inductive graph interface+-- severely limits implementation choices and optimization opportunities, so+-- haggle tries a different approach.+--+-- Furthermore, the types of vertices (nodes in FGL) and edges are held+-- as abstract in haggle, allowing for changes later if necessary.  That said,+-- changes are unlikely and the representations are exposed (with no+-- guarantees) through an Internal module.+--+-- Enough talk, example time:+--+-- > import Control.Monad ( replicateM )+-- > import Data.Graph.Haggle+-- > import Data.Graph.Haggle.Digraph+-- > import Data.Graph.Haggle.Algorithms.DFS+-- >+-- > main :: IO ()+-- > main = do+-- >   g <- newMDigraph+-- >   [v0, v1, v2] <- replicateM 3 (addVertex g)+-- >   e1 <- addEdge g v0 v1+-- >   e2 <- addEdge g v1 v2+-- >   gi <- freeze g+-- >   print (dfs gi v1) -- [V 1, V 2] since the first vertex is 0+--+-- The example builds a graph with three vertices and performs a DFS+-- from the middle vertex.  Note that the DFS algorithm is implemented on+-- immutable graphs, so we freeze the mutable graph before traversing it.  The+-- graph type in this example is a directed graph.+--+-- There are other graph variants that support efficient access to predecessor+-- edges: bidirectional graphs.  There are also simple graph variants that+-- prohibit parallel edges.+--+-- The core graph implementations support only vertices and edges.  /Adapters/+-- add support for 'Vertex' and 'Edge' labels.  See 'EdgeLabelAdapter',+-- 'VertexLabelAdapter', and 'LabelAdapter' (which supports both).  This+-- split allows the core implementations of graphs and graph algorithms to+-- be fast and compact (since they do not need to allocate storage for or+-- manipulate labels).  The adapters store labels on the side, similarly+-- to the property maps of Boost Graph Library.  Also note that the adapters+-- are strongly typed.  To add edges to a graph with edge labels, you must call+-- 'addLabeledEdge' instead of 'addEdge'.  Likewise for graphs with vertex+-- labels and 'addLabeledVertex'/'addVertex'.  This requirement is enforced+-- in the type system so that labels cannot become out-of-sync with the+-- structure of the graph.  The adapters each work with any type of underlying+-- graph.+module Data.Graph.Haggle (+  -- * Graph types+  -- ** Mutable graphs+  D.MDigraph,+  D.newMDigraph,+  D.newSizedMDigraph,+  B.MBiDigraph,+  B.newMBiDigraph,+  B.newSizedMBiDigraph,+  SBD.MSimpleBiDigraph,+  SBD.newMSimpleBiDigraph,+  SBD.newSizedMSimpleBiDigraph,+  -- *** Adapters+  EA.EdgeLabeledMGraph,+  EA.newEdgeLabeledGraph,+  EA.newSizedEdgeLabeledGraph,+  VA.VertexLabeledMGraph,+  VA.newVertexLabeledGraph,+  VA.newSizedVertexLabeledGraph,+  A.LabeledMGraph,+  A.newLabeledGraph,+  A.newSizedLabeledGraph,+  -- ** Immutable graphs+  D.Digraph,+  B.BiDigraph,+  SBD.SimpleBiDigraph,+  -- *** Adapters+  EA.EdgeLabeledGraph,+  VA.VertexLabeledGraph,+  VA.fromEdgeList,+  A.LabeledGraph,+  A.fromLabeledEdgeList,+  -- ** Inductive graphs+  PT.PatriciaTree,+  -- * Basic types+  I.Vertex,+  I.Edge,+  I.edgeSource,+  I.edgeDest,++  -- * Mutable graph operations+  getVertices,+  getSuccessors,+  getOutEdges,+  countVertices,+  countEdges,+  checkEdgeExists,+  freeze,++  addVertex,+  addEdge,++  getEdgeLabel,+  unsafeGetEdgeLabel,+  addLabeledEdge,++  getVertexLabel,+  addLabeledVertex,+  getLabeledVertices,++  removeVertex,+  removeEdgesBetween,+  removeEdge,+++  getPredecessors,+  getInEdges,++  -- ** Mutable labeled graph operations+  A.mapEdgeLabel,+  A.mapVertexLabel,++  -- * Immutable graph operations+  vertices,+  edges,+  successors,+  outEdges,+  edgesBetween,+  edgeExists,+  isEmpty,+  thaw,++  predecessors,+  inEdges,++  edgeLabel,+  labeledEdges,+  labeledOutEdges,++  vertexLabel,+  labeledVertices,++  labeledInEdges,++  -- * Inductive graph operations+  emptyGraph,+  match,+  context,+  insertLabeledVertex,+  insertLabeledEdge,+  deleteEdge,+  deleteEdgesBetween,+  replaceLabeledEdge,+  deleteVertex,+  I.Context(..),++  -- * Classes++  -- | These classes are a critical implementation detail, but are+  -- re-exported to simplify writing type signatures for generic+  -- functions.+  I.MGraph,+  I.ImmutableGraph,+  I.MAddVertex,+  I.MAddEdge,+  I.MLabeledEdge,+  I.MEdgeLabel,+  I.MLabeledVertex,+  I.MVertexLabel,+  I.MRemovable,+  I.MBidirectional,+  I.Graph,+  I.Thawable,+  I.MutableGraph,+  I.Bidirectional,+  I.HasEdgeLabel,+  I.EdgeLabel,+  I.HasVertexLabel,+  I.VertexLabel,+  I.BidirectionalEdgeLabel,+  I.InductiveGraph+  ) where++import qualified Control.Monad.Primitive as P+import qualified Control.Monad.Ref as R++import qualified Data.Graph.Haggle.Classes as I+import qualified Data.Graph.Haggle.Digraph as D+import qualified Data.Graph.Haggle.BiDigraph as B+import qualified Data.Graph.Haggle.SimpleBiDigraph as SBD+import qualified Data.Graph.Haggle.PatriciaTree as PT++import qualified Data.Graph.Haggle.EdgeLabelAdapter as EA+import qualified Data.Graph.Haggle.VertexLabelAdapter as VA+import qualified Data.Graph.Haggle.LabelAdapter as A++-- Mutable graphs++getVertices :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => g m -> m [I.Vertex]+getVertices = I.getVertices+{-# INLINABLE getVertices #-}++getSuccessors :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => g m -> I.Vertex -> m [I.Vertex]+getSuccessors = I.getSuccessors+{-# INLINABLE getSuccessors #-}++getOutEdges :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => g m -> I.Vertex -> m [I.Edge]+getOutEdges = I.getOutEdges+{-# INLINABLE getOutEdges #-}++countVertices :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => g m -> m Int+countVertices = I.countVertices+{-# INLINABLE countVertices #-}++countEdges :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => g m -> m Int+countEdges = I.countEdges+{-# INLINABLE countEdges #-}++checkEdgeExists :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => g m -> I.Vertex -> I.Vertex -> m Bool+checkEdgeExists = I.checkEdgeExists+{-# INLINABLE checkEdgeExists #-}++freeze :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => g m -> m (I.ImmutableGraph g)+freeze = I.freeze+{-# INLINABLE freeze #-}++addVertex :: (I.MAddVertex g, P.PrimMonad m, R.MonadRef m) => g m -> m I.Vertex+addVertex = I.addVertex+{-# INLINABLE addVertex #-}++addEdge :: (I.MAddEdge g, P.PrimMonad m, R.MonadRef m) => g m -> I.Vertex -> I.Vertex -> m (Maybe I.Edge)+addEdge = I.addEdge+{-# INLINABLE addEdge #-}++getEdgeLabel :: (I.MLabeledEdge g, P.PrimMonad m, R.MonadRef m) => g m -> I.Edge -> m (Maybe (I.MEdgeLabel g))+getEdgeLabel = I.getEdgeLabel+{-# INLINABLE getEdgeLabel #-}++unsafeGetEdgeLabel :: (I.MLabeledEdge g, P.PrimMonad m, R.MonadRef m) => g m -> I.Edge -> m (I.MEdgeLabel g)+unsafeGetEdgeLabel = I.unsafeGetEdgeLabel+{-# INLINABLE unsafeGetEdgeLabel #-}++addLabeledEdge :: (I.MLabeledEdge g, P.PrimMonad m, R.MonadRef m) => g m -> I.Vertex -> I.Vertex -> I.MEdgeLabel g -> m (Maybe I.Edge)+addLabeledEdge = I.addLabeledEdge+{-# INLINABLE addLabeledEdge #-}++getVertexLabel :: (I.MLabeledVertex g, P.PrimMonad m, R.MonadRef m) => g m -> I.Vertex -> m (Maybe (I.MVertexLabel g))+getVertexLabel = I.getVertexLabel+{-# INLINABLE getVertexLabel #-}++addLabeledVertex :: (I.MLabeledVertex g, P.PrimMonad m, R.MonadRef m) => g m -> I.MVertexLabel g -> m I.Vertex+addLabeledVertex = I.addLabeledVertex+{-# INLINABLE addLabeledVertex #-}++getLabeledVertices :: (I.MLabeledVertex g, P.PrimMonad m, R.MonadRef m) => g m -> m [(I.Vertex, I.MVertexLabel g)]+getLabeledVertices = I.getLabeledVertices+{-# INLINABLE getLabeledVertices #-}++removeVertex :: (I.MRemovable g, P.PrimMonad m, R.MonadRef m) => g m -> I.Vertex -> m ()+removeVertex = I.removeVertex+{-# INLINABLE removeVertex #-}++removeEdgesBetween :: (I.MRemovable g, P.PrimMonad m, R.MonadRef m) => g m -> I.Vertex -> I.Vertex -> m ()+removeEdgesBetween = I.removeEdgesBetween+{-# INLINABLE removeEdgesBetween #-}++removeEdge :: (I.MRemovable g, P.PrimMonad m, R.MonadRef m) => g m -> I.Edge -> m ()+removeEdge = I.removeEdge+{-# INLINABLE removeEdge #-}++getPredecessors :: (I.MBidirectional g, P.PrimMonad m, R.MonadRef m) => g m -> I.Vertex -> m [I.Vertex]+getPredecessors = I.getPredecessors+{-# INLINABLE getPredecessors #-}++getInEdges :: (I.MBidirectional g, P.PrimMonad m, R.MonadRef m) => g m -> I.Vertex -> m [I.Edge]+getInEdges = I.getInEdges+{-# INLINABLE getInEdges #-}++-- Immutable graphs++vertices :: (I.Graph g) => g -> [I.Vertex]+vertices = I.vertices+{-# INLINABLE vertices #-}++edges :: (I.Graph g) => g -> [I.Edge]+edges = I.edges+{-# INLINABLE edges #-}++successors :: (I.Graph g) => g -> I.Vertex -> [I.Vertex]+successors = I.successors+{-# INLINABLE successors #-}++outEdges :: (I.Graph g) => g -> I.Vertex -> [I.Edge]+outEdges = I.outEdges+{-# INLINABLE outEdges #-}++edgesBetween :: (I.Graph g) => g -> I.Vertex -> I.Vertex -> [I.Edge]+edgesBetween = I.edgesBetween+{-# INLINABLE edgesBetween #-}++edgeExists :: (I.Graph g) => g -> I.Vertex -> I.Vertex -> Bool+edgeExists = I.edgeExists+{-# INLINABLE edgeExists #-}++isEmpty :: (I.Graph g) => g -> Bool+isEmpty = I.isEmpty+{-# INLINABLE isEmpty #-}++thaw :: (I.Thawable g, P.PrimMonad m, R.MonadRef m) => g -> m (I.MutableGraph g m)+thaw = I.thaw+{-# INLINABLE thaw #-}++predecessors :: (I.Bidirectional g) => g -> I.Vertex -> [I.Vertex]+predecessors = I.predecessors+{-# INLINABLE predecessors #-}++inEdges :: (I.Bidirectional g) => g -> I.Vertex -> [I.Edge]+inEdges = I.inEdges+{-# INLINABLE inEdges #-}++edgeLabel :: (I.HasEdgeLabel g) => g -> I.Edge -> Maybe (I.EdgeLabel g)+edgeLabel = I.edgeLabel+{-# INLINABLE edgeLabel #-}++labeledEdges :: (I.HasEdgeLabel g) => g -> [(I.Edge, I.EdgeLabel g)]+labeledEdges = I.labeledEdges+{-# INLINABLE labeledEdges #-}++labeledOutEdges :: (I.HasEdgeLabel g) => g -> I.Vertex -> [(I.Edge, I.EdgeLabel g)]+labeledOutEdges = I.labeledOutEdges+{-# INLINABLE labeledOutEdges #-}++labeledInEdges :: (I.BidirectionalEdgeLabel g) => g -> I.Vertex -> [(I.Edge, I.EdgeLabel g)]+labeledInEdges = I.labeledInEdges+{-# INLINABLE labeledInEdges #-}++vertexLabel :: (I.HasVertexLabel g) => g -> I.Vertex -> Maybe (I.VertexLabel g)+vertexLabel = I.vertexLabel+{-# INLINABLE vertexLabel #-}++labeledVertices :: (I.HasVertexLabel g) => g -> [(I.Vertex, I.VertexLabel g)]+labeledVertices = I.labeledVertices+{-# INLINABLE labeledVertices #-}++emptyGraph :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g+emptyGraph = I.emptyGraph+{-# INLINABLE emptyGraph #-}++match :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g -> I.Vertex -> Maybe (I.Context g, g)+match = I.match+{-# INLINABLE match #-}++context :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g -> I.Vertex -> Maybe (I.Context g)+context = I.context+{-# INLINABLE context #-}++insertLabeledVertex :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g -> I.VertexLabel g -> (I.Vertex, g)+insertLabeledVertex = I.insertLabeledVertex+{-# INLINABLE insertLabeledVertex #-}++insertLabeledEdge :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g -> I.Vertex -> I.Vertex -> I.EdgeLabel g -> Maybe (I.Edge, g)+insertLabeledEdge = I.insertLabeledEdge+{-# INLINABLE insertLabeledEdge #-}++deleteEdge :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g -> I.Edge -> g+deleteEdge = I.deleteEdge+{-# INLINABLE deleteEdge #-}++deleteEdgesBetween :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g -> I.Vertex -> I.Vertex -> g+deleteEdgesBetween = I.deleteEdgesBetween+{-# INLINABLE deleteEdgesBetween #-}++replaceLabeledEdge :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g -> I.Vertex -> I.Vertex -> I.EdgeLabel g -> Maybe (I.Edge, g)+replaceLabeledEdge = I.replaceLabeledEdge+{-# INLINABLE replaceLabeledEdge #-}++deleteVertex :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g -> I.Vertex -> g+deleteVertex = I.deleteVertex+{-# INLINABLE deleteVertex #-}

@@ -0,0 +1,213 @@+-- | Depth-first search and derived operations.+--+-- All of the search variants take a list of 'Vertex' that serves as+-- roots for the search.+--+-- The [x] variants ('xdfsWith' and 'xdffWith') are the most general+-- and are fully configurable in direction and action.  They take a+-- \"direction\" function that tells the search what vertices are+-- next from the current 'Vertex'.  They also take a summarization function+-- to convert a 'Vertex' into some other value.  This could be 'id' or a+-- function to extract a label, if supported by your graph type.+--+-- The [r] variants are reverse searches, while the [u] variants are+-- undirected.+--+-- A depth-first forest is a collection (list) of depth-first trees.  A+-- depth-first tree is an n-ary tree rooted at a vertex that contains+-- the vertices reached in a depth-first search from that root.  The+-- edges in the tree are a subset of the edges in the graph.+module Data.Graph.Haggle.Algorithms.DFS (+  -- * Depth-first Searches+  xdfsWith,+  dfsWith,+  dfs,+  rdfsWith,+  rdfs,+  udfsWith,+  udfs,+  -- * Depth-first Forests+  xdffWith,+  dffWith,+  dff,+  rdffWith,+  rdff,+  udffWith,+  udff,+  -- * Derived Queries+  components,+  noComponents,+  isConnected,+  topsort,+  scc,+  reachable+  ) where++import Control.Monad ( filterM, foldM, liftM )+import Control.Monad.ST+import qualified Data.Foldable as F+import Data.Monoid+import qualified Data.Sequence as Seq+import Data.Tree ( Tree )+import qualified Data.Tree as T++import Prelude++import Data.Graph.Haggle+import Data.Graph.Haggle.Classes ( maxVertexId )+import Data.Graph.Haggle.Internal.Basic+import Data.Graph.Haggle.Internal.BitSet++-- | The most general DFS+xdfsWith :: (Graph g)+         => g+         -> (Vertex -> [Vertex])+         -> (Vertex -> c)+         -> [Vertex]+         -> [c]+xdfsWith g nextVerts f roots+  | isEmpty g || null roots = []+  | otherwise = runST $ do+    bs <- newBitSet (maxVertexId g + 1)+    res <- foldM (go bs) [] roots+    return $ reverse res+  where+    go bs acc v = do+      isMarked <- testBit bs (vertexId v)+      case isMarked of+        True -> return acc+        False -> do+          setBit bs (vertexId v)+          nxt <- filterM (notVisited bs) (nextVerts v)+          foldM (go bs) (f v : acc) nxt++notVisited :: BitSet s -> Vertex -> ST s Bool+notVisited bs v = liftM not (testBit bs (vertexId v))++-- | Forward parameterized DFS+dfsWith :: (Graph g)+        => g+        -> (Vertex -> c)+        -> [Vertex]+        -> [c]+dfsWith g = xdfsWith g (successors g)++-- | Forward DFS+dfs :: (Graph g) => g -> [Vertex] -> [Vertex]+dfs g = dfsWith g id++-- | Reverse parameterized DFS+rdfsWith :: (Bidirectional g)+         => g+         -> (Vertex -> c)+         -> [Vertex]+         -> [c]+rdfsWith g = xdfsWith g (predecessors g)++-- | Reverse DFS+rdfs :: (Bidirectional g) => g -> [Vertex] -> [Vertex]+rdfs g = rdfsWith g id++-- | Undirected parameterized DFS.  This variant follows both+-- incoming and outgoing edges from each 'Vertex'.+udfsWith :: (Bidirectional g)+         => g+         -> (Vertex -> c)+         -> [Vertex]+         -> [c]+udfsWith g = xdfsWith g (neighbors g)++-- | Undirected DFS+udfs :: (Bidirectional g) => g -> [Vertex] -> [Vertex]+udfs g = udfsWith g id++-- | The most general depth-first forest.+xdffWith :: (Graph g)+         => g+         -> (Vertex -> [Vertex])+         -> (Vertex -> c)+         -> [Vertex]+         -> [Tree c]+xdffWith g nextVerts f roots+  | isEmpty g || null roots = []+  | otherwise = runST $ do+    bs <- newBitSet (maxVertexId g + 1)+    res <- foldM (go bs) [] roots+    return $ reverse res+  where+    go bs acc v = do+      isMarked <- testBit bs (vertexId v)+      case isMarked of+        True -> return acc+        False -> do+          setBit bs (vertexId v)+          nxt <- filterM (notVisited bs) (nextVerts v)+          ts <- foldM (go bs) [] nxt+          return $ T.Node (f v) (reverse ts) : acc++dffWith :: (Graph g)+        => g+        -> (Vertex -> c)+        -> [Vertex]+        -> [Tree c]+dffWith g = xdffWith g (successors g)++dff :: (Graph g) => g -> [Vertex] -> [Tree Vertex]+dff g = dffWith g id++rdffWith :: (Bidirectional g) => g -> (Vertex -> c) -> [Vertex] -> [Tree c]+rdffWith g = xdffWith g (predecessors g)++rdff :: (Bidirectional g) => g -> [Vertex] -> [Tree Vertex]+rdff g = rdffWith g id++udffWith :: (Bidirectional g) => g -> (Vertex -> c) -> [Vertex] -> [Tree c]+udffWith g = xdffWith g (neighbors g)++udff :: (Bidirectional g) => g -> [Vertex] -> [Tree Vertex]+udff g = udffWith g id++-- Derived++-- | Return a list of each connected component in the graph+components :: (Bidirectional g) => g -> [[Vertex]]+components g = map preorder $ udff g (vertices g)++-- | The number of components in the graph+noComponents :: (Bidirectional g) => g -> Int+noComponents = length . components++-- | True if there is only a single component in the graph.+isConnected :: (Bidirectional g) => g -> Bool+isConnected = (==1) . noComponents++-- | Topologically sort the graph; the input must be a DAG.+topsort :: (Graph g) => g -> [Vertex]+topsort g = reverse $ F.toList $ postflattenF $ dff g (vertices g)++-- | Return a list of each /strongly-connected component/ in the graph.+-- In a strongly-connected component, every vertex is reachable from every+-- other vertex.+scc :: (Bidirectional g) => g -> [[Vertex]]+scc g = map preorder (rdff g (topsort g))++-- | Compute the set of vertices reachable from a root 'Vertex'.+reachable :: (Graph g) => Vertex -> g -> [Vertex]+reachable v g = preorderF (dff g [v])++-- Helpers++neighbors :: (Bidirectional g) => g -> Vertex -> [Vertex]+neighbors g v = successors g v ++ predecessors g v++preorder :: Tree a -> [a]+preorder = T.flatten++preorderF :: [Tree a] -> [a]+preorderF = concatMap preorder++postflatten :: Tree a -> Seq.Seq a+postflatten (T.Node v ts) = postflattenF ts <> Seq.singleton v++postflattenF :: [Tree a] -> Seq.Seq a+postflattenF = F.foldMap postflatten

@@ -0,0 +1,149 @@+-- | Compute the dominators in a graph from a root node.+--+-- The set of dominators for a 'Vertex' in a graph is always with regard+-- to a @root@ 'Vertex', given as input to the algorithm.  'Vertex' @d@+-- dominates 'Vertex' @v@ if every path from the @root@ to @v@ must go+-- through @d@.  @d@ strictly dominates @v@ if @d@ dominates @v@ and is not+-- @v@.  The immediate dominator of @v@ is the unique 'Vertex' that strictly+-- dominates @v@ and does not strictly dominate any other 'Vertex' that+-- dominates @v@.+--+-- This implementation is ported from FGL (<http://hackage.haskell.org/package/fgl>)+-- and is substantially similar.  The major change is that it uses the vector+-- library instead of array.+--+-- The algorithm is based on \"A Simple, Fast Dominance Algorithm\" by+-- Cooper, Harvey, and Kennedy+--+-- <http://www.cs.rice.edu/~keith/EMBED/dom.pdf>+--+-- This is not Tarjan's algorithm; supposedly this is faster in practice+-- for most graphs.+module Data.Graph.Haggle.Algorithms.Dominators (+  immediateDominators,+  dominators+  ) where++import Data.Map ( Map )+import qualified Data.Map as M+import Data.Maybe ( fromMaybe )+import Data.Set ( Set )+import qualified Data.Set as S+import Data.Tree ( Tree(..) )+import qualified Data.Tree as T+import Data.Vector ( Vector, (!) )+import qualified Data.Vector as V++import Data.Graph.Haggle+import Data.Graph.Haggle.Algorithms.DFS++type ToNode = Vector Vertex+type FromNode = Map Vertex Int+type IDom = Vector Int+type Preds = Vector [Int]++-- | Compute the immediate dominators in the graph from the @root@ 'Vertex'.+-- Each 'Vertex' reachable from the @root@ will be paired with its immediate+-- dominator.  Note that there is no entry in the result pairing for the+-- root 'Vertex' because it has no immediate dominator.+--+-- If the root vertex is not in the graph, an empty list is returned.+immediateDominators :: (Graph g) => g -> Vertex -> [(Vertex, Vertex)]+immediateDominators g root = fromMaybe [] $ do+  (res, toNode, _) <- domWork g root+  return $ tail $ V.toList $ V.imap (\i n -> (toNode!i, toNode!n)) res++-- | Compute all of the dominators for each 'Vertex' reachable from the @root@.+-- Each reachable 'Vertex' is paired with the list of nodes that dominate it,+-- including the 'Vertex' itself.  The @root@ is only dominated by itself.+dominators :: (Graph g) => g -> Vertex -> [(Vertex, [Vertex])]+dominators g root = fromMaybe [] $ do+  (res, toNode, fromNode) <- domWork g root+  let dom' = getDom toNode res+      rest = M.keys (M.filter (-1 ==) fromNode)+      verts = vertices g+  return $ [(toNode ! i, dom' ! i) | i <- [0..V.length dom' - 1]] +++           [(n, verts) | n <- rest]++domWork :: (Graph g) => g -> Vertex -> Maybe (IDom, ToNode, FromNode)+domWork g root+  | null trees = Nothing+  | otherwise = return (idom, toNode, fromNode)+  where+    -- Build up a depth-first tree from the root as a first approximation+    trees@(~[tree]) = dff g [root]+    (s, ntree) = numberTree 0 tree+    -- Start with an approximation (idom0) where the idom of each node is+    -- its parent in the depth-first tree.  Note that index 0 is the root,+    -- which we will basically be ignoring (since it has no dominator).+    dom0Map = M.fromList (treeEdges (-1) ntree)+    idom0 = V.generate (M.size dom0Map) (dom0Map M.!)+    -- Build a mapping from graph vertices to internal indices.  @treeNodes@+    -- are nodes that are in the depth-first tree from the root.  @otherNodes@+    -- are the rest of the nodes in the graph, mapped to -1 (since they aren't+    -- going to be in the result)+    treeNodes = M.fromList $ zip (T.flatten tree) (T.flatten ntree)+    otherNodes = M.fromList $ zip (vertices g) (repeat (-1))+    fromNode = M.unionWith const treeNodes otherNodes+    -- Translate from internal nodes back to graph nodes (only need the nodes+    -- in the depth-first tree)+    toNodeMap = M.fromList $ zip (T.flatten ntree) (T.flatten tree)+    toNode = V.generate (M.size toNodeMap) (toNodeMap M.!)++    -- Use a pre-pass over the graph to collect predecessors so that we don't+    -- require a Bidirectional graph.  We need a linear pass over the graph+    -- here anyway, so we don't lose anything.+    predMap = fmap S.toList $ foldr (toPredecessor g) M.empty (vertices g)+    preds = V.fromList $ [0] : [filter (/= -1) (map (fromNode M.!) (predMap M.! (toNode ! i)))+                               | i <- [1..s-1]]+    idom = fixEq (refineIDom preds) idom0++toPredecessor :: (Graph g)+              => g+              -> Vertex+              -> Map Vertex (Set Vertex)+              -> Map Vertex (Set Vertex)+toPredecessor g pre m = foldr addPred m (successors g pre)+  where+    addPred suc = M.insertWith S.union suc (S.singleton pre)++refineIDom :: Preds -> IDom -> IDom+refineIDom preds idom = fmap (foldl1 (intersect idom)) preds++intersect :: IDom -> Int -> Int -> Int+intersect idom a b =+  case a `compare` b of+    LT -> intersect idom a (idom ! b)+    EQ -> a+    GT -> intersect idom (idom ! a) b++-- Helpers++getDom :: ToNode -> IDom -> Vector [Vertex]+getDom toNode idom = res+  where+    -- The root dominates itself (the only dominator for the root)+    root = [toNode ! 0]+    res = V.fromList $ root : [toNode ! i : res ! (idom ! i) | i <- [1..V.length idom - 1]]++treeEdges :: a -> Tree a -> [(a,a)]+treeEdges a (Node b ts) = (b,a) : concatMap (treeEdges b) ts++-- relabel tree, labeling vertices with consecutive numbers in depth first order+numberTree :: Int -> Tree a -> (Int, Tree Int)+numberTree n (Node _ ts) = let (n', ts') = numberForest (n+1) ts+                           in  (n', Node n ts')++-- same as numberTree, for forests.+numberForest :: Int -> [Tree a] -> (Int, [Tree Int])+numberForest n []     = (n, [])+numberForest n (t:ts) = let (n', t')   = numberTree n t+                            (n'', ts') = numberForest n' ts+                        in  (n'', t':ts')++fixEq :: Eq a => (a -> a) -> a -> a+fixEq f v+  | v' == v   = v+  | otherwise = fixEq f v'+  where+    v' = f v

@@ -0,0 +1,243 @@+{-# LANGUAGE TypeFamilies #-}+-- | This graph is an efficient representation of bidirectional graphs with+-- parallel edges.+--+-- This is in contrast to 'Data.Graph.Haggle.SimpleBiDigraph', which+-- can only handle simple graphs (i.e., without parallel edges).+--+-- The representation is slightly less efficient as a result.+module Data.Graph.Haggle.BiDigraph (+  MBiDigraph,+  BiDigraph,+  newMBiDigraph,+  newSizedMBiDigraph+  ) where++import Control.Monad ( when )+import qualified Control.Monad.Primitive as P+import qualified Control.Monad.Ref as R+import Data.IntMap ( IntMap )+import qualified Data.IntMap as IM+import qualified Data.Vector.Mutable as MV+import qualified Data.Vector as V++import Data.Graph.Haggle.Classes+import Data.Graph.Haggle.Internal.Basic++-- | A mutable bidirectional graph+data MBiDigraph m =+  MBiDigraph { mgraphVertexCount :: R.Ref m Int+             , mgraphEdgeCount :: R.Ref m Int+             , mgraphEdgeIdSrc :: R.Ref m Int+             , mgraphPreds :: R.Ref m (MV.MVector (P.PrimState m) (IntMap [Edge]))+             , mgraphSuccs :: R.Ref m (MV.MVector (P.PrimState m) (IntMap [Edge]))+             }++-- | An immutable bidirectional graph+data BiDigraph =+  BiDigraph { vertexCount :: {-# UNPACK #-} !Int+            , edgeCount :: {-# UNPACK #-} !Int+            , edgeIdSrc :: {-# UNPACK #-} !Int+            , graphPreds :: V.Vector (IntMap [Edge])+            , graphSuccs :: V.Vector (IntMap [Edge])+            }+++defaultSize :: Int+defaultSize = 128++-- | Allocate a new mutable bidirectional graph with a default size+newMBiDigraph :: (P.PrimMonad m, R.MonadRef m) => m (MBiDigraph m)+newMBiDigraph = newSizedMBiDigraph defaultSize 0++-- | Allocate a new mutable bidirectional graph with space reserved+-- for nodes and edges.  This can be more efficient and avoid resizing.+newSizedMBiDigraph :: (P.PrimMonad m, R.MonadRef m)+                   => Int -- ^ Reserved space for nodes+                   -> Int -- ^ Reserved space for edges+                   -> m (MBiDigraph m)+newSizedMBiDigraph szNodes _ = do+  when (szNodes < 0) $ error "newSizedMBiDigraph: Negative size"+  nn <- R.newRef 0+  en <- R.newRef 0+  esrc <- R.newRef 0+  pvec <- MV.new szNodes+  svec <- MV.new szNodes+  pref <- R.newRef pvec+  sref <- R.newRef svec+  return $! MBiDigraph { mgraphVertexCount = nn+                       , mgraphEdgeCount = en+                       , mgraphEdgeIdSrc = esrc+                       , mgraphPreds = pref+                       , mgraphSuccs = sref+                       }++instance MGraph MBiDigraph where+  type ImmutableGraph MBiDigraph = BiDigraph+  getVertices g = do+    nVerts <- R.readRef (mgraphVertexCount g)+    return [ V v | v <- [0.. nVerts - 1] ]++  getOutEdges g (V src) = do+    nVerts <- R.readRef (mgraphVertexCount g)+    case src >= nVerts of+      True -> return []+      False -> do+        svec <- R.readRef (mgraphSuccs g)+        succs <- MV.unsafeRead svec src+        return $ concat (IM.elems succs)+  countVertices = R.readRef . mgraphVertexCount+  countEdges = R.readRef . mgraphEdgeCount++  getSuccessors g (V src) = do+    nVerts <- R.readRef (mgraphVertexCount g)+    case src >= nVerts of+      True -> return []+      False -> do+        svec <- R.readRef (mgraphSuccs g)+        succs <- MV.unsafeRead svec src+        return $ map V $ IM.keys succs++  checkEdgeExists g (V src) (V dst) = do+    nVerts <- R.readRef (mgraphVertexCount g)+    case src >= nVerts || dst >= nVerts of+      True -> return False+      False -> do+        svec <- R.readRef (mgraphSuccs g)+        succs <- MV.unsafeRead svec src+        return $ IM.member dst succs++  freeze g = do+    nVerts <- R.readRef (mgraphVertexCount g)+    nEdges <- R.readRef (mgraphEdgeCount g)+    esrc <- R.readRef (mgraphEdgeIdSrc g)+    pvec <- R.readRef (mgraphPreds g)+    svec <- R.readRef (mgraphSuccs g)+    pvec' <- V.freeze (MV.take nVerts pvec)+    svec' <- V.freeze (MV.take nVerts svec)+    return $! BiDigraph { vertexCount = nVerts+                        , edgeCount = nEdges+                        , edgeIdSrc = esrc+                        , graphPreds = pvec'+                        , graphSuccs = svec'+                        }++instance MAddVertex MBiDigraph where+  addVertex g = do+    ensureNodeSpace g+    vid <- R.readRef r+    R.modifyRef' r (+1)+    pvec <- R.readRef (mgraphPreds g)+    svec <- R.readRef (mgraphSuccs g)+    MV.write pvec vid IM.empty+    MV.write svec vid IM.empty+    return (V vid)+    where+      r = mgraphVertexCount g+++instance MAddEdge MBiDigraph where+  addEdge g v1@(V src) v2@(V dst) = do+    nVerts <- R.readRef (mgraphVertexCount g)+    exists <- checkEdgeExists g v1 v2+    case exists || src >= nVerts || dst >= nVerts of+      True -> return Nothing+      False -> do+        eid <- R.readRef (mgraphEdgeIdSrc g)+        R.modifyRef' (mgraphEdgeIdSrc g) (+1)+        R.modifyRef' (mgraphEdgeCount g) (+1)+        let e = E eid src dst+        pvec <- R.readRef (mgraphPreds g)+        preds <- MV.unsafeRead pvec dst+        MV.unsafeWrite pvec dst (IM.insertWith (++) src [e] preds)++        svec <- R.readRef (mgraphSuccs g)+        succs <- MV.unsafeRead svec src+        MV.unsafeWrite svec src (IM.insertWith (++) dst [e] succs)++        return $ Just e++instance MBidirectional MBiDigraph where+  getPredecessors g (V vid) = do+    nVerts <- R.readRef (mgraphVertexCount g)+    case vid < nVerts of+      False -> return []+      True -> do+        pvec <- R.readRef (mgraphPreds g)+        preds <- MV.unsafeRead pvec vid+        return $ map V $ IM.keys preds++  getInEdges g (V vid) = do+    nVerts <- R.readRef (mgraphVertexCount g)+    case vid < nVerts of+      False -> return []+      True -> do+        pvec <- R.readRef (mgraphPreds g)+        preds <- MV.unsafeRead pvec vid+        return $ concat (IM.elems preds)++instance Thawable BiDigraph where+  type MutableGraph BiDigraph = MBiDigraph+  thaw g = do+    vc <- R.newRef (vertexCount g)+    ec <- R.newRef (edgeCount g)+    eidsrc <- R.newRef (edgeIdSrc g)+    pvec <- V.thaw (graphPreds g)+    svec <- V.thaw (graphSuccs g)+    pref <- R.newRef pvec+    sref <- R.newRef svec+    return MBiDigraph { mgraphVertexCount = vc+                      , mgraphEdgeCount = ec+                      , mgraphEdgeIdSrc = eidsrc+                      , mgraphPreds = pref+                      , mgraphSuccs = sref+                      }++instance Graph BiDigraph where+  vertices g = map V [0 .. vertexCount g - 1]+  edges g = concatMap (outEdges g) (vertices g)+  successors g (V v)+    | outOfRange g v = []+    | otherwise = map V $ IM.keys $ V.unsafeIndex (graphSuccs g) v+  outEdges g (V v)+    | outOfRange g v = []+    | otherwise =+      let succs = V.unsafeIndex (graphSuccs g) v+      in concat (IM.elems succs)+  edgesBetween g (V src) (V dst)+    | outOfRange g src || outOfRange g dst = []+    | otherwise = IM.findWithDefault [] dst (V.unsafeIndex (graphSuccs g) src)+  maxVertexId g = V.length (graphSuccs g) - 1+  isEmpty = (==0) . vertexCount++instance Bidirectional BiDigraph  where+  predecessors g (V v)+    | outOfRange g v = []+    | otherwise = map V $ IM.keys $ V.unsafeIndex (graphPreds g) v+  inEdges g (V v)+    | outOfRange g v = []+    | otherwise =+      let preds = V.unsafeIndex (graphPreds g) v+      in concat (IM.elems preds)++-- Helpers++outOfRange :: BiDigraph -> Int -> Bool+outOfRange g = (>= vertexCount g)++-- | Given a graph, ensure that there is space in the vertex vector+-- for a new vertex.  If there is not, double the capacity.+ensureNodeSpace :: (P.PrimMonad m, R.MonadRef m) => MBiDigraph m -> m ()+ensureNodeSpace g = do+  pvec <- R.readRef (mgraphPreds g)+  svec <- R.readRef (mgraphSuccs g)+  let cap = MV.length pvec+  cnt <- R.readRef (mgraphVertexCount g)+  case cnt < cap of+    True -> return ()+    False -> do+      pvec' <- MV.grow pvec cap+      svec' <- MV.grow svec cap+      R.writeRef (mgraphPreds g) pvec'+      R.writeRef (mgraphSuccs g) svec'+

@@ -0,0 +1,211 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+module Data.Graph.Haggle.Classes (+  -- * Basic Types+  Vertex,+  Edge,+  edgeSource,+  edgeDest,+  -- * Mutable Graphs+  MGraph(..),+  MAddEdge(..),+  MAddVertex(..),+  MRemovable(..),+  MBidirectional(..),+  MLabeledEdge(..),+  MLabeledVertex(..),+  -- * Immutable Graphs+  Graph(..),+  edgeExists,+  Thawable(..),+  Bidirectional(..),+  HasEdgeLabel(..),+  HasVertexLabel(..),+  BidirectionalEdgeLabel(..),+  -- * Inductive Graphs+  InductiveGraph(..),+  Context(..)+  ) where+++import Control.Monad ( forM, liftM )+import qualified Control.Monad.Primitive as P+import qualified Control.Monad.Ref as R+import Data.Maybe ( fromMaybe )+import Data.Graph.Haggle.Internal.Basic++-- | The interface supported by a mutable graph.+class MGraph g where+  -- | The type generated by 'freeze'ing a mutable graph+  type ImmutableGraph g++  -- | List all of the vertices in the graph.+  getVertices :: (P.PrimMonad m, R.MonadRef m) => g m -> m [Vertex]++  -- | List the successors for the given 'Vertex'.+  getSuccessors :: (P.PrimMonad m, R.MonadRef m) => g m -> Vertex -> m [Vertex]++  -- | Get all of the 'Edge's with the given 'Vertex' as their source.+  getOutEdges :: (P.PrimMonad m, R.MonadRef m) => g m -> Vertex -> m [Edge]++  -- | Return the number of vertices in the graph+  countVertices :: (P.PrimMonad m, R.MonadRef m) => g m -> m Int++  -- | Return the number of edges in the graph+  countEdges :: (P.PrimMonad m, R.MonadRef m) => g m -> m Int++  -- | Edge existence test; this has a default implementation,+  -- but can be overridden if an implementation can support a+  -- better-than-linear version.+  checkEdgeExists :: (P.PrimMonad m, R.MonadRef m) => g m -> Vertex -> Vertex -> m Bool+  checkEdgeExists g src dst = do+    succs <- getSuccessors g src+    return $ any (==dst) succs++  -- | Freeze the mutable graph into an immutable graph.+  freeze :: (P.PrimMonad m, R.MonadRef m) => g m -> m (ImmutableGraph g)++class (MGraph g) => MAddVertex g where+  -- | Add a new 'Vertex' to the graph, returning its handle.+  addVertex :: (P.PrimMonad m, R.MonadRef m) => g m -> m Vertex++class (MGraph g) => MAddEdge g where+  -- | Add a new 'Edge' to the graph from @src@ to @dst@.  If either+  -- the source or destination is not in the graph, returns Nothing.+  -- Otherwise, the 'Edge' reference is returned.+  addEdge :: (P.PrimMonad m, R.MonadRef m) => g m -> Vertex -> Vertex -> m (Maybe Edge)++class (MGraph g) => MLabeledEdge g where+  type MEdgeLabel g+  getEdgeLabel :: (P.PrimMonad m, R.MonadRef m) => g m -> Edge -> m (Maybe (MEdgeLabel g))+  getEdgeLabel g e = do+    nEs <- countEdges g+    case edgeId e >= nEs of+      True -> return Nothing+      False -> liftM Just (unsafeGetEdgeLabel g e)+  unsafeGetEdgeLabel :: (P.PrimMonad m, R.MonadRef m) => g m -> Edge -> m (MEdgeLabel g)+  addLabeledEdge :: (P.PrimMonad m, R.MonadRef m) => g m -> Vertex -> Vertex -> MEdgeLabel g -> m (Maybe Edge)++class (MGraph g) => MLabeledVertex g where+  type MVertexLabel g+  getVertexLabel :: (P.PrimMonad m, R.MonadRef m) => g m -> Vertex -> m (Maybe (MVertexLabel g))+  addLabeledVertex :: (P.PrimMonad m, R.MonadRef m) => g m -> MVertexLabel g -> m Vertex+  getLabeledVertices :: (P.PrimMonad m, R.MonadRef m) => g m -> m [(Vertex, MVertexLabel g)]+  getLabeledVertices g = do+    vs <- getVertices g+    forM vs $ \v -> do+      ml <- getVertexLabel g v+      case ml of+        Just l -> return (v, l)+        Nothing -> error ("impossible (missing label for vertex" ++ show v ++ ")")++-- | An interface for graphs that allow vertex and edge removal.  Note that+-- implementations are not required to reclaim storage from removed+-- vertices (just make them inaccessible).+class (MGraph g) => MRemovable g where+  removeVertex :: (P.PrimMonad m, R.MonadRef m) => g m -> Vertex -> m ()+  removeEdgesBetween :: (P.PrimMonad m, R.MonadRef m) => g m -> Vertex -> Vertex -> m ()+  removeEdge :: (P.PrimMonad m, R.MonadRef m) => g m -> Edge -> m ()++-- | An interface for graphs that support looking at predecessor (incoming+-- edges) efficiently.+class (MGraph g) => MBidirectional g where+  getPredecessors :: (P.PrimMonad m, R.MonadRef m) => g m -> Vertex -> m [Vertex]+  getInEdges :: (P.PrimMonad m, R.MonadRef m) => g m -> Vertex -> m [Edge]++-- | The basic interface of immutable graphs.+class Graph g where+  vertices :: g -> [Vertex]+  edges :: g -> [Edge]+  successors :: g -> Vertex -> [Vertex]+  outEdges :: g -> Vertex -> [Edge]+  maxVertexId :: g -> Int+  isEmpty :: g -> Bool+  -- | This has a default implementation in terms of 'outEdges', but is part+  -- of the class so that instances can offer a more efficient implementation+  -- when possible.+  edgesBetween :: g -> Vertex -> Vertex -> [Edge]+  edgesBetween g src dst = filter ((dst ==) . edgeDest) (outEdges g src)++edgeExists :: Graph g => g -> Vertex -> Vertex -> Bool+edgeExists g v1 v2 = not . null $ edgesBetween g v1 v2++class (Graph g) => Thawable g where+  type MutableGraph g :: (* -> *) -> *+  thaw :: (P.PrimMonad m, R.MonadRef m) => g -> m (MutableGraph g m)++-- | The interface for immutable graphs with efficient access to+-- incoming edges.+class (Graph g) => Bidirectional g where+  predecessors :: g -> Vertex -> [Vertex]+  inEdges :: g -> Vertex -> [Edge]++-- | The interface for immutable graphs with labeled edges.+class (Graph g) => HasEdgeLabel g where+  type EdgeLabel g+  edgeLabel :: g -> Edge -> Maybe (EdgeLabel g)+  labeledEdges :: g -> [(Edge, EdgeLabel g)]+  labeledOutEdges :: g -> Vertex -> [(Edge, EdgeLabel g)]+  labeledOutEdges g v = map (addEdgeLabel g) (outEdges g v)+++class (HasEdgeLabel g, Bidirectional g) => BidirectionalEdgeLabel g where+  labeledInEdges :: g -> Vertex -> [(Edge, EdgeLabel g)]+  labeledInEdges g v = map (addEdgeLabel g) (inEdges g v)++-- | The interface for immutable graphs with labeled vertices.+class (Graph g) => HasVertexLabel g where+  type VertexLabel g+  vertexLabel :: g -> Vertex -> Maybe (VertexLabel g)+  labeledVertices :: g -> [(Vertex, VertexLabel g)]++-- | Contexts represent the "context" of a 'Vertex', which includes the incoming edges of the 'Vertex',+-- the label of the 'Vertex', and the outgoing edges of the 'Vertex'.+data Context g = Context [(EdgeLabel g, Vertex)] (VertexLabel g) [(EdgeLabel g, Vertex)]++class (Graph g, HasEdgeLabel g, HasVertexLabel g) => InductiveGraph g where+  -- | The empty inductive graph+  emptyGraph :: g+  -- | The call+  --+  -- > let (c, g') = match g v+  --+  -- decomposes the graph into the 'Context' c of @v@ and the rest of+  -- the graph @g'@.+  match :: g -> Vertex -> Maybe (Context g, g)+  -- | Return the context of a 'Vertex'+  context :: g -> Vertex -> Maybe (Context g)+  -- | Insert a new labeled 'Vertex' into the graph.+  insertLabeledVertex :: g -> VertexLabel g -> (Vertex, g)+  -- | Must return 'Nothing' if either the source or destination 'Vertex' is not+  -- in the graph.  Also returns 'Nothing' if the edge already exists and the+  -- underlying graph does not support parallel edges.+  --+  -- Otherwise return the inserted 'Edge' and updated graph.+  insertLabeledEdge :: g -> Vertex -> Vertex -> EdgeLabel g -> Maybe (Edge, g)+  -- | Delete the given 'Edge'.  In a multigraph, this lets you remove+  -- a single parallel edge between two vertices.+  deleteEdge :: g -> Edge -> g+  -- | Delete all edges between a pair of vertices.+  deleteEdgesBetween :: g -> Vertex -> Vertex -> g++  -- | Like 'insertLabeledEdge', but overwrite any existing edges.  Equivalent+  -- to:+  --+  -- > let g' = deleteEdgesBetween g v1 v2+  -- > in insertLabeledEdge g v1 v2 lbl+  replaceLabeledEdge :: g -> Vertex -> Vertex -> EdgeLabel g -> Maybe (Edge, g)+  replaceLabeledEdge g src dst lbl =+    let g' = deleteEdgesBetween g src dst+    in insertLabeledEdge g' src dst lbl++  -- | Remove a 'Vertex' from the graph+  deleteVertex :: g -> Vertex -> g+  deleteVertex g v = fromMaybe g $ do+    (_, g') <- match g v+    return g'++addEdgeLabel :: (HasEdgeLabel g) => g -> Edge -> (Edge, EdgeLabel g)+addEdgeLabel g e = (e, el)+  where+   Just el = edgeLabel g e

@@ -0,0 +1,266 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+-- | This graph implementation is a directed (multi-)graph that only tracks+-- successors.  This encoding is very compact.  It is a multi-graph because it+-- allows parallel edges between vertices.  If you require only simple graphs,+-- careful edge insertion is required (or another graph type might be more+-- appropriate).+--+-- Limitations:+--+--  * Removing nodes and edges is not currently possible.+--+--  * Predecessors are not accessible+--+--  * Edge existence tests are /linear/ in the number of edges for+--    the source node.+module Data.Graph.Haggle.Digraph (+  MDigraph,+  Digraph,+  newMDigraph,+  newSizedMDigraph+  ) where++import qualified Control.DeepSeq as DS+import Control.Monad ( when )+import qualified Control.Monad.Primitive as P+import qualified Control.Monad.Ref as R+import qualified Data.Vector.Unboxed.Mutable as MUV+import qualified Data.Vector.Unboxed as UV++import Data.Graph.Haggle.Classes+import Data.Graph.Haggle.Internal.Basic++-- | This is a compact (mutable) directed graph.+data MDigraph m = -- See Note [Graph Representation]+  MDigraph { graphVertexCount :: R.Ref m Int+           , graphEdgeRoots :: R.Ref m (MUV.MVector (P.PrimState m) Int)+           , graphEdgeCount :: R.Ref m Int+           , graphEdgeTarget :: R.Ref m (MUV.MVector (P.PrimState m) Int)+           , graphEdgeNext :: R.Ref m (MUV.MVector (P.PrimState m) Int)+           }++data Digraph =+  Digraph { edgeRoots :: !(UV.Vector Int)+          , edgeTargets :: !(UV.Vector Int)+          , edgeNexts :: !(UV.Vector Int)+          }++-- | The 'Digraph' is always in normal form, as the vectors are all unboxed+instance DS.NFData Digraph where+  rnf !_g = ()++defaultSize :: Int+defaultSize = 128++-- | Create a new empty mutable graph with a small amount of storage+-- reserved for vertices and edges.+newMDigraph :: (P.PrimMonad m, R.MonadRef m) => m (MDigraph m)+newMDigraph = newSizedMDigraph defaultSize defaultSize++-- | Create a new empty graph with storage reserved for @szVerts@ vertices+-- and @szEdges@ edges.+--+-- > g <- newSizedMDigraph szVerts szEdges+newSizedMDigraph :: (P.PrimMonad m, R.MonadRef m) => Int -> Int -> m (MDigraph m)+newSizedMDigraph szNodes szEdges = do+  when (szNodes < 0 || szEdges < 0) $ error "Negative size (newSized)"+  nn <- R.newRef 0+  en <- R.newRef 0+  nVec <- MUV.new szNodes+  nVecRef <- R.newRef nVec+  eTarget <- MUV.new szEdges+  eTargetRef <- R.newRef eTarget+  eNext <- MUV.new szEdges+  eNextRef <- R.newRef eNext+  return $! MDigraph { graphVertexCount = nn+                   , graphEdgeRoots = nVecRef+                   , graphEdgeCount = en+                   , graphEdgeTarget = eTargetRef+                   , graphEdgeNext = eNextRef+                   }++++instance MGraph MDigraph where+  type ImmutableGraph MDigraph = Digraph+  getVertices g = do+    nVerts <- R.readRef (graphVertexCount g)+    return [V v | v <- [0..nVerts-1]]++  getOutEdges g (V src) = do+    nVerts <- R.readRef (graphVertexCount g)+    case src >= nVerts of+      True -> return []+      False -> do+        roots <- R.readRef (graphEdgeRoots g)+        lstRoot <- MUV.unsafeRead roots src+        findEdges g src lstRoot++  countVertices = R.readRef . graphVertexCount+  countEdges = R.readRef . graphEdgeCount++  getSuccessors g src = do+    es <- getOutEdges g src+    return $ map edgeDest es++  freeze g = do+    nVerts <- R.readRef (graphVertexCount g)+    nEdges <- R.readRef (graphEdgeCount g)+    roots <- R.readRef (graphEdgeRoots g)+    targets <- R.readRef (graphEdgeTarget g)+    nexts <- R.readRef (graphEdgeNext g)+    roots' <- UV.freeze (MUV.take nVerts roots)+    targets' <- UV.freeze (MUV.take nEdges targets)+    nexts' <- UV.freeze (MUV.take nEdges nexts)+    return $! Digraph { edgeRoots = roots'+                    , edgeTargets = targets'+                    , edgeNexts = nexts'+                    }++instance MAddVertex MDigraph where+  addVertex g = do+    ensureNodeSpace g+    vid <- R.readRef r+    R.modifyRef' r (+1)+    vec <- R.readRef (graphEdgeRoots g)+    MUV.unsafeWrite vec vid (-1)+    return (V vid)+    where+      r = graphVertexCount g++instance MAddEdge MDigraph where+  addEdge g (V src) (V dst) = do+    nVerts <- R.readRef (graphVertexCount g)+    case src >= nVerts || dst >= nVerts of+      True -> return Nothing+      False -> do+        ensureEdgeSpace g+        eid <- R.readRef (graphEdgeCount g)+        R.modifyRef' (graphEdgeCount g) (+1)+        rootVec <- R.readRef (graphEdgeRoots g)+        -- The current list of edges for src+        curListHead <- MUV.unsafeRead rootVec src++        -- Now create the new edge+        nextVec <- R.readRef (graphEdgeNext g)+        targetVec <- R.readRef (graphEdgeTarget g)+        MUV.unsafeWrite nextVec eid curListHead+        MUV.unsafeWrite targetVec eid dst++        -- The list now starts at our new edge+        MUV.unsafeWrite rootVec src eid+        return $ Just (E eid src dst)++instance Thawable Digraph where+  type MutableGraph Digraph = MDigraph+  thaw g = do+    vc <- R.newRef (UV.length (edgeRoots g))+    ec <- R.newRef (UV.length (edgeTargets g))+    rvec <- UV.thaw (edgeRoots g)+    tvec <- UV.thaw (edgeTargets g)+    nvec <- UV.thaw (edgeNexts g)+    rref <- R.newRef rvec+    tref <- R.newRef tvec+    nref <- R.newRef nvec+    return MDigraph { graphVertexCount = vc+                    , graphEdgeCount = ec+                    , graphEdgeRoots = rref+                    , graphEdgeTarget = tref+                    , graphEdgeNext = nref+                    }+++instance Graph Digraph where+  vertices g = map V [0 .. UV.length (edgeRoots g) - 1]+  edges g = concatMap (outEdges g) (vertices g)+  successors g (V v)+    | outOfRange g v = []+    | otherwise =+      let root = UV.unsafeIndex (edgeRoots g) v+      in pureSuccessors g root+  outEdges g (V v)+    | outOfRange g v = []+    | otherwise =+      let root = UV.unsafeIndex (edgeRoots g) v+      in pureEdges g v root+  maxVertexId g = UV.length (edgeRoots g) - 1+  isEmpty = (==0) . UV.length . edgeRoots++-- Helpers++outOfRange :: Digraph -> Int -> Bool+outOfRange g = (>= UV.length (edgeRoots g))++pureEdges :: Digraph -> Int -> Int -> [Edge]+pureEdges _ _ (-1) = []+pureEdges g src ix = E ix src dst : pureEdges g src nxt+  where+    dst = UV.unsafeIndex (edgeTargets g) ix+    nxt = UV.unsafeIndex (edgeNexts g) ix++pureSuccessors :: Digraph -> Int -> [Vertex]+pureSuccessors _ (-1) = []+pureSuccessors g ix = V s : pureSuccessors g nxt+  where+    s = UV.unsafeIndex (edgeTargets g) ix+    nxt = UV.unsafeIndex (edgeNexts g) ix++-- | Given the root of a successor list, traverse it and+-- accumulate all edges, stopping at -1.+findEdges :: (P.PrimMonad m, R.MonadRef m) => MDigraph m -> Int -> Int -> m [Edge]+findEdges _ _ (-1) = return []+findEdges g src root = do+  targets <- R.readRef (graphEdgeTarget g)+  nexts <- R.readRef (graphEdgeNext g)+  let go acc (-1) = return acc+      go acc ix = do+        tgt <- MUV.unsafeRead targets ix+        nxt <- MUV.unsafeRead nexts ix+        go (E ix src tgt : acc) nxt+  go [] root++-- | Given a graph, ensure that there is space in the vertex vector+-- for a new vertex.  If there is not, double the capacity.+ensureNodeSpace :: (P.PrimMonad m, R.MonadRef m) => MDigraph m -> m ()+ensureNodeSpace g = do+  vec <- R.readRef (graphEdgeRoots g)+  let cap = MUV.length vec+  cnt <- R.readRef (graphVertexCount g)+  case cnt < cap of+    True -> return ()+    False -> do+      vec' <- MUV.grow vec cap+      R.writeRef (graphEdgeRoots g) vec'++-- | Ensure that the graph has space for another edge.  If there is not,+-- double the edge capacity.+ensureEdgeSpace :: (P.PrimMonad m, R.MonadRef m) => MDigraph m -> m ()+ensureEdgeSpace g = do+  v1 <- R.readRef (graphEdgeTarget g)+  v2 <- R.readRef (graphEdgeNext g)+  nEdges <- R.readRef (graphEdgeCount g)+  let cap = MUV.length v1+  case nEdges < cap of+    True -> return ()+    False -> do+      v1' <- MUV.grow v1 cap+      v2' <- MUV.grow v2 cap+      R.writeRef (graphEdgeTarget g) v1'+      R.writeRef (graphEdgeNext g) v2'++{- Note [Graph Representation]++The edge roots vector is indexed by vertex id.  A -1 in the+vector indicates that there are no edges leaving the vertex.+Any other value is an index into BOTH the graphEdgeTarget and+graphEdgeNext vectors.++The graphEdgeTarget vector contains the vertex id of an edge+target.++The graphEdgeNext vector contains, at the same index, the index+of the next edge in the edge list (again into Target and Next).+A -1 indicates no more edges.++-}

@@ -0,0 +1,215 @@+{-# LANGUAGE TypeFamilies #-}+-- | This adapter adds edge labels (but not vertex labels) to graphs.+--+-- It only supports 'addLabeledEdge', not 'addEdge'.  See 'LabeledGraph'+-- for more details.+module Data.Graph.Haggle.EdgeLabelAdapter (+  EdgeLabeledMGraph,+  EdgeLabeledGraph,+  newEdgeLabeledGraph,+  newSizedEdgeLabeledGraph,+  mapEdgeLabel+  ) where++import qualified Control.DeepSeq as DS+import qualified Control.Monad.Primitive as P+import qualified Control.Monad.Ref as R+import qualified Data.Graph.Haggle.Classes as I+import qualified Data.Graph.Haggle.Internal.Adapter as A++newtype EdgeLabeledMGraph g el s = ELMG { unELMG :: A.LabeledMGraph g () el s }+newtype EdgeLabeledGraph g el = ELG { unELG :: A.LabeledGraph g () el }++instance (DS.NFData g, DS.NFData el) => DS.NFData (EdgeLabeledGraph g el) where+  rnf (ELG g) = g `DS.deepseq` ()++mapEdgeLabel :: EdgeLabeledGraph g el -> (el -> el') -> EdgeLabeledGraph g el'+mapEdgeLabel g = ELG . A.mapEdgeLabel (unELG g)+{-# INLINE mapEdgeLabel #-}++vertices :: (I.Graph g) => EdgeLabeledGraph g el -> [I.Vertex]+vertices = I.vertices . unELG+{-# INLINE vertices #-}++edges :: (I.Graph g) => EdgeLabeledGraph g el -> [I.Edge]+edges = I.edges . unELG+{-# INLINE edges #-}++successors :: (I.Graph g) => EdgeLabeledGraph g el -> I.Vertex -> [I.Vertex]+successors (ELG lg) = I.successors lg+{-# INLINE successors #-}++outEdges :: (I.Graph g) => EdgeLabeledGraph g el -> I.Vertex -> [I.Edge]+outEdges (ELG lg) = I.outEdges lg+{-# INLINE outEdges #-}++edgesBetween :: (I.Graph g) => EdgeLabeledGraph g el -> I.Vertex -> I.Vertex -> [I.Edge]+edgesBetween (ELG lg) = I.edgesBetween lg+{-# INLINE edgesBetween #-}++maxVertexId :: (I.Graph g) => EdgeLabeledGraph g el -> Int+maxVertexId = I.maxVertexId . unELG+{-# INLINE maxVertexId #-}++isEmpty :: (I.Graph g) => EdgeLabeledGraph g el -> Bool+isEmpty = I.isEmpty . unELG+{-# INLINE isEmpty #-}++instance (I.Graph g) => I.Graph (EdgeLabeledGraph g el) where+  vertices = vertices+  edges = edges+  successors = successors+  outEdges = outEdges+  edgesBetween = edgesBetween+  maxVertexId = maxVertexId+  isEmpty = isEmpty++instance (I.Thawable g) => I.Thawable (EdgeLabeledGraph g el) where+  type MutableGraph (EdgeLabeledGraph g el) =+    EdgeLabeledMGraph (I.MutableGraph g) el+  thaw (ELG lg) = do+    g' <- I.thaw lg+    return $ ELMG g'+++predecessors :: (I.Bidirectional g) => EdgeLabeledGraph g el -> I.Vertex -> [I.Vertex]+predecessors (ELG lg) = I.predecessors lg+{-# INLINE predecessors #-}++inEdges :: (I.Bidirectional g) => EdgeLabeledGraph g el -> I.Vertex -> [I.Edge]+inEdges (ELG lg) = I.inEdges lg+{-# INLINE inEdges #-}++instance (I.Bidirectional g) => I.Bidirectional (EdgeLabeledGraph g el) where+  predecessors = predecessors+  inEdges = inEdges++instance (I.Bidirectional g) => I.BidirectionalEdgeLabel (EdgeLabeledGraph g el)++edgeLabel :: (I.Graph g) => EdgeLabeledGraph g el -> I.Edge -> Maybe el+edgeLabel (ELG lg) = I.edgeLabel lg+{-# INLINE edgeLabel #-}++labeledEdges :: (I.Graph g) => EdgeLabeledGraph g el -> [(I.Edge, el)]+labeledEdges = I.labeledEdges . unELG+{-# INLINE labeledEdges #-}++instance (I.Graph g) => I.HasEdgeLabel (EdgeLabeledGraph g el) where+  type EdgeLabel (EdgeLabeledGraph g el) = el+  edgeLabel = edgeLabel+  labeledEdges = labeledEdges++newEdgeLabeledGraph :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+                    => m (g m)+                    -> m (EdgeLabeledMGraph g nl m)+newEdgeLabeledGraph newG = do+  g <- A.newLabeledGraph newG+  return $ ELMG g+{-# INLINE newEdgeLabeledGraph #-}++newSizedEdgeLabeledGraph :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+                         => (Int -> Int -> m (g m))+                         -> Int+                         -> Int+                         -> m (EdgeLabeledMGraph g el m)+newSizedEdgeLabeledGraph newG szV szE = do+  g <- A.newSizedLabeledGraph newG szV szE+  return $ ELMG g+{-# INLINE newSizedEdgeLabeledGraph #-}++addLabeledEdge :: (I.MGraph g, I.MAddEdge g, P.PrimMonad m, R.MonadRef m)+               => EdgeLabeledMGraph g el m+               -> I.Vertex+               -> I.Vertex+               -> el+               -> m (Maybe I.Edge)+addLabeledEdge lg = I.addLabeledEdge (unELMG lg)+{-# INLINE addLabeledEdge #-}++addVertex :: (I.MGraph g, I.MAddVertex g, P.PrimMonad m, R.MonadRef m)+          => EdgeLabeledMGraph g el m+          -> m I.Vertex+addVertex lg = I.addVertex (A.rawMGraph (unELMG lg))+{-# INLINE addVertex #-}++unsafeGetEdgeLabel :: (I.MGraph g, I.MAddEdge g, P.PrimMonad m, R.MonadRef m)+                   => EdgeLabeledMGraph g el m+                   -> I.Edge+                   -> m el+unsafeGetEdgeLabel (ELMG g) e =+  I.unsafeGetEdgeLabel g e+{-# INLINE unsafeGetEdgeLabel #-}++getSuccessors :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+              => EdgeLabeledMGraph g el m+              -> I.Vertex+              -> m [I.Vertex]+getSuccessors lg = I.getSuccessors (unELMG lg)+{-# INLINE getSuccessors #-}++getOutEdges :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+            => EdgeLabeledMGraph g el m -> I.Vertex -> m [I.Edge]+getOutEdges lg = I.getOutEdges (unELMG lg)+{-# INLINE getOutEdges #-}++countVertices :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => EdgeLabeledMGraph g el m -> m Int+countVertices = I.countVertices . unELMG+{-# INLINE countVertices #-}++getVertices :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => EdgeLabeledMGraph g el m -> m [I.Vertex]+getVertices = I.getVertices . unELMG+{-# INLINE getVertices #-}++countEdges :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => EdgeLabeledMGraph g el m -> m Int+countEdges = I.countEdges . unELMG+{-# INLINE countEdges #-}++getPredecessors :: (I.MBidirectional g, P.PrimMonad m, R.MonadRef m)+                => EdgeLabeledMGraph g el m -> I.Vertex -> m [I.Vertex]+getPredecessors lg = I.getPredecessors (unELMG lg)+{-# INLINE getPredecessors #-}++getInEdges :: (I.MBidirectional g, P.PrimMonad m, R.MonadRef m)+           => EdgeLabeledMGraph g el m -> I.Vertex -> m [I.Edge]+getInEdges lg = I.getInEdges (unELMG lg)+{-# INLINE getInEdges #-}++checkEdgeExists :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+                => EdgeLabeledMGraph g el m+                -> I.Vertex+                -> I.Vertex+                -> m Bool+checkEdgeExists lg = I.checkEdgeExists (unELMG lg)+{-# INLINE checkEdgeExists #-}++freeze :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+       => EdgeLabeledMGraph g el m+       -> m (EdgeLabeledGraph (I.ImmutableGraph g) el)+freeze lg = do+  g' <- I.freeze (unELMG lg)+  return $ ELG g'+{-# INLINE freeze #-}++instance (I.MGraph g) => I.MGraph (EdgeLabeledMGraph g el) where+  type ImmutableGraph (EdgeLabeledMGraph g el) =+    EdgeLabeledGraph (I.ImmutableGraph g) el+  getVertices = getVertices+  getSuccessors = getSuccessors+  getOutEdges = getOutEdges+  countVertices = countVertices+  countEdges = countEdges+  checkEdgeExists = checkEdgeExists+  freeze = freeze++instance (I.MBidirectional g) => I.MBidirectional (EdgeLabeledMGraph g el) where+  getPredecessors = getPredecessors+  getInEdges = getInEdges++instance (I.MAddVertex g) => I.MAddVertex (EdgeLabeledMGraph g el) where+  addVertex = addVertex++instance (I.MAddEdge g) => I.MLabeledEdge (EdgeLabeledMGraph g el) where+  type MEdgeLabel (EdgeLabeledMGraph g el) = el+  unsafeGetEdgeLabel = unsafeGetEdgeLabel+  addLabeledEdge = addLabeledEdge+

@@ -0,0 +1,395 @@+{-# LANGUAGE TypeFamilies, PatternGuards, RankNTypes #-}+-- | This internal module implements code shared between all of the+-- adapter interfaces.  The adapters add support for vertex and edge+-- labels without modifications to the underlying graph.  Any graph+-- implementing the 'MGraph' interface can have labels added with+-- these adapters.+--+-- Analogous adapters will be added for the pure graph interface, too.+module Data.Graph.Haggle.Internal.Adapter (+  -- * Types+  LabeledMGraph(..),+  LabeledGraph(..),+  -- * Mutable graph API+  newLabeledGraph,+  newSizedLabeledGraph,+  -- * Immutable graph API+  mapVertexLabel,+  mapEdgeLabel,+  fromLabeledEdgeList,+  -- * Helpers+  ensureEdgeLabelStorage,+  ensureNodeLabelStorage,+  unsafeGetEdgeLabel+  ) where++import qualified Control.DeepSeq as DS+import Control.Monad ( liftM )+import qualified Control.Monad.Primitive as P+import qualified Control.Monad.Ref as R+import Control.Monad.ST ( ST, runST )+import Data.Vector ( Vector )+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import qualified Data.Graph.Haggle.Classes as I+import qualified Data.Graph.Haggle.VertexMap as VM+import qualified Data.Graph.Haggle.Internal.Basic as I++-- | An adapter adding support for both vertex and edge labels for mutable+-- graphs.+data LabeledMGraph g nl el m =+  LMG { rawMGraph :: g m+      , nodeLabelStorage :: R.Ref m (MV.MVector (P.PrimState m) nl)+      , edgeLabelStorage :: R.Ref m (MV.MVector (P.PrimState m) el)+      }++-- | An adapter adding support for both vertex and edge labels for immutable+-- graphs.+data LabeledGraph g nl el =+  LG { rawGraph :: g+     , nodeLabelStore :: Vector nl+     , edgeLabelStore :: Vector el+     }++instance (DS.NFData g, DS.NFData nl, DS.NFData el) => DS.NFData (LabeledGraph g nl el) where+  rnf gr = rawGraph gr `DS.deepseq` nodeLabelStore gr `DS.deepseq` edgeLabelStore gr `DS.deepseq` ()++newLabeledGraph :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+                => m (g m)+                -> m (LabeledMGraph g nl el m)+newLabeledGraph newG = do+  g <- newG+  nstore <- MV.new 128+  nref <- R.newRef nstore+  estore <- MV.new 128+  eref <- R.newRef estore+  return LMG { rawMGraph = g+             , nodeLabelStorage = nref+             , edgeLabelStorage = eref+             }++newSizedLabeledGraph :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+                     => (Int -> Int -> m (g m))+                     -> Int+                     -> Int+                     -> m (LabeledMGraph g nl el m)+newSizedLabeledGraph newG szVertices szEdges = do+  g <- newG szVertices szEdges+  nstore <- MV.new szVertices+  nref <- R.newRef nstore+  estore <- MV.new szEdges+  eref <- R.newRef estore+  return LMG { rawMGraph = g+             , nodeLabelStorage = nref+             , edgeLabelStorage = eref+             }++addLabeledVertex :: (I.MGraph g, I.MAddVertex g, P.PrimMonad m, R.MonadRef m)+                 => LabeledMGraph g nl el m+                 -> nl+                 -> m I.Vertex+addLabeledVertex lg nl = do+  v <- I.addVertex (rawMGraph lg)+  ensureNodeLabelStorage lg+  nlVec <- R.readRef (nodeLabelStorage lg)+  MV.write nlVec (I.vertexId v) nl+  return v+--+-- getEdgeLabel :: (PrimMonad m, I.MGraph g)+--              => LabeledMGraph g nl el m+--              -> I.Edge+--              -> m (Maybe el)+-- getEdgeLabel lg e = do+--   nEs <- I.countEdges (rawMGraph lg)+--   case I.edgeId e >= nEs of+--     True -> return Nothing+--     False -> do+--       elVec <- readSTRef (edgeLabelStorage lg)+--       Just `liftM` MV.read elVec (I.edgeId e)++-- FIXME: Just implement this one and push the safe version to have the default+-- impl+unsafeGetEdgeLabel :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+                   => LabeledMGraph g nl el m+                   -> I.Edge+                   -> m el+unsafeGetEdgeLabel (LMG _ _ stor) (I.E eid _ _) = do+  elVec <- R.readRef stor+  MV.unsafeRead elVec eid+{-# INLINE unsafeGetEdgeLabel #-}++getVertexLabel :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+               => LabeledMGraph g nl el m+               -> I.Vertex+               -> m (Maybe nl)+getVertexLabel lg v = do+  nNs <- I.countVertices (rawMGraph lg)+  case I.vertexId v >= nNs of+    True -> return Nothing+    False -> do+      nlVec <- R.readRef (nodeLabelStorage lg)+      Just `liftM` MV.read nlVec (I.vertexId v)++addLabeledEdge :: (I.MGraph g, I.MAddEdge g, P.PrimMonad m, R.MonadRef m)+               => LabeledMGraph g nl el m+               -> I.Vertex+               -> I.Vertex+               -> el+               -> m (Maybe I.Edge)+addLabeledEdge lg src dst el = do+  e <- I.addEdge (rawMGraph lg) src dst+  case e of+    Nothing -> return e+    Just e' -> do+      ensureEdgeLabelStorage lg+      elVec <- R.readRef (edgeLabelStorage lg)+      MV.write elVec (I.edgeId e') el+      return e++getSuccessors :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+              => LabeledMGraph g nl el m+              -> I.Vertex+              -> m [I.Vertex]+getSuccessors lg = I.getSuccessors (rawMGraph lg)+{-# INLINE getSuccessors #-}++getOutEdges :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+            => LabeledMGraph g nl el m -> I.Vertex -> m [I.Edge]+getOutEdges lg = I.getOutEdges (rawMGraph lg)+{-# INLINE getOutEdges #-}++countVertices :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => LabeledMGraph g nl el m -> m Int+countVertices = I.countVertices . rawMGraph+{-# INLINE countVertices #-}++countEdges :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => LabeledMGraph g nl el m -> m Int+countEdges = I.countEdges . rawMGraph+{-# INLINE countEdges #-}++getVertices :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => LabeledMGraph g nl el m -> m [I.Vertex]+getVertices = I.getVertices . rawMGraph+{-# INLINE getVertices #-}++getPredecessors :: (I.MBidirectional g, P.PrimMonad m, R.MonadRef m)+                => LabeledMGraph g nl el m -> I.Vertex -> m [I.Vertex]+getPredecessors lg = I.getPredecessors (rawMGraph lg)+{-# INLINE getPredecessors #-}++getInEdges :: (I.MBidirectional g, P.PrimMonad m, R.MonadRef m)+           => LabeledMGraph g nl el m -> I.Vertex -> m [I.Edge]+getInEdges lg = I.getInEdges (rawMGraph lg)+{-# INLINE getInEdges #-}++checkEdgeExists :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+                => LabeledMGraph g nl el m+                -> I.Vertex+                -> I.Vertex+                -> m Bool+checkEdgeExists lg = I.checkEdgeExists (rawMGraph lg)+{-# INLINE checkEdgeExists #-}++freeze :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+       => LabeledMGraph g nl el m+       -> m (LabeledGraph (I.ImmutableGraph g) nl el)+freeze lg = do+  g' <- I.freeze (rawMGraph lg)+  nc <- I.countVertices (rawMGraph lg)+  ec <- I.countEdges (rawMGraph lg)+  ns <- R.readRef (nodeLabelStorage lg)+  es <- R.readRef (edgeLabelStorage lg)+  ns' <- V.freeze (MV.take nc ns)+  es' <- V.freeze (MV.take ec es)+  return LG { rawGraph = g'+            , nodeLabelStore = ns'+            , edgeLabelStore = es'+            }++instance (I.MGraph g) => I.MGraph (LabeledMGraph g nl el) where+  type ImmutableGraph (LabeledMGraph g nl el) = LabeledGraph (I.ImmutableGraph g) nl el+  getVertices = getVertices+  getSuccessors = getSuccessors+  getOutEdges = getOutEdges+  countEdges = countEdges+  countVertices = countVertices+  checkEdgeExists = checkEdgeExists+  freeze = freeze++instance (I.MBidirectional g) => I.MBidirectional (LabeledMGraph g nl el) where+  getPredecessors = getPredecessors+  getInEdges = getInEdges++instance (I.MAddEdge g) => I.MLabeledEdge (LabeledMGraph g nl el) where+  type MEdgeLabel (LabeledMGraph g nl el) = el+  -- getEdgeLabel = getEdgeLabel+  unsafeGetEdgeLabel = unsafeGetEdgeLabel+  addLabeledEdge = addLabeledEdge++instance (I.MAddVertex g) => I.MLabeledVertex (LabeledMGraph g nl el) where+  type MVertexLabel (LabeledMGraph g nl el) = nl+  getVertexLabel = getVertexLabel+  addLabeledVertex = addLabeledVertex++vertices :: (I.Graph g) => LabeledGraph g nl el -> [I.Vertex]+vertices = I.vertices . rawGraph+{-# INLINE vertices #-}++edges :: (I.Graph g) => LabeledGraph g nl el -> [I.Edge]+edges = I.edges . rawGraph+{-# INLINE edges #-}++successors :: (I.Graph g) => LabeledGraph g nl el -> I.Vertex -> [I.Vertex]+successors lg = I.successors (rawGraph lg)+{-# INLINE successors #-}++outEdges :: (I.Graph g) => LabeledGraph g nl el -> I.Vertex -> [I.Edge]+outEdges lg = I.outEdges (rawGraph lg)+{-# INLINE outEdges #-}++edgesBetween :: (I.Graph g) => LabeledGraph g nl el -> I.Vertex -> I.Vertex -> [I.Edge]+edgesBetween lg = I.edgesBetween (rawGraph lg)+{-# INLINE edgesBetween #-}++maxVertexId :: (I.Graph g) => LabeledGraph g nl el -> Int+maxVertexId = I.maxVertexId . rawGraph+{-# INLINE maxVertexId #-}++isEmpty :: (I.Graph g) => LabeledGraph g nl el -> Bool+isEmpty = I.isEmpty . rawGraph+{-# INLINE isEmpty #-}++thaw :: (I.Thawable g, P.PrimMonad m, R.MonadRef m)+     => LabeledGraph g nl el+     -> m (LabeledMGraph (I.MutableGraph g) nl el m)+thaw lg = do+  g' <- I.thaw (rawGraph lg)+  nlVec <- V.thaw (nodeLabelStore lg)+  elVec <- V.thaw (edgeLabelStore lg)+  nref <- R.newRef nlVec+  eref <- R.newRef elVec+  return LMG { rawMGraph = g'+             , nodeLabelStorage = nref+             , edgeLabelStorage = eref+             }++instance (I.Thawable g) => I.Thawable (LabeledGraph g nl el) where+  type MutableGraph (LabeledGraph g nl el) = LabeledMGraph (I.MutableGraph g) nl el+  thaw = thaw++instance (I.Graph g) => I.Graph (LabeledGraph g nl el) where+  vertices = vertices+  edges = edges+  successors = successors+  outEdges = outEdges+  edgesBetween = edgesBetween+  maxVertexId = maxVertexId+  isEmpty = isEmpty++predecessors :: (I.Bidirectional g) => LabeledGraph g nl el -> I.Vertex -> [I.Vertex]+predecessors lg = I.predecessors (rawGraph lg)+{-# INLINE predecessors #-}++inEdges :: (I.Bidirectional g) => LabeledGraph g nl el -> I.Vertex -> [I.Edge]+inEdges lg = I.inEdges (rawGraph lg)+{-# INLINE inEdges #-}++instance (I.Bidirectional g) => I.Bidirectional (LabeledGraph g nl el) where+  predecessors = predecessors+  inEdges = inEdges++instance (I.Bidirectional g) => I.BidirectionalEdgeLabel (LabeledGraph g nl el)++edgeLabel :: LabeledGraph g nl el -> I.Edge -> Maybe el+edgeLabel lg e = edgeLabelStore lg V.!? I.edgeId e+{-# INLINE edgeLabel #-}++instance (I.Graph g) => I.HasEdgeLabel (LabeledGraph g nl el) where+  type EdgeLabel (LabeledGraph g nl el) = el+  edgeLabel = edgeLabel+  labeledEdges = labeledEdges++vertexLabel :: LabeledGraph g nl el -> I.Vertex -> Maybe nl+vertexLabel lg v = nodeLabelStore lg V.!? I.vertexId v+{-# INLINE vertexLabel #-}++instance (I.Graph g) => I.HasVertexLabel (LabeledGraph g nl el) where+  type VertexLabel (LabeledGraph g nl el) = nl+  vertexLabel = vertexLabel+  labeledVertices = labeledVertices++-- | Note that we are not just using the @nodeLabelStore@ directly.  In+-- graphs that support vertex removal, we do not want to include removed+-- vertices, so we go through the public accessor.  This is slower but easier+-- to see as correct.+labeledVertices :: (I.Graph g) => LabeledGraph g nl el -> [(I.Vertex, nl)]+labeledVertices g = map toLabVert $ I.vertices (rawGraph g)+  where+    toLabVert v =+      let Just lab = vertexLabel g v+      in (v, lab)++-- | Likewise, we use 'edges' here instead of directly reading from the edge+-- label storage array.+labeledEdges :: (I.Graph g) => LabeledGraph g nl el -> [(I.Edge, el)]+labeledEdges g = map toLabEdge $ I.edges (rawGraph g)+  where+    toLabEdge e =+      let Just lab = edgeLabel g e+      in (e, lab)++mapEdgeLabel :: LabeledGraph g nl el -> (el -> el') -> LabeledGraph g nl el'+mapEdgeLabel g f = g { edgeLabelStore = V.map f (edgeLabelStore g) }++mapVertexLabel :: LabeledGraph g nl el -> (nl -> nl') -> LabeledGraph g nl' el+mapVertexLabel g f = g { nodeLabelStore = V.map f (nodeLabelStore g) }++-- | Construct a graph from a labeled list of edges.  The node endpoint values+-- are used as vertex labels, and the last element of the triple is used as an+-- edge label.+fromLabeledEdgeList :: (Ord nl, I.MGraph g, I.MAddVertex g, I.MAddEdge g)+                    => (forall s . ST s (g (ST s)))+                    -> [(nl, nl, el)]+                    -> (LabeledGraph (I.ImmutableGraph g) nl el, VM.VertexMap nl)+fromLabeledEdgeList con es = runST $ do+  g <- newLabeledGraph con+  vm <- VM.newVertexMapRef+  mapM_ (fromListAddEdge g vm) es+  g' <- I.freeze g+  vm' <- VM.vertexMapFromRef vm+  return (g', vm')++fromListAddEdge :: (I.MAddVertex g, I.MAddEdge g, Ord nl, P.PrimMonad m, R.MonadRef m)+                => LabeledMGraph g nl el m+                -> VM.VertexMapRef nl m+                -> (nl, nl, el)+                -> m ()+fromListAddEdge g vm (src, dst, lbl) = do+  vsrc <- VM.vertexForLabelRef g vm src+  vdst <- VM.vertexForLabelRef g vm dst+  _ <- addLabeledEdge g vsrc vdst lbl+  return ()++-- Helpers++ensureEdgeLabelStorage :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+                       => LabeledMGraph g nl el m -> m ()+ensureEdgeLabelStorage lg = do+  elVec <- R.readRef (edgeLabelStorage lg)+  edgeCount <- I.countEdges (rawMGraph lg)+  let cap = MV.length elVec+  case cap > edgeCount of+    True -> return ()+    False -> do+      elVec' <- MV.grow elVec cap+      R.writeRef (edgeLabelStorage lg) elVec'++ensureNodeLabelStorage :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+                       => LabeledMGraph g nl el m -> m ()+ensureNodeLabelStorage lg = do+  nlVec <- R.readRef (nodeLabelStorage lg)+  vertCount <- I.countVertices (rawMGraph lg)+  let cap = MV.length nlVec+  case cap > vertCount of+    True -> return ()+    False -> do+      nlVec' <- MV.grow nlVec cap+      R.writeRef (nodeLabelStorage lg) nlVec'

@@ -0,0 +1,74 @@+-- | This module defines the most basic types in the library.  Their+-- representations are required in several modules, but external+-- clients should probably not rely on them.+--+-- Stability not guaranteed.+module Data.Graph.Haggle.Internal.Basic (+  Vertex(..),+  Edge(..),+  vertexId,+  edgeId,+  edgeSource,+  edgeDest+  ) where++import Control.DeepSeq+import Data.Hashable++-- | An abstract representation of a vertex.+--+-- Note that the representation is currently exposed.  Do not rely on+-- this, as it is subject to change.+newtype Vertex = V Int+  deriving (Eq, Ord, Show)++instance Hashable Vertex where+  hashWithSalt = hashVertex++instance NFData Vertex where+  rnf (V i) = i `seq` ()++hashVertex :: Int -> Vertex -> Int+hashVertex s (V i) = hashWithSalt s i+{-# INLINE hashVertex #-}++-- | An edge between two vertices.+data Edge = E {-# UNPACK #-}!Int {-# UNPACK #-}!Int {-# UNPACK #-}!Int+  deriving (Eq, Ord, Show)++instance Hashable Edge where+  hashWithSalt = hashEdge++instance NFData Edge where+  rnf e = e `seq` ()++hashEdge :: Int -> Edge -> Int+hashEdge s (E eid src dst) = s `hashWithSalt` eid `hashWithSalt` src `hashWithSalt` dst+{-# INLINE hashEdge #-}++vertexId :: Vertex -> Int+vertexId (V vid) = vid+{-# INLINE vertexId #-}++edgeId :: Edge -> Int+edgeId (E eid _ _) = eid+{-# INLINE edgeId #-}++edgeSource :: Edge -> Vertex+edgeSource (E _ s _) = V s+{-# INLINE edgeSource #-}++edgeDest :: Edge -> Vertex+edgeDest (E _ _ d) = V d+{-# INLINE edgeDest #-}+++{- Note [Edge Format]++Edges track (in order)++1) The edge unique identifier+2) The edge source+3) The edge destination++-}

@@ -0,0 +1,49 @@+module Data.Graph.Haggle.Internal.BitSet (+  BitSet,+  newBitSet,+  setBit,+  testBit+  ) where++import Control.Monad.ST+import qualified Data.Bits as B+import Data.Vector.Unboxed.Mutable ( STVector )+import qualified Data.Vector.Unboxed.Mutable as V+import Data.Word ( Word64 )++data BitSet s = BS (STVector s Word64) {-# UNPACK #-} !Int++bitsPerWord :: Int+bitsPerWord = 64++-- | Allocate a new 'BitSet' with @n@ bits.  Bits are all+-- initialized to zero.+--+-- > bs <- newBitSet n+newBitSet :: Int -> ST s (BitSet s)+newBitSet n = do+  let nWords = (n `div` bitsPerWord) + 1+  v <- V.replicate nWords 0+  return $ BS v n++-- | Set a bit in the bitset.  Out of range has no effect.+setBit :: BitSet s -> Int -> ST s ()+setBit (BS v sz) bitIx+  | bitIx >= sz = return ()+  | otherwise = do+    let wordIx = bitIx `div` bitsPerWord+        bitPos = bitIx `mod` bitsPerWord+    oldWord <- V.read v wordIx+    let newWord = B.setBit oldWord bitPos+    V.write v wordIx newWord++-- | Return True if the bit is set.  Out of range will return False.+testBit :: BitSet s -> Int -> ST s Bool+testBit (BS v sz) bitIx+  | bitIx >= sz = return False+  | otherwise = do+    let wordIx = bitIx `div` bitsPerWord+        bitPos = bitIx `mod` bitsPerWord+    w <- V.read v wordIx+    return $ B.testBit w bitPos+

@@ -0,0 +1,14 @@+module Data.Graph.Haggle.LabelAdapter (+  -- * Types+  LabeledMGraph,+  LabeledGraph,+  -- * Mutable Graph API+  newLabeledGraph,+  newSizedLabeledGraph,+  -- * Immutable Graph API+  mapEdgeLabel,+  mapVertexLabel,+  fromLabeledEdgeList,+  ) where++import Data.Graph.Haggle.Internal.Adapter

@@ -0,0 +1,165 @@+{-# LANGUAGE TypeFamilies, BangPatterns #-}+-- | This graph is based on the implementation in fgl (using+-- big-endian patricia-tries -- IntMap).+--+-- This formulation does not support parallel edges.+module Data.Graph.Haggle.PatriciaTree ( PatriciaTree ) where++import Control.DeepSeq+import Control.Monad ( guard )+import Data.Foldable ( toList )+import Data.IntMap ( IntMap )+import qualified Data.IntMap as IM+import Data.Maybe ( fromMaybe )+import Data.Monoid++import           Prelude++import qualified Data.Graph.Haggle.Classes as I+import qualified Data.Graph.Haggle.Internal.Basic as I++data Ctx nl el = Ctx !(IntMap el) I.Vertex nl !(IntMap el)++instance (NFData nl, NFData el) => NFData (Ctx nl el) where+  rnf (Ctx p v nl s) =+    p `deepseq` s `deepseq` nl `deepseq` v `seq` ()++-- | The 'PatriciaTree' is a graph implementing the 'I.InductiveGraph'+-- interface (as well as the other immutable graph interfaces).  It is+-- based on the graph type provided by fgl.+--+-- Inductive graphs support more interesting decompositions than the+-- other graph interfaces in this library, at the cost of less compact+-- representations and some additional overhead on some operations, as+-- most must go through the 'I.match' operator.+--+-- This graph type is most useful for incremental construction in pure+-- code.  It also supports node removal from pure code.+data PatriciaTree nl el = Gr { graphRepr :: IntMap (Ctx nl el) }++instance (NFData nl, NFData el) => NFData (PatriciaTree nl el) where+  rnf (Gr im) = im `deepseq` ()++instance I.Graph (PatriciaTree nl el) where+  vertices = map I.V . IM.keys . graphRepr+  isEmpty = IM.null . graphRepr+  maxVertexId (Gr g)+    | IM.null g = 0+    | otherwise = fst $ IM.findMax g+  edgesBetween (Gr g) (I.V src) (I.V dst) = toList $ do+    Ctx _ _ _ ss <- IM.lookup src g+    guard (IM.member dst ss)+    return (I.E (-1) src dst)+  edges g = concatMap (I.outEdges g) (I.vertices g)+  successors (Gr g) (I.V v) = fromMaybe [] $ do+    Ctx _ _ _ ss <- IM.lookup v g+    return $ map I.V $ IM.keys ss+  outEdges (Gr g) (I.V v) = fromMaybe [] $ do+    Ctx _ _ _ ss <- IM.lookup v g+    return $ map toEdge (IM.keys ss)+    where+      toEdge d = I.E (-1) v d++instance I.HasEdgeLabel (PatriciaTree nl el) where+  type EdgeLabel (PatriciaTree nl el) = el+  edgeLabel (Gr g) (I.E _ src dst) = do+    Ctx _ _ _ ss <- IM.lookup src g+    IM.lookup dst ss+  labeledEdges gr = map toLabEdge (I.edges gr)+    where+      toLabEdge e =+        let Just lab = I.edgeLabel gr e+        in (e, lab)+  labeledOutEdges (Gr g) (I.V s) = fromMaybe [] $ do+    Ctx _ _ _ ss <- IM.lookup s g+    return $ IM.foldrWithKey toOut [] ss+    where+      toOut d lbl acc = (I.E (-1) s d, lbl) : acc++instance I.HasVertexLabel (PatriciaTree nl el) where+  type VertexLabel (PatriciaTree nl el) = nl+  vertexLabel (Gr g) (I.V v) = do+    Ctx _ _ lbl _ <- IM.lookup v g+    return lbl+  labeledVertices gr = map toLabVert (I.vertices gr)+    where+      toLabVert v =+        let Just l = I.vertexLabel gr v+        in (v, l)++instance I.Bidirectional (PatriciaTree nl el) where+  predecessors (Gr g) (I.V v) = fromMaybe [] $ do+    Ctx pp _ _ _ <- IM.lookup v g+    return $ map I.V (IM.keys pp)+  inEdges (Gr g) (I.V v) = fromMaybe [] $ do+    Ctx pp _ _ _ <- IM.lookup v g+    return $ map toEdge (IM.keys pp)+    where+      toEdge s = I.E (-1) s v++instance I.BidirectionalEdgeLabel (PatriciaTree nl el) where+  labeledInEdges (Gr g) (I.V d) = fromMaybe [] $ do+    Ctx pp _ _ _ <- IM.lookup d g+    return $ IM.foldrWithKey toIn [] pp+    where+      toIn s lbl acc = (I.E (-1) s d, lbl) : acc++instance I.InductiveGraph (PatriciaTree nl el) where+  emptyGraph = Gr IM.empty+  insertLabeledVertex gr@(Gr g) lab =+    let vid = I.maxVertexId gr + 1+        v = I.V vid+        g' = IM.insert vid (Ctx mempty v lab mempty) g+    in (v, Gr g')+  insertLabeledEdge gr@(Gr g) v1@(I.V src) v2@(I.V dst) lab = do+    guard (IM.member src g && IM.member dst g)+    guard (not (I.edgeExists gr v1 v2))+    let e = I.E (-1) src dst+    Ctx spp sv sl sss <- IM.lookup src g+    Ctx dpp dv dl dss <- IM.lookup dst g+    let sctx' = Ctx spp sv sl (IM.insert dst lab sss)+        dctx' = Ctx (IM.insert src lab dpp) dv dl dss+        !g' = IM.insert src sctx' g+        !g'' = IM.insert dst dctx' g'+    return (e, Gr g'')+  deleteEdge g (I.E _ s d) = I.deleteEdgesBetween g (I.V s) (I.V d)+  deleteEdgesBetween gr@(Gr g) (I.V src) (I.V dst) = fromMaybe gr $ do+    Ctx spp sv sl sss <- IM.lookup src g+    Ctx dpp dv dl dss <- IM.lookup dst g+    let sctx' = Ctx spp sv sl (IM.delete dst sss)+        dctx' = Ctx (IM.delete src dpp) dv dl dss+        !g' = IM.insert src sctx' g+        !g'' = IM.insert dst dctx' g'+    return (Gr g'')+  context (Gr g) (I.V v) = do+    Ctx pp _ l ss <- IM.lookup v g+    return $ I.Context (toAdj pp) l (toAdj ss)+  match (Gr g) (I.V v) = do+    Ctx pp _ l ss <- IM.lookup v g+    let g' = foldr (IM.adjust (removeSucc v)) g (IM.keys pp)+        g'' = foldr (IM.adjust (removePred v)) g' (IM.keys ss)+        g''' = IM.delete v g''+    return $ (I.Context (toAdj pp) l (toAdj ss), Gr g''')++toAdj :: IntMap a -> [(a, I.Vertex)]+toAdj = IM.foldrWithKey f []+  where+    f dst lbl acc = (lbl, I.V dst) : acc++removeSucc :: Int -> Ctx nl el -> Ctx nl el+removeSucc v (Ctx pp vert lbl ss) =+  Ctx pp vert lbl (IM.delete v ss)++removePred :: Int -> Ctx nl el -> Ctx nl el+removePred v (Ctx pp vert lbl ss) =+  Ctx (IM.delete v pp) vert lbl ss++{- Note [Representation]++Since this graph does not support parallel edges, the edge ID does not+actually matter.  This implementation will let it always be zero.  Edge+identity can be recovered with just (src, dst).++-}++

@@ -0,0 +1,239 @@+{-# LANGUAGE TypeFamilies #-}+-- | This is a simple graph (it does not allow parallel edges).  To support+-- this efficiently, it is less compact than 'Digraph' or 'BiDigraph'.  As+-- a consequence, edge existence tests are efficient (logarithmic in the+-- number of edges leaving the source vertex).+module Data.Graph.Haggle.SimpleBiDigraph (+  MSimpleBiDigraph,+  SimpleBiDigraph,+  newMSimpleBiDigraph,+  newSizedMSimpleBiDigraph+  ) where++import qualified Control.DeepSeq as DS+import Control.Monad ( when )+import qualified Control.Monad.Primitive as P+import qualified Control.Monad.Ref as R+import Data.Foldable ( toList )+import Data.IntMap ( IntMap )+import qualified Data.IntMap as IM+import qualified Data.Vector.Mutable as MV+import qualified Data.Vector as V++import Data.Graph.Haggle.Classes+import Data.Graph.Haggle.Internal.Basic++data MSimpleBiDigraph m = -- See Note [Graph Representation]+  MBiDigraph { mgraphVertexCount :: R.Ref m Int+             , mgraphEdgeCount :: R.Ref m Int+             , mgraphPreds :: R.Ref m (MV.MVector (P.PrimState m) (IntMap Edge))+             , mgraphSuccs :: R.Ref m (MV.MVector (P.PrimState m) (IntMap Edge))+             }++data SimpleBiDigraph =+  BiDigraph { vertexCount :: {-# UNPACK #-} !Int+            , edgeCount :: {-# UNPACK #-} !Int+            , graphPreds :: V.Vector (IntMap Edge)+            , graphSuccs :: V.Vector (IntMap Edge)+            }++instance DS.NFData SimpleBiDigraph where+  rnf bdg = graphPreds bdg `DS.deepseq` graphSuccs bdg `DS.deepseq` ()++defaultSize :: Int+defaultSize = 128++newMSimpleBiDigraph :: (P.PrimMonad m, R.MonadRef m) => m (MSimpleBiDigraph m)+newMSimpleBiDigraph = newSizedMSimpleBiDigraph defaultSize 0++newSizedMSimpleBiDigraph :: (P.PrimMonad m, R.MonadRef m) => Int -> Int -> m (MSimpleBiDigraph m)+newSizedMSimpleBiDigraph szNodes _ = do+  when (szNodes < 0) $ error "Negative size (newSized)"+  nn <- R.newRef 0+  en <- R.newRef 0+  pvec <- MV.new szNodes+  svec <- MV.new szNodes+  pref <- R.newRef pvec+  sref <- R.newRef svec+  return $! MBiDigraph { mgraphVertexCount = nn+                       , mgraphEdgeCount = en+                       , mgraphPreds = pref+                       , mgraphSuccs = sref+                       }++instance MGraph MSimpleBiDigraph where+  type ImmutableGraph MSimpleBiDigraph = SimpleBiDigraph+  getVertices g = do+    nVerts <- R.readRef (mgraphVertexCount g)+    return [V v | v <- [0..nVerts - 1]]++  getOutEdges g (V src) = do+    nVerts <- R.readRef (mgraphVertexCount g)+    case src >= nVerts of+      True -> return []+      False -> do+        svec <- R.readRef (mgraphSuccs g)+        succs <- MV.unsafeRead svec src+        return $ IM.elems succs++  countVertices = R.readRef . mgraphVertexCount+  countEdges = R.readRef . mgraphEdgeCount++  getSuccessors g (V src) = do+    nVerts <- R.readRef (mgraphVertexCount g)+    case src >= nVerts of+      True -> return []+      False -> do+        svec <- R.readRef (mgraphSuccs g)+        succs <- MV.unsafeRead svec src+        return $ map V $ IM.keys succs++  checkEdgeExists g (V src) (V dst) = do+    nVerts <- R.readRef (mgraphVertexCount g)+    case src >= nVerts || dst >= nVerts of+      True -> return False+      False -> do+        svec <- R.readRef (mgraphSuccs g)+        succs <- MV.unsafeRead svec src+        return $ IM.member dst succs++  freeze g = do+    nVerts <- R.readRef (mgraphVertexCount g)+    nEdges <- R.readRef (mgraphEdgeCount g)+    pvec <- R.readRef (mgraphPreds g)+    svec <- R.readRef (mgraphSuccs g)+    pvec' <- V.freeze (MV.take nVerts pvec)+    svec' <- V.freeze (MV.take nVerts svec)+    return $! BiDigraph { vertexCount = nVerts+                        , edgeCount = nEdges+                        , graphPreds = pvec'+                        , graphSuccs = svec'+                        }++instance MAddVertex MSimpleBiDigraph where+  addVertex g = do+    ensureNodeSpace g+    vid <- R.readRef r+    R.modifyRef' r (+1)+    pvec <- R.readRef (mgraphPreds g)+    svec <- R.readRef (mgraphSuccs g)+    MV.write pvec vid IM.empty+    MV.write svec vid IM.empty+    return (V vid)+    where+      r = mgraphVertexCount g++instance MAddEdge MSimpleBiDigraph where+  addEdge g v1@(V src) v2@(V dst) = do+    nVerts <- R.readRef (mgraphVertexCount g)+    exists <- checkEdgeExists g v1 v2+    case exists || src >= nVerts || dst >= nVerts of+      True -> return Nothing+      False -> do+        eid <- R.readRef (mgraphEdgeCount g)+        let e = E eid src dst+        R.modifyRef' (mgraphEdgeCount g) (+1)++        pvec <- R.readRef (mgraphPreds g)+        preds <- MV.unsafeRead pvec dst+        MV.unsafeWrite pvec dst (IM.insert src e preds)++        svec <- R.readRef (mgraphSuccs g)+        succs <- MV.unsafeRead svec src+        MV.unsafeWrite svec src (IM.insert dst e succs)++        return $ Just e++instance MBidirectional MSimpleBiDigraph where+  getPredecessors g (V vid) = do+    nVerts <- R.readRef (mgraphVertexCount g)+    case vid < nVerts of+      False -> return []+      True -> do+        pvec <- R.readRef (mgraphPreds g)+        preds <- MV.unsafeRead pvec vid+        return $ map V $ IM.keys preds++  getInEdges g (V vid) = do+    nVerts <- R.readRef (mgraphVertexCount g)+    case vid < nVerts of+      False -> return []+      True -> do+        pvec <- R.readRef (mgraphPreds g)+        preds <- MV.unsafeRead pvec vid+        return $ IM.elems preds++instance Thawable SimpleBiDigraph where+  type MutableGraph SimpleBiDigraph = MSimpleBiDigraph+  thaw g = do+    vc <- R.newRef (vertexCount g)+    ec <- R.newRef (edgeCount g)+    pvec <- V.thaw (graphPreds g)+    svec <- V.thaw (graphSuccs g)+    pref <- R.newRef pvec+    sref <- R.newRef svec+    return MBiDigraph { mgraphVertexCount = vc+                      , mgraphEdgeCount = ec+                      , mgraphPreds = pref+                      , mgraphSuccs = sref+                      }++instance Graph SimpleBiDigraph where+  -- FIXME: This will be more complicated if we support removing vertices+  vertices g = map V [0 .. vertexCount g - 1]+  edges g = concatMap (outEdges g) (vertices g)+  successors g (V v)+    | outOfRange g v = []+    | otherwise = map V $ IM.keys $ V.unsafeIndex (graphSuccs g) v+  outEdges g (V v)+    | outOfRange g v = []+    | otherwise =+      let succs = V.unsafeIndex (graphSuccs g) v+      in IM.elems succs+  edgesBetween g (V src) (V dst)+    | outOfRange g src || outOfRange g dst = []+    | otherwise = toList $ IM.lookup dst (V.unsafeIndex (graphSuccs g) src)+  maxVertexId g = V.length (graphSuccs g) - 1+  isEmpty = (==0) . vertexCount+++instance Bidirectional SimpleBiDigraph  where+  predecessors g (V v)+    | outOfRange g v = []+    | otherwise = map V $ IM.keys $ V.unsafeIndex (graphPreds g) v+  inEdges g (V v)+    | outOfRange g v = []+    | otherwise =+      let preds = V.unsafeIndex (graphPreds g) v+      in IM.elems preds++-- Helpers++outOfRange :: SimpleBiDigraph -> Int -> Bool+outOfRange g = (>= vertexCount g)++-- | Given a graph, ensure that there is space in the vertex vector+-- for a new vertex.  If there is not, double the capacity.+ensureNodeSpace :: (P.PrimMonad m, R.MonadRef m) => MSimpleBiDigraph m -> m ()+ensureNodeSpace g = do+  pvec <- R.readRef (mgraphPreds g)+  svec <- R.readRef (mgraphSuccs g)+  let cap = MV.length pvec+  cnt <- R.readRef (mgraphVertexCount g)+  case cnt < cap of+    True -> return ()+    False -> do+      pvec' <- MV.grow pvec cap+      svec' <- MV.grow svec cap+      R.writeRef (mgraphPreds g) pvec'+      R.writeRef (mgraphSuccs g) svec'+++{- Note [Graph Representation]++Each of the IntMaps in the vectors maps the edge *destination* node id to the+*edge id*.  We need to store the edge IDs to reconstruct an Edge.  Other graph+representations use the edge IDs to maintain lists, but here we don't have+that.  The destination is the key of the map for fast edgeExists tests.++-}

@@ -0,0 +1,262 @@+{-# LANGUAGE TypeFamilies, PatternGuards, RankNTypes #-}+-- | An adapter to create graphs with labeled vertices and unlabeled edges.+--+-- See 'LabeledGraph' for an overview.  The only significant difference+-- is that this graph only supports adding unlabeled edges, and thus you+-- must use 'addEdge' instead of 'addLabeledEdge'.+module Data.Graph.Haggle.VertexLabelAdapter (+  VertexLabeledMGraph,+  VertexLabeledGraph,+  -- * Mutable Graph API+  newVertexLabeledGraph,+  newSizedVertexLabeledGraph,+  -- * Immutable Graph API+  mapVertexLabel,+  fromEdgeList+  ) where++import qualified Control.DeepSeq as DS+import qualified Control.Monad.Primitive as P+import qualified Control.Monad.Ref as R+import Control.Monad.ST ( ST, runST )++import qualified Data.Graph.Haggle.Classes as I+import qualified Data.Graph.Haggle.VertexMap as VM+import qualified Data.Graph.Haggle.Internal.Adapter as A++newtype VertexLabeledMGraph g nl m = VLMG { unVLMG :: A.LabeledMGraph g nl () m }+newtype VertexLabeledGraph g nl = VLG { unVLG :: A.LabeledGraph g nl () }++instance (DS.NFData g, DS.NFData nl) => DS.NFData (VertexLabeledGraph g nl) where+  rnf (VLG g) = g `DS.deepseq` ()++mapVertexLabel :: VertexLabeledGraph g nl -> (nl -> nl') -> VertexLabeledGraph g nl'+mapVertexLabel g = VLG . A.mapVertexLabel (unVLG g)+{-# INLINE mapVertexLabel #-}++vertices :: (I.Graph g) => VertexLabeledGraph g nl -> [I.Vertex]+vertices = I.vertices . unVLG+{-# INLINE vertices #-}++edges :: (I.Graph g) => VertexLabeledGraph g nl -> [I.Edge]+edges = I.edges . unVLG+{-# INLINE edges #-}++successors :: (I.Graph g) => VertexLabeledGraph g nl -> I.Vertex -> [I.Vertex]+successors (VLG lg) = I.successors lg+{-# INLINE successors #-}++outEdges :: (I.Graph g) => VertexLabeledGraph g nl -> I.Vertex -> [I.Edge]+outEdges (VLG lg) = I.outEdges lg+{-# INLINE outEdges #-}++edgesBetween :: (I.Graph g) => VertexLabeledGraph g nl -> I.Vertex -> I.Vertex -> [I.Edge]+edgesBetween (VLG lg) = I.edgesBetween lg+{-# INLINE edgesBetween #-}++maxVertexId :: (I.Graph g) => VertexLabeledGraph g nl -> Int+maxVertexId = I.maxVertexId . unVLG+{-# INLINE maxVertexId #-}++isEmpty :: (I.Graph g) => VertexLabeledGraph g nl -> Bool+isEmpty = I.isEmpty . unVLG+{-# INLINE isEmpty #-}++instance (I.Graph g) => I.Graph (VertexLabeledGraph g nl) where+  vertices = vertices+  edges = edges+  successors = successors+  outEdges = outEdges+  edgesBetween = edgesBetween+  maxVertexId = maxVertexId+  isEmpty = isEmpty++instance (I.Thawable g) => I.Thawable (VertexLabeledGraph g nl) where+  type MutableGraph (VertexLabeledGraph g nl) =+    VertexLabeledMGraph (I.MutableGraph g) nl+  thaw (VLG lg) = do+    g' <- I.thaw lg+    return $ VLMG g'+++predecessors :: (I.Bidirectional g) => VertexLabeledGraph g nl -> I.Vertex -> [I.Vertex]+predecessors (VLG lg) = I.predecessors lg+{-# INLINE predecessors #-}++inEdges :: (I.Bidirectional g) => VertexLabeledGraph g nl -> I.Vertex -> [I.Edge]+inEdges (VLG lg) = I.inEdges lg+{-# INLINE inEdges #-}++instance (I.Bidirectional g) => I.Bidirectional (VertexLabeledGraph g nl) where+  predecessors = predecessors+  inEdges = inEdges++vertexLabel :: (I.Graph g) => VertexLabeledGraph g nl -> I.Vertex -> Maybe nl+vertexLabel (VLG g) = I.vertexLabel g+{-# INLINE vertexLabel #-}++instance (I.Graph g) => I.HasVertexLabel (VertexLabeledGraph g nl) where+  type VertexLabel (VertexLabeledGraph g nl) = nl+  vertexLabel = vertexLabel+  labeledVertices = labeledVertices++labeledVertices :: (I.Graph g) => VertexLabeledGraph g nl -> [(I.Vertex, nl)]+labeledVertices = I.labeledVertices . unVLG+{-# INLINE labeledVertices #-}++newVertexLabeledGraph :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+                      => m (g m)+                      -> m (VertexLabeledMGraph g nl m)+newVertexLabeledGraph newG = do+  g <- A.newLabeledGraph newG+  return $ VLMG g+{-# INLINE newVertexLabeledGraph #-}++newSizedVertexLabeledGraph :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+                           => (Int -> Int -> m (g m))+                           -> Int+                           -> Int+                           -> m (VertexLabeledMGraph g nl m)+newSizedVertexLabeledGraph newG szV szE = do+  g <- A.newSizedLabeledGraph newG szV szE+  return $ VLMG g+{-# INLINE newSizedVertexLabeledGraph #-}++addEdge :: (I.MGraph g, I.MAddEdge g, P.PrimMonad m, R.MonadRef m)+        => VertexLabeledMGraph g nl m+        -> I.Vertex+        -> I.Vertex+        -> m (Maybe I.Edge)+addEdge lg = I.addEdge (A.rawMGraph (unVLMG lg))+{-# INLINE addEdge #-}++addLabeledVertex :: (I.MGraph g, I.MAddVertex g, P.PrimMonad m, R.MonadRef m)+                 => VertexLabeledMGraph g nl m+                 -> nl+                 -> m I.Vertex+addLabeledVertex lg = I.addLabeledVertex (unVLMG lg)+{-# INLINE addLabeledVertex #-}++getVertexLabel :: (I.MGraph g, I.MAddVertex g, P.PrimMonad m, R.MonadRef m)+               => VertexLabeledMGraph g nl m+               -> I.Vertex+               -> m (Maybe nl)+getVertexLabel lg = I.getVertexLabel (unVLMG lg)+{-# INLINE getVertexLabel #-}++getSuccessors :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+              => VertexLabeledMGraph g nl m+              -> I.Vertex+              -> m [I.Vertex]+getSuccessors lg = I.getSuccessors (unVLMG lg)+{-# INLINE getSuccessors #-}++getOutEdges :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+            => VertexLabeledMGraph g nl m -> I.Vertex -> m [I.Edge]+getOutEdges lg = I.getOutEdges (unVLMG lg)+{-# INLINE getOutEdges #-}++countVertices :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => VertexLabeledMGraph g nl m -> m Int+countVertices = I.countVertices . unVLMG+{-# INLINE countVertices #-}++getVertices :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => VertexLabeledMGraph g nl m -> m [I.Vertex]+getVertices = I.getVertices . unVLMG+{-# INLINE getVertices #-}++countEdges :: (I.MGraph g, P.PrimMonad m, R.MonadRef m) => VertexLabeledMGraph g nl m -> m Int+countEdges = I.countEdges . unVLMG+{-# INLINE countEdges #-}++getPredecessors :: (I.MBidirectional g, P.PrimMonad m, R.MonadRef m)+                => VertexLabeledMGraph g nl m -> I.Vertex -> m [I.Vertex]+getPredecessors lg = I.getPredecessors (unVLMG lg)+{-# INLINE getPredecessors #-}++getInEdges :: (I.MBidirectional g, P.PrimMonad m, R.MonadRef m)+           => VertexLabeledMGraph g nl m -> I.Vertex -> m [I.Edge]+getInEdges lg = I.getInEdges (unVLMG lg)+{-# INLINE getInEdges #-}++checkEdgeExists :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+                => VertexLabeledMGraph g nl m+                -> I.Vertex+                -> I.Vertex+                -> m Bool+checkEdgeExists lg = I.checkEdgeExists (unVLMG lg)+{-# INLINE checkEdgeExists #-}++freeze :: (I.MGraph g, P.PrimMonad m, R.MonadRef m)+       => VertexLabeledMGraph g nl m+       -> m (VertexLabeledGraph (I.ImmutableGraph g) nl)+freeze lg = do+  g' <- I.freeze (unVLMG lg)+  return $ VLG g'+{-# INLINE freeze #-}++instance (I.MGraph g) => I.MGraph (VertexLabeledMGraph g nl) where+  type ImmutableGraph (VertexLabeledMGraph g nl) =+    VertexLabeledGraph (I.ImmutableGraph g) nl+  getVertices = getVertices+  getSuccessors = getSuccessors+  getOutEdges = getOutEdges+  countVertices = countVertices+  countEdges = countEdges+  checkEdgeExists = checkEdgeExists+  freeze = freeze++instance (I.MAddVertex g) => I.MLabeledVertex (VertexLabeledMGraph g nl) where+  type MVertexLabel (VertexLabeledMGraph g nl) = nl+  getVertexLabel = getVertexLabel+  addLabeledVertex = addLabeledVertex++instance (I.MBidirectional g) => I.MBidirectional (VertexLabeledMGraph g nl) where+  getPredecessors = getPredecessors+  getInEdges = getInEdges++instance (I.MAddEdge g) => I.MAddEdge (VertexLabeledMGraph g nl) where+  addEdge = addEdge++-- | Build a new (immutable) graph from a list of edges.  Edges are defined+-- by pairs of /node labels/.  A new 'Vertex' will be allocated for each+-- node label.+--+-- The type of the constructed graph is controlled by the first argument,+-- which is a constructor for a mutable graph.+--+-- Example:+--+-- > import Data.Graph.Haggle.VertexLabelAdapter+-- > import Data.Graph.Haggle.SimpleBiDigraph+-- >+-- > let g = fromEdgeList newMSimpleBiDigraph [(0,1), (1,2), (2,3), (3,0)]+--+-- @g@ has type SimpleBiDigraph.+--+-- An alternative that is fully polymorphic in the return type would be+-- possible, but it would require type annotations on the result of+-- 'fromEdgeList', which could be very annoying.+fromEdgeList :: (I.MGraph g, I.MAddEdge g, I.MAddVertex g, Ord nl)+             => (forall s . ST s (g (ST s)))+             -> [(nl, nl)]+             -> (VertexLabeledGraph (I.ImmutableGraph g) nl, VM.VertexMap nl)+fromEdgeList con es = runST $ do+  g <- newVertexLabeledGraph con+  vm <- VM.newVertexMapRef+  mapM_ (fromListAddEdge g vm) es+  g' <- I.freeze g+  vm' <- VM.vertexMapFromRef vm+  return (g', vm')++fromListAddEdge :: (I.MAddVertex g, I.MAddEdge g, Ord nl, P.PrimMonad m, R.MonadRef m)+                => VertexLabeledMGraph g nl m+                -> VM.VertexMapRef nl m+                -> (nl, nl)+                -> m ()+fromListAddEdge g vm (src, dst) = do+  vsrc <- VM.vertexForLabelRef g vm src+  vdst <- VM.vertexForLabelRef g vm dst+  _ <- addEdge g vsrc vdst+  return ()++

@@ -0,0 +1,99 @@+{-# LANGUAGE PatternGuards, FlexibleContexts #-}+-- | This is a simple module to handle a common pattern: constructing graphs+-- where vertex labels map uniquely to vertices.+--+-- The primary functions in this module are 'vertexForLabel' and+-- 'vertexForLabelRef', which take a vertex label and return the 'Vertex' for+-- that label (allocating a new 'Vertex') if necessary.  The first of those+-- functions explicitly threads the mapping as inputs and outputs.  The second+-- manages a mutable ref side-by-side with the underlying graph.+--+-- After the graph is fully constructed, this mapping is often still useful.+module Data.Graph.Haggle.VertexMap (+  -- * Pure interface+  VertexMap,+  emptyVertexMap,+  vertexForLabel,+  lookupVertexForLabel,+  vertexMapFromGraph,+  -- * Ref interface+  VertexMapRef,+  newVertexMapRef,+  vertexForLabelRef,+  vertexMapFromRef ) where++import qualified Control.DeepSeq as DS+import Control.Monad ( liftM )+import qualified Control.Monad.Primitive as P+import qualified Control.Monad.Ref as R+import Data.Map ( Map )+import qualified Data.Map as M+import Data.Tuple ( swap )++import Data.Graph.Haggle.Classes++-- | A simple mapping from labels to their 'Vertex'+newtype VertexMap nl = VM (Map nl Vertex)++instance (DS.NFData nl) => DS.NFData (VertexMap nl) where+  rnf (VM m) = m `DS.deepseq` ()++emptyVertexMap :: VertexMap nl+emptyVertexMap = VM M.empty++-- | > (v, m') <- vertexForLabel g m lbl+--+-- Looks up the 'Vertex' for @lbl@ in @g@.  If no 'Vertex' in @g@ has that+-- label, a new 'Vertex' is allocated and returned.  The updated vertex+-- mapping @m'@ is returned, too.+vertexForLabel :: (MLabeledVertex g, Ord (MVertexLabel g), P.PrimMonad m, R.MonadRef m)+               => g m+               -> VertexMap (MVertexLabel g)+               -> MVertexLabel g+               -> m (Vertex, VertexMap (MVertexLabel g))+vertexForLabel g vm@(VM m) lbl+  | Just v <- M.lookup lbl m = return (v, vm)+  | otherwise = do+    v <- addLabeledVertex g lbl+    let m' = M.insert lbl v m+    return (v, VM m')++-- | A pure lookup to convert a 'Vertex' label into a 'Vertex'.  If the+-- label is not in the graph, returns 'Nothing'.+lookupVertexForLabel :: (Ord nl) => nl -> VertexMap nl -> Maybe Vertex+lookupVertexForLabel lbl (VM m) = M.lookup lbl m++-- | Build a 'VertexMap' from a 'Graph' with 'Vertex' labels.+vertexMapFromGraph :: (HasVertexLabel g, Ord (VertexLabel g))+                   => g -> VertexMap (VertexLabel g)+vertexMapFromGraph = VM . M.fromList . map swap . labeledVertices++-- | A 'VertexMap' wrapped up in a mutable ref for possibly+-- easier access in 'vertexMapFromRef'.+newtype VertexMapRef nl m = VMR (R.Ref m (VertexMap nl))++-- | Extract the pure 'VertexMap' from the mutable ref.  This is useful+-- to retain the mapping after the graph is fully constructed.+vertexMapFromRef :: (P.PrimMonad m, R.MonadRef m) => VertexMapRef nl m -> m (VertexMap nl)+vertexMapFromRef (VMR ref) = R.readRef ref++-- | Allocate a new 'VertexMap' buried in a mutable ref.+newVertexMapRef :: (P.PrimMonad m, R.MonadRef m) => m (VertexMapRef nl m)+newVertexMapRef = liftM VMR $ R.newRef emptyVertexMap++-- | Just like 'vertexForLabel', but holding the mapping in a ref instead+-- of threading it.  Usage is simpler:+--+-- > v <- vertexForLabelRef g m lbl+vertexForLabelRef :: (MLabeledVertex g, Ord (MVertexLabel g), P.PrimMonad m, R.MonadRef m)+                  => g m+                  -> VertexMapRef (MVertexLabel g) m+                  -> MVertexLabel g+                  -> m Vertex+vertexForLabelRef g (VMR ref) lbl = do+  vm <- R.readRef ref+  (v, vm') <- vertexForLabel g vm lbl+  R.writeRef ref vm'+  return v++

@@ -0,0 +1,155 @@+-- | This module tests Haggle by comparing its results to those of FGL.+-- This assumes that FGL is reasonably correct.+--+-- The arbitrary instance for GraphPair generates a list of edges and+-- then constructs equivalent FGL and Haggle graphs.  The quickcheck+-- properties for each operation try to ensure that the two implementations+-- return the same results.+module Main ( main ) where++import Test.Framework ( defaultMain, testGroup, Test )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.QuickCheck++import Control.Arrow ( first, second )+import Control.Monad ( replicateM )+import qualified Data.Foldable as F+import Data.Maybe ( isNothing )+import qualified Data.Set as S++import qualified Data.Graph.Inductive as FGL+import qualified Data.Graph.Haggle as HGL+import qualified Data.Graph.Haggle.VertexLabelAdapter as HGL+import qualified Data.Graph.Haggle.SimpleBiDigraph as HGL+import qualified Data.Graph.Haggle.Algorithms.DFS as HGL+import qualified Data.Graph.Haggle.Algorithms.Dominators as HGL++-- import Debug.Trace+-- debug = flip trace++type BaseGraph = FGL.Gr Int ()+type TestGraph = HGL.VertexLabeledGraph HGL.SimpleBiDigraph Int++data GraphPair = GP [(Int, Int)] BaseGraph TestGraph++instance Arbitrary GraphPair where+  arbitrary = sized mkGraphPair++instance Show GraphPair where+  show (GP es _ _) = show es++newtype NodeId = NID Int+  deriving (Show)+instance Arbitrary NodeId where+  arbitrary = sized mkNodeId+    where+      mkNodeId n = do+        i <- choose (0, n)+        return (NID i)++mkGraphPair :: Int -> Gen GraphPair+mkGraphPair sz = do+  nEdges <- choose (2, 2 * sz)+  srcs <- replicateM nEdges (choose (0, sz))+  dsts <- replicateM nEdges (choose (0, sz))+  let edges = unique $ zip srcs dsts+      nids = unique (srcs ++ dsts)+      ns = zip nids nids+      bg = FGL.mkGraph ns (map (\(s, d) -> (s, d, ())) edges)+      (tg, _) = HGL.fromEdgeList HGL.newMSimpleBiDigraph edges+  return $! GP edges bg tg++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests = [ testProperty "prop_sameVertexCount" prop_sameVertexCount+        , testProperty "prop_sameEdgeCount" prop_sameEdgeCount+        , testProperty "prop_sameSuccessorsAtLabel" prop_sameSuccessorsAtLabel+        , testProperty "prop_samePredecessorsAtLabel" prop_samePredecessorsAtLabel+        , testProperty "prop_dfsSame" prop_dfsSame+        , testProperty "prop_sameComponents" prop_sameComponents+        , testProperty "prop_sameNoComponents" prop_sameNoComponents+        , testProperty "prop_immDominatorsSame" prop_immDominatorsSame+        , testProperty "prop_dominatorsSame" prop_dominatorsSame+        ]++prop_sameVertexCount :: GraphPair -> Bool+prop_sameVertexCount (GP _ bg tg) =+  length (FGL.nodes bg) == length (HGL.vertices tg)++prop_sameEdgeCount :: GraphPair -> Bool+prop_sameEdgeCount (GP _ bg tg) =+  length (FGL.edges bg) == length (HGL.edges tg)++prop_sameSuccessorsAtLabel :: (NodeId, GraphPair) -> Bool+prop_sameSuccessorsAtLabel (NID nid, GP _ bg tg)+  | not (FGL.gelem nid bg) && isNothing (vertexFromLabel tg nid) = True+  | otherwise = bss == tss+  where+    bss = S.fromList $ fmap Just $ FGL.suc bg nid+    ts = maybe [] (map (HGL.vertexLabel tg) . HGL.successors tg) (vertexFromLabel tg nid)+    tss = S.fromList ts++prop_samePredecessorsAtLabel :: (NodeId, GraphPair) -> Bool+prop_samePredecessorsAtLabel (NID nid, GP _ bg tg)+  | not (FGL.gelem nid bg) && isNothing (vertexFromLabel tg nid) = True+  | otherwise = bss == tss+  where+    bss = S.fromList $ fmap Just $ FGL.pre bg nid+    ts = maybe [] (map (HGL.vertexLabel tg) . HGL.predecessors tg) (vertexFromLabel tg nid)+    tss = S.fromList ts++-- Note that this is only checking the *set* of vertices reached.  Unfortunately,+-- verifying the *order* is difficult because there are many valid DFS orders+-- (depending on the order edges are stored).  A test using the DFS number+-- (derived from the depth in the depth-first tree) would be a good complement+-- to this.+prop_dfsSame :: (NodeId, GraphPair) -> Bool+prop_dfsSame (NID root, GP _ bg tg) =+  S.fromList bres == S.fromList tres+  where+    bres = map Just $ FGL.dfs [root] bg+    v = vertexFromLabel tg root+    tres = maybe [] (map (HGL.vertexLabel tg) . HGL.dfs tg . (:[])) v++prop_immDominatorsSame :: (NodeId, GraphPair) -> Bool+prop_immDominatorsSame (NID root, GP _ bg tg)+  | not (FGL.gelem root bg) && isNothing (vertexFromLabel tg root) = True+  | otherwise = S.fromList bdoms == S.fromList tdoms+  where+    bdoms = FGL.iDom bg root+    toLabs (v1, v2) =+      let Just v1l = HGL.vertexLabel tg v1+          Just v2l = HGL.vertexLabel tg v2+      in (v1l, v2l)+    tdoms = maybe [] (map toLabs . HGL.immediateDominators tg) (vertexFromLabel tg root)++prop_dominatorsSame :: (NodeId, GraphPair) -> Bool+prop_dominatorsSame (NID root, GP _ bg tg)+  | not (FGL.gelem root bg) && isNothing (vertexFromLabel tg root) = True+  | otherwise = S.fromList (map (first Just) bdoms) == S.fromList (map (first (HGL.vertexLabel tg)) tdoms)+  where+    bdoms = map (second (S.fromList . map Just)) $ FGL.dom bg root+    Just rv = vertexFromLabel tg root+    tdoms = map (second (S.fromList . map (HGL.vertexLabel tg))) $ HGL.dominators tg rv++prop_sameComponents :: GraphPair -> Bool+prop_sameComponents (GP _ bg tg) = bcs == tcs+  where+    bcs = S.map (S.fromList . map Just) $ S.fromList $ FGL.components bg+    tcs = S.map (S.fromList . map (HGL.vertexLabel tg)) $ S.fromList $ HGL.components tg++prop_sameNoComponents :: GraphPair -> Bool+prop_sameNoComponents (GP _ bg tg) =+  FGL.noComponents bg == HGL.noComponents tg++-- Helpers++vertexFromLabel :: TestGraph -> Int -> Maybe HGL.Vertex+vertexFromLabel g lbl = F.find labelMatch (HGL.vertices g)+  where+    labelMatch v = Just lbl == (HGL.vertexLabel g v)++unique :: (Ord a) => [a] -> [a]+unique = S.toList . S.fromList