haggle 0.2 → 0.3

raw patch · 9 files changed

+128/−12 lines, 9 filesdep −monad-primitivedep ~fgldep ~vectorPVP ok

version bump matches the API change (PVP)

Dependencies removed: monad-primitive

Dependency ranges changed: fgl, vector

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−0
• README.md +1/−1
• haggle.cabal +6/−6
• src/Data/Graph/Haggle.hs +5/−0
• src/Data/Graph/Haggle/Algorithms/Dominators.hs +4/−3
• src/Data/Graph/Haggle/Classes.hs +4/−0
• src/Data/Graph/Haggle/PatriciaTree.hs +19/−1
• src/Data/Graph/Haggle/VertexLabelAdapter.hs +1/−1
• tests/GraphTests.hs +79/−0

@@ -1,3 +1,12 @@+0.3 (2023-08-20)+----------------++- Add `Functor` instances for `PatriciaTree` and `Ctx` (@RyanGlScott)+- Support building with vector-0.13.* (@RyanGlScott)+- Remove an unused dependency on monad-primitive (@RyanGlScott)+- Add `replaceLabeledVertex` to the `InductiveGraph` interface (@kquick)+- Fixed a bug in the dominators calculation (@kquick)+ 0.2 (2022-05-08) ---------------- 

@@ -1,5 +1,5 @@ # Overview-![travis-ci status](https://travis-ci.org/travitch/haggle.svg?branch=master)+![Github Actions status](https://github.com/travitch/haggle/actions/workflows/haskell-ci.yml/badge.svg)  Haggle is a graph library for Haskell.  It aims to support large graphs efficiently and compactly.  It differs from

@@ -1,5 +1,5 @@ name: haggle-version: 0.2+version: 0.3 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@@ -16,7 +16,7 @@ category: Data Structures, Graphs build-type: Simple cabal-version: >=1.10-tested-with: GHC ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.2+tested-with: GHC ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.5 || ==0.6.2 extra-source-files: ChangeLog.md                     README.md @@ -43,13 +43,12 @@                  Data.Graph.Haggle.Internal.BitSet   build-depends: base >= 4.5 && < 5,                  ref-tf >= 0.4 && < 0.6,-                 vector >= 0.9 && < 0.13,+                 vector >= 0.9 && < 0.14,                  vector-th-unbox >= 0.2.1.3 && < 0.3,                  primitive >= 0.4 && < 0.9,                  containers >= 0.4,                  hashable >= 1.2 && < 1.5,-                 deepseq >= 1 && < 2,-                 monad-primitive < 0.2+                 deepseq >= 1 && < 2  test-suite GraphTests   type: exitcode-stdio-1.0@@ -60,7 +59,8 @@   build-depends: haggle,                  base >= 4.5,                  containers,-                 fgl,+                 -- fgl 5.8.1.1 is required for its dom fix for oracle testing here+                 fgl >= 5.8.1.1,                  HUnit,                  QuickCheck > 2.4,                  test-framework,

@@ -157,6 +157,7 @@   deleteEdge,   deleteEdgesBetween,   replaceLabeledEdge,+  replaceLabeledVertex,   deleteVertex,   I.Context(..), @@ -379,6 +380,10 @@ 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 #-}++replaceLabeledVertex :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g -> I.Vertex -> I.VertexLabel g -> g+replaceLabeledVertex = I.replaceLabeledVertex+{-# INLINABLE replaceLabeledVertex #-}  deleteVertex :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g -> I.Vertex -> g deleteVertex = I.deleteVertex

@@ -61,7 +61,7 @@   (res, toNode, fromNode) <- domWork g root   let dom' = getDom toNode res       rest = M.keys (M.filter (-1 ==) fromNode)-      verts = vertices g+      verts = reachable root g   return $ [(toNode ! i, dom' ! i) | i <- [0..V.length dom' - 1]] ++            [(n, verts) | n <- rest] @@ -70,6 +70,7 @@   | null trees = Nothing   | otherwise = return (idom, toNode, fromNode)   where+    vlist = reachable root g     -- Build up a depth-first tree from the root as a first approximation     trees@(~[tree]) = dff g [root]     (s, ntree) = numberTree 0 tree@@ -83,7 +84,7 @@     -- 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))+    otherNodes = M.fromList $ zip vlist (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)@@ -93,7 +94,7 @@     -- 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)+    predMap = fmap S.toList $ foldr (toPredecessor g) M.empty vlist     preds = V.fromList $ [0] : [filter (/= -1) (map (fromNode M.!) (predMap M.! (toNode ! i)))                                | i <- [1..s-1]]     idom = fixEq (refineIDom preds) idom0

@@ -208,6 +208,10 @@     let g' = deleteEdgesBetween g src dst     in insertLabeledEdge g' src dst lbl +  -- | Used to update the label for a Vertex.  The Vertex itself remains, but the+  -- label associated with the vertex is modified.+  replaceLabeledVertex :: g -> Vertex -> VertexLabel g -> g+   -- | Remove a 'Vertex' from the graph   deleteVertex :: g -> Vertex -> g   deleteVertex g v = fromMaybe g $ do

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies, BangPatterns #-}+{-# LANGUAGE TypeFamilies, BangPatterns, DeriveFunctor #-} -- | This graph is based on the implementation in fgl (using -- big-endian patricia-tries -- IntMap). --@@ -20,6 +20,7 @@ import qualified Data.Graph.Haggle.Internal.Basic as I  data Ctx nl el = Ctx !(IntMap el) I.Vertex nl !(IntMap el)+  deriving Functor  instance (NFData nl, NFData el) => NFData (Ctx nl el) where   rnf (Ctx p v nl s) =@@ -37,6 +38,7 @@ -- 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) }+  deriving Functor  instance (NFData nl, NFData el) => NFData (PatriciaTree nl el) where   rnf (Gr im) = im `deepseq` ()@@ -120,6 +122,17 @@         v = I.V vid         g' = IM.insert vid (Ctx mempty v lab mempty) g     in (v, Gr g')+  replaceLabeledVertex (Gr g) (I.V v) vl =+    let updLabel (Ctx ie nv _nl oe) = Ctx ie nv vl oe+    in Gr $ IM.adjust updLabel v g+  insertLabeledEdge gr@(Gr g) v1@(I.V src) (I.V dst) lab | src == dst = do+    guard (IM.member src g)+    guard (not (I.edgeExists gr v1 v1))+    let e = I.E (-1) src src+    Ctx spp sv sl sss <- IM.lookup src g+    let ctx' = Ctx (IM.insert src lab spp) sv sl (IM.insert dst lab sss)+        !g' = IM.insert src ctx' g+    return (e, 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))@@ -132,6 +145,11 @@         !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) | src == dst = fromMaybe gr $ do+    Ctx spp sv sl sss <- IM.lookup src g+    let ctx' = Ctx (IM.delete src spp) sv sl (IM.delete src sss)+        !g' = IM.insert src ctx' g+    return (Gr g')   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

@@ -229,7 +229,7 @@ -- > import Data.Graph.Haggle.VertexLabelAdapter -- > import Data.Graph.Haggle.SimpleBiDigraph -- >--- > let g = fromEdgeList newMSimpleBiDigraph [(0,1), (1,2), (2,3), (3,0)]+-- > let (g,m) = fromEdgeList newMSimpleBiDigraph [(0,1), (1,2), (2,3), (3,0)] -- -- @g@ has type SimpleBiDigraph. --

@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+ -- | This module tests Haggle by comparing its results to those of FGL. -- This assumes that FGL is reasonably correct. --@@ -6,6 +8,7 @@ -- 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, Test )@@ -80,8 +83,13 @@         , testProperty "prop_sameComponents" prop_sameComponents         , testProperty "prop_sameNoComponents" prop_sameNoComponents         , testProperty "prop_immDominatorsSame" prop_immDominatorsSame++        -- prop_dominatorsSame requires fgl 5.8.1.1, which fixes errors in fgl's+        -- dom functionality that is used as the oracle for the tests here.         , testProperty "prop_dominatorsSame" prop_dominatorsSame+         ] <>  testPatricia+        <> testExplicit  prop_sameVertexCount :: GraphPair -> Bool prop_sameVertexCount (GP _ bg tg) =@@ -167,6 +175,70 @@  -- Explicit tests for various functionality +testExplicit :: [Test.Framework.Test]+testExplicit =+  let gr0 = foldl (\g -> snd . HGL.insertLabeledVertex g)+            (HGL.emptyGraph :: HGL.PatriciaTree Int Char)+            [1,2,4]+      vs = fst <$> HGL.labeledVertices gr0++      plusEdge g f t = snd $ fromJust $ HGL.insertLabeledEdge g f t 'a'++      gr1 = plusEdge gr0 (vs !! 0) (vs !! 1)+      -- gr1 has three nodes, two are connected, one is not connected (i.e. two+      -- independent subgraphs)++      gr2 = plusEdge (plusEdge gr0 (vs !! 1) (vs !! 0)) (vs !! 1) (vs !! 1)+++  in hUnitTestToTests $ test+     [ "haggle (patricia) [1-2,4] reachable from 1" ~:+       do HGL.reachable (vs !! 0) gr1 @?= [ (vs !! 0)+                                          , (vs !! 1)+                                          ]+     , "haggle (patricia) [1-2,4] reachable from 2" ~:+       do HGL.reachable (vs !! 1) gr1 @?= [ (vs !! 1)+                                          ]+     , "haggle (patricia) [2-1,2-2] reachable from 1" ~:+       do HGL.reachable (vs !! 0) gr2 @?= [ (vs !! 0)+                                          ]++     , "haggle dominator [1-2,4] from 1" ~:+       do HGL.dominators gr1 (vs !! 0) @?= [ (vs !! 0, [ (vs !! 0) ])+                                           , (vs !! 1, [ (vs !! 1), (vs !! 0) ])+                                           ]++     , "haggle dominator [2-1,2-2,4] from 1" ~:+       do HGL.dominators gr2 (vs !! 0) @?= [ (vs !! 0, [ (vs !! 0) ])+                                           ]++     , "haggle add self-edge" ~:+       do let Just (e,g) = HGL.insertLabeledEdge gr0 (vs!!0) (vs!!0) 's'+          HGL.edges g @?= [e]++     , "haggle delete self-edge" ~:+       do let Just (_,g) = HGL.insertLabeledEdge gr0 (vs!!0) (vs!!0) 's'+          HGL.edges (HGL.deleteEdgesBetween g (vs!!0) (vs!!0)) @?= []+++     -- n.b. fgl's dominator is broken (as haggle's original version also was) in+     -- that its return includes (4, [1,2,4]), which is invalid: 4 is in an+     -- independent subgraph and cannot be dominated by 1.+     -- , "fgl dominator for [1-2,4] from 1" ~:+     --   do let fgr0 = FGL.mkGraph [(1,1), (2,2), (4,4)] [(0, 1, 'f')] :: FGL.Gr Int Char+     --      FGL.dom fgr0 1 @?= [ (1, [ 1 ])+     --                         , (2, [ 1, 2 ])+     --                         ]++     -- n.b. fgl's dominator is also broken in regards to reachability.  For a+     -- dom return for [2-1, 2-2] from 1 also returns (2, [1,2]) which is+     -- invalid, because 2 is not reachable from 1 and so 1 cannot be a dominator+     -- for 2+     -- , "fgl dominator for [2-1,2-2] from 1" ~:+     --   do let fgr2 = FGL.mkGraph [(1,1), (2,2)] [(2,1,'f'), (2,2,'s')] :: FGL.Gr Int Char+     --      FGL.dom fgr2 1 @?= [ (1, [ 1 ]) ]+     ]+ testPatricia :: [Test.Framework.Test] testPatricia =   let gr0 = foldl (\g -> snd . HGL.insertLabeledVertex g)@@ -199,4 +271,11 @@        do let gr2 = Bi.bimap (+2) (succ . succ) gr1           sum (snd <$> HGL.labeledVertices gr2) @?= 27           L.sort (snd <$> HGL.labeledEdges gr2) @?= "cde"++     , "replaceLabeledVertex" ~:+       do let gr2 = HGL.replaceLabeledVertex gr1 (vs !! 2) 11+          -- Vertex label changed?+          sum (snd <$> HGL.labeledVertices gr2) @?= (15 + (11 - 4))+          -- Edges are still in place?+          L.sort (snd <$> HGL.labeledEdges gr2) @?= "abc"      ]