haggle 0.3 → 0.3.1

raw patch · 10 files changed

+508/−81 lines, 10 filesdep +criteriondep ~basedep ~containersdep ~deepseqPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: criterion

Dependency ranges changed: base, containers, deepseq, hashable, primitive

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• bench/HaggleBench.hs +184/−0
• haggle.cabal +21/−4
• src/Data/Graph/Haggle/Algorithms/DFS.hs +30/−18
• src/Data/Graph/Haggle/Algorithms/Dominators.hs +38/−31
• src/Data/Graph/Haggle/Classes.hs +4/−3
• src/Data/Graph/Haggle/Internal/Adapter.hs +6/−4
• src/Data/Graph/Haggle/Internal/BitSet.hs +34/−8
• src/Data/Graph/Haggle/PatriciaTree.hs +7/−4
• tests/GraphTests.hs +177/−9

@@ -1,3 +1,10 @@+0.3.1 (2025-08-13)+------------------++- Update bounds for compatibility with ghc-9.10+- Add `hasCycle` for detecting cycles in graphs (@kquick)+- Optimize DFS algorithms by removing an unnecessary traversal (@kquick)+ 0.3 (2023-08-20) ---------------- 

@@ -0,0 +1,184 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Main ( main ) where++import           Criterion.Main++import           Control.DeepSeq+import           Data.Bifunctor ( bimap )+import qualified Data.Foldable as F+import           Data.Maybe ( fromJust )+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.Algorithms.DFS as HGL+++-- | Generates a list of nodes and edges for a sample graph of the specified+-- depth (height).  The root node will be 0, and every node will have "width"+-- children down to the desired depth.  There are also some extra cross-level+-- edges added to keep things from being too regular.+mkEdges :: Int -> Int -> ([Int], [(Int,Int)])+mkEdges width depth = bimap unique unique $ go [0] 0+  where go cur l =+          if l >= depth then (mempty, mempty)+          else let subStart i = if i == 0 then 1 else width ^ i + subStart (i-1)+                   subVals = [ subStart l .. ]+                   (subNs, subEs) =+                     fst $ foldr addToRoot ((mempty, mempty), subVals) cur+                   addToRoot r ((rnodes, redges), vals) =+                     let (thisSub, remSub) = splitAt width vals+                         thisEdges = (r,) <$> thisSub+                     in ((rnodes <> thisSub, redges <> thisEdges), remSub)+                   next = go subNs (l+1)+                   extra =+                     let esrcs = concat $ replicate width cur+                         etgts = [ t+                                 | t <- drop l $ fst next+                                 , t `mod` (width + 3) == 0 ]+                     in zip esrcs etgts+               in (cur <> subNs <> fst next, subEs <> extra <> snd next)+++mkFglGraph :: Int -> Int -> FGL.Gr Int ()+mkFglGraph depth width =+  let (nodes, edgs) = mkEdges width depth+      edges = fmap (\(s,d) -> (s,d,())) edgs+  in FGL.mkGraph (zip nodes nodes) edges+++mkHaggleDiGraph :: Int -> Int+                -> (HGL.Vertex, HGL.VertexLabeledGraph HGL.Digraph Int)+mkHaggleDiGraph depth width =+  let (_nodes, edges) = mkEdges width depth+      g = fst $ HGL.fromEdgeList  HGL.newMDigraph edges+      Just v = vertexFromLabel g 0+  in (v, g)++mkHaggleBiDiGraph :: Int -> Int -> (HGL.Vertex, HGL.VertexLabeledGraph HGL.BiDigraph Int)+mkHaggleBiDiGraph depth width =+  let (_nodes, edges) = mkEdges width depth+      g = fst $ HGL.fromEdgeList HGL.newMBiDigraph edges+      Just v = vertexFromLabel g 0+  in (v, g)++mkHaggleSimpleBiDiGraph :: Int -> Int -> (HGL.Vertex, HGL.VertexLabeledGraph HGL.SimpleBiDigraph Int)+mkHaggleSimpleBiDiGraph depth width =+  let (_nodes, edges) = mkEdges width depth+      g = fst $ HGL.fromEdgeList HGL.newMSimpleBiDigraph edges+      Just v = vertexFromLabel g 0+  in (v, g)++mkHagglePatriciaGraph :: Int -> Int -> (HGL.Vertex, HGL.PatriciaTree Int ())+mkHagglePatriciaGraph depth width =+  let (nodes, edges) = mkEdges width depth+      addNode g n = snd $ HGL.insertLabeledVertex g n+      gnodes = foldl addNode HGL.emptyGraph nodes+      addEdge g (s,d) = fromJust $ do sv <- vertexFromLabel g s+                                      dv <- vertexFromLabel g d+                                      (_,g') <- HGL.insertLabeledEdge g sv dv ()+                                      return g'+      pgraph = foldl addEdge gnodes edges+      Just v = vertexFromLabel pgraph 0+  in (v, pgraph)+++vertexFromLabel :: HGL.HasVertexLabel g+                => Eq (HGL.VertexLabel g)+                => g -> HGL.VertexLabel g -> 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++testFglDFS :: FGL.Graph gr => gr a b -> [FGL.Node]+testFglDFS g = let r = FGL.dfs [0,0,0] g in if null r then error "bad fgl dfs" else r++testHaggleDFS :: HGL.HasVertexLabel g+              => Eq (HGL.VertexLabel g)+              => Num (HGL.VertexLabel g)+              => (HGL.Vertex, g) -> [Maybe (HGL.VertexLabel g)]+testHaggleDFS (r,g) = HGL.vertexLabel g <$> HGL.dfs g [r,r,r]++testHaggleXDFS :: HGL.HasVertexLabel g+               => Eq (HGL.VertexLabel g)+               => Num (HGL.VertexLabel g)+               => (HGL.Vertex, g) -> [Maybe (HGL.VertexLabel g)]+testHaggleXDFS (r,g) = HGL.vertexLabel g+                       <$> HGL.xdfsWith g (HGL.successors g) id [r,r,r]++main :: IO ()+main = do setup+          defaultMain [+            bgroup "dfs" [+                bgroup "nf" [+                    bench "fgl" $ nf testFglDFS g1f+                    , bench "haggle.di" $ nf testHaggleDFS g1hd+                    , bench "haggle.bidi" $ nf testHaggleDFS g1hbd+                    , bench "haggle.simplebidi" $ nf testHaggleDFS g1hsbd+                    , bench "haggle.patricia" $ nf testHaggleDFS g1hp+                    ]+                ]+            , bgroup "xdfs" [+                bgroup "nf" [+                    bench "haggle.di" $ nf testHaggleXDFS g1hd+                    , bench "haggle.bidi" $ nf testHaggleXDFS g1hbd+                    , bench "haggle.simplebidi" $ nf testHaggleXDFS g1hsbd+                    , bench "haggle.patricia" $ nf testHaggleXDFS g1hp+                    ]+                -- , bgroup "whnf" [+                --     bench "haggle.di" $ whnf testHaggleXDFS g1hd+                --     , bench "haggle.bidi" $ whnf testHaggleXDFS g1hbd+                --     , bench "haggle.simplebidi" $ whnf testHaggleXDFS g1hsbd+                --     , bench "haggle.patricia" $ whnf testHaggleXDFS g1hp+                --     ]+                ]+            , bgroup "topsort" [+                bgroup "nf" [+                    bench "fgl" $ nf FGL.topsort g1f+                    , bench "haggle.di" $ nf HGL.topsort $ snd g1hd+                    , bench "haggle.bidi" $ nf HGL.topsort $ snd g1hbd+                    , bench "haggle.simplebidi" $ nf HGL.topsort $ snd g1hsbd+                    , bench "haggle.patricia" $ nf HGL.topsort $ snd g1hp+                    ]+                ]+            , bgroup "scc" [+                bgroup "nf" [+                    bench "fgl" $ nf FGL.scc g1f+                    -- , bench "haggle.di" $ nf HGL.scc $ snd g1hd+                    , bench "haggle.bidi" $ nf HGL.scc $ snd g1hbd+                    , bench "haggle.simplebidi" $ nf HGL.scc $ snd g1hsbd+                    , bench "haggle.patricia" $ nf HGL.scc $ snd g1hp+                    ]+                ]+            , bgroup "isConnected" [+                bgroup "nf" [+                    bench "fgl" $ nf FGL.isConnected g1f+                    -- , bench "haggle.di" $ nf HGL.isConnected $ snd g1hd+                    , bench "haggle.bidi" $ nf HGL.isConnected $ snd g1hbd+                    , bench "haggle.simplebidi" $ nf HGL.isConnected $ snd g1hsbd+                    , bench "haggle.patricia" $ nf HGL.isConnected $ snd g1hp+                    ]+                ]+            ]+  where+    setup = g1f+            -- `deepseq` g1hd   -- error: uninitialised element (from Vector)+            -- `deepseq` g1hbd  -- no instance for NFData+            -- `deepseq` g1hsbd   -- error: uninitialised element (from Vector)+            `deepseq` g1hp+            `deepseq` return ()++    g1f :: FGL.Gr Int ()+    g1f = mkFglGraph 4 5++    g1hd = mkHaggleDiGraph 4 5+    g1hbd = mkHaggleBiDiGraph 4 5+    g1hsbd = mkHaggleSimpleBiDiGraph 4 5+    g1hp = mkHagglePatriciaGraph 4 5

@@ -1,5 +1,5 @@ name: haggle-version: 0.3+version: 0.3.1 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.8 || ==9.4.5 || ==0.6.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.8 || ==9.6.6 || == 9.8.2 || == 9.10.1 extra-source-files: ChangeLog.md                     README.md @@ -45,9 +45,9 @@                  ref-tf >= 0.4 && < 0.6,                  vector >= 0.9 && < 0.14,                  vector-th-unbox >= 0.2.1.3 && < 0.3,-                 primitive >= 0.4 && < 0.9,+                 primitive >= 0.4 && < 0.10,                  containers >= 0.4,-                 hashable >= 1.2 && < 1.5,+                 hashable >= 1.2 && < 1.6,                  deepseq >= 1 && < 2  test-suite GraphTests@@ -66,6 +66,23 @@                  test-framework,                  test-framework-hunit,                  test-framework-quickcheck2++benchmark haggleBench+  type: exitcode-stdio-1.0+  default-language: Haskell2010+  main-is: HaggleBench.hs+  hs-source-dirs: bench+  ghc-options: -Wall -O2+  build-depends: haggle+               , base >= 4.5+               , criterion >= 1 && < 1.7+               , containers+               , deepseq+               , fgl >= 5.8.1.1+  if impl(ghc >= 8.4)+     buildable: True+  else+     buildable: False  source-repository head   type: git

@@ -40,10 +40,11 @@   isConnected,   topsort,   scc,-  reachable+  reachable,+  hasCycle   ) where -import Control.Monad ( filterM, foldM, liftM )+import Control.Monad ( foldM ) import Control.Monad.ST import qualified Data.Foldable as F import Data.Monoid@@ -66,22 +67,23 @@          -> [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+  | otherwise =+    if any (not . (`elem` vertices g)) roots+    then []+    else 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)+      isMarked <- testBitUnsafe bs (vertexId v)       case isMarked of         True -> return acc         False -> do-          setBit bs (vertexId v)-          nxt <- filterM (notVisited bs) (nextVerts v)+          setBitUnsafe bs (vertexId v)+          let nxt = 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)@@ -129,18 +131,21 @@          -> [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+  | otherwise =+    if any (not . (`elem` vertices g)) roots+    then []+    else 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)+      isMarked <- testBitUnsafe bs (vertexId v)       case isMarked of         True -> return acc         False -> do-          setBit bs (vertexId v)-          nxt <- filterM (notVisited bs) (nextVerts v)+          setBitUnsafe bs (vertexId v)+          let nxt = nextVerts v           ts <- foldM (go bs) [] nxt           return $ T.Node (f v) (reverse ts) : acc @@ -193,6 +198,13 @@ -- | Compute the set of vertices reachable from a root 'Vertex'. reachable :: (Graph g) => Vertex -> g -> [Vertex] reachable v g = preorderF (dff g [v])+++-- | Returns true if the current node is part of a cycle (i.e. itself is+-- reachable by a path starting with one or more of this vertex's out edges).+hasCycle :: (Graph g) => Vertex -> g -> Bool+hasCycle v g = any (\v' -> v `elem` (reachable v' g)) $ successors g v+  -- Helpers 

@@ -51,7 +51,9 @@ 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+  case V.toList $ V.imap (\i n -> (toNode!i, toNode!n)) res of+    [] -> error "Impossible: a vertex always dominates itself"+    _ : rest -> return rest  -- | 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,@@ -66,38 +68,43 @@            [(n, verts) | n <- rest]  domWork :: (Graph g) => g -> Vertex -> Maybe (IDom, ToNode, FromNode)-domWork g root-  | null trees = Nothing-  | otherwise = return (idom, toNode, fromNode)+domWork g root =+  -- Build up a depth-first tree from the root as a first approximation+  case dff g [root] of+    [] -> Nothing+    [tree] ->+      let (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 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)+          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 vlist+          preds = V.fromList $ [0] : [filter (/= -1) (map (fromNode M.!) (predMap M.! (toNode ! i)))+                                     | i <- [1..s-1]]+++          idom = fixEq (refineIDom preds) idom0+      in return (idom, toNode, fromNode)+    _trees -> error "Impossible: only a single tree can be reachable starting from a single root node"   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-    -- 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 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)-    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 vlist-    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

@@ -219,6 +219,7 @@     return g'  addEdgeLabel :: (HasEdgeLabel g) => g -> Edge -> (Edge, EdgeLabel g)-addEdgeLabel g e = (e, el)-  where-   Just el = edgeLabel g e+addEdgeLabel g e =+  case edgeLabel g e of+    Just el -> (e, el)+    Nothing -> error "Expected an edge label for a graph implementation satisfying the HasEdgeLabel constraint"

@@ -324,8 +324,9 @@ labeledVertices g = map toLabVert $ I.vertices (rawGraph g)   where     toLabVert v =-      let Just lab = vertexLabel g v-      in (v, lab)+      case vertexLabel g v of+        Just lab -> (v, lab)+        Nothing -> error "Impossible: LabeledGraphs always have vertex labels"  -- | Likewise, we use 'edges' here instead of directly reading from the edge -- label storage array.@@ -333,8 +334,9 @@ labeledEdges g = map toLabEdge $ I.edges (rawGraph g)   where     toLabEdge e =-      let Just lab = edgeLabel g e-      in (e, lab)+      case edgeLabel g e of+        Just lab -> (e, lab)+        Nothing -> error "Impossible: LabeledGraphs always have edge labels"  mapEdgeLabel :: LabeledGraph g nl el -> (el -> el') -> LabeledGraph g nl el' mapEdgeLabel g f = g { edgeLabelStore = V.map f (edgeLabelStore g) }

@@ -2,7 +2,9 @@   BitSet,   newBitSet,   setBit,-  testBit+  testBit,+  setBitUnsafe,+  testBitUnsafe   ) where  import Control.Monad.ST@@ -11,6 +13,21 @@ import qualified Data.Vector.Unboxed.Mutable as V import Data.Word ( Word64 ) +-- Note that the implementation here assumes thaththe bit numbers are all+-- unsigned.  A proper implementation would perhaps use 'Natural' instead of+-- 'Int', but that would require gratuitous fromEnum/toEnum conversions from all+-- the other API's that just use 'Int', which has about a 33% performance impact+-- when measured.+--+-- The 'setBit' and 'testBit' operations use V.unsafeRead instead of V.read+-- (where the latter is roughly 25% slower) because this is an internal module+-- that is generally always used with a positive 'Int' value, and the value is+-- also checked against 'sz' (which is also probably superfluous).  In other+-- words, this module prioritizes performance over robustness and should only be+-- used when the caller can guarantee positive Int values and otherwise good+-- behavior.++ data BitSet s = BS (STVector s Word64) {-# UNPACK #-} !Int  bitsPerWord :: Int@@ -28,22 +45,31 @@  -- | Set a bit in the bitset.  Out of range has no effect. setBit :: BitSet s -> Int -> ST s ()-setBit (BS v sz) bitIx+setBit b@(BS _ sz) bitIx   | bitIx >= sz = return ()-  | otherwise = do+  | bitIx < 0 = return ()+  | otherwise = setBitUnsafe b bitIx++-- |  Set a bit in the bitset.  The specified bit must be in range.+setBitUnsafe :: BitSet s -> Int -> ST s ()+setBitUnsafe (BS v _) bitIx = do     let wordIx = bitIx `div` bitsPerWord         bitPos = bitIx `mod` bitsPerWord-    oldWord <- V.read v wordIx+    oldWord <- V.unsafeRead 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+testBit b@(BS _ sz) bitIx   | bitIx >= sz = return False-  | otherwise = do+  | bitIx < 0 = return False+  | otherwise = testBitUnsafe b bitIx++-- | Return True if the bit is set.  The specified bit must be in range.+testBitUnsafe :: BitSet s -> Int -> ST s Bool+testBitUnsafe (BS v _) bitIx = do     let wordIx = bitIx `div` bitsPerWord         bitPos = bitIx `mod` bitsPerWord-    w <- V.read v wordIx+    w <- V.unsafeRead v wordIx     return $ B.testBit w bitPos-

@@ -79,8 +79,10 @@   labeledEdges gr = map toLabEdge (I.edges gr)     where       toLabEdge e =-        let Just lab = I.edgeLabel gr e-        in (e, lab)+        case I.edgeLabel gr e of+          Just lab -> (e, lab)+          Nothing -> error "Impossible: PatriciaTree instances always have edge labels"+   labeledOutEdges (Gr g) (I.V s) = fromMaybe [] $ do     Ctx _ _ _ ss <- IM.lookup s g     return $ IM.foldrWithKey toOut [] ss@@ -95,8 +97,9 @@   labeledVertices gr = map toLabVert (I.vertices gr)     where       toLabVert v =-        let Just l = I.vertexLabel gr v-        in (v, l)+        case I.vertexLabel gr v of+          Just l -> (v, l)+          Nothing -> error "Impossible: PatriciaTree instances always have vertex labels"  instance I.Bidirectional (PatriciaTree nl el) where   predecessors (Gr g) (I.V v) = fromMaybe [] $ do

@@ -1,5 +1,11 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -- | This module tests Haggle by comparing its results to those of FGL. -- This assumes that FGL is reasonably correct.@@ -20,6 +26,7 @@ import Control.Arrow ( first, second ) import qualified Data.Bifunctor as Bi import Control.Monad ( replicateM )+import Data.Function ( on ) import qualified Data.Foldable as F import qualified Data.List as L import Data.Maybe ( fromJust, isNothing )@@ -31,8 +38,6 @@  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 @@ -59,6 +64,8 @@         i <- choose (0, n)         return (NID i) +-- | Generates a pair of a Haggle graph and the corresponding FGL graph to serve+-- as an oracle. mkGraphPair :: Int -> Gen GraphPair mkGraphPair sz = do   nEdges <- choose (2, 2 * sz)@@ -71,6 +78,8 @@       (tg, _) = HGL.fromEdgeList HGL.newMSimpleBiDigraph edges   return $! GP edges bg tg ++ main :: IO () main = defaultMain tests @@ -88,6 +97,11 @@         -- dom functionality that is used as the oracle for the tests here.         , testProperty "prop_dominatorsSame" prop_dominatorsSame +        , testProperty "patricia match: remaining vertices" prop_match_patricia_remvertices+        , testProperty "patricia match: vertex label removed" prop_match_patricia_vlblremoved+        , testProperty "patricia match: disconnected to" prop_match_patricia_no_in_edges+        , testProperty "patricia match: disconnected from" prop_match_patricia_no_out_edges+        , testProperty "patricia match: edges removed" prop_match_patricia_remedges         ] <>  testPatricia         <> testExplicit @@ -202,7 +216,17 @@      , "haggle (patricia) [2-1,2-2] reachable from 1" ~:        do HGL.reachable (vs !! 0) gr2 @?= [ (vs !! 0)                                           ]+     , "no cycle in [1-2,4] from 1" ~:+       do HGL.hasCycle (vs !! 0) gr1 @?= False +     , "cycle in [1-2-1,4] from 1" ~:+       do let tg = plusEdge gr1 (vs !! 1) (vs !! 0)+          HGL.hasCycle (vs !! 0) tg @?= True++     , "cycle in [1*-2,4] from 1" ~:+       do let tg = plusEdge gr1 (vs !! 0) (vs !! 0)+          HGL.hasCycle (vs !! 0) tg @?= True+      , "haggle dominator [1-2,4] from 1" ~:        do HGL.dominators gr1 (vs !! 0) @?= [ (vs !! 0, [ (vs !! 0) ])                                            , (vs !! 1, [ (vs !! 1), (vs !! 0) ])@@ -242,15 +266,15 @@ testPatricia :: [Test.Framework.Test] testPatricia =   let gr0 = foldl (\g -> snd . HGL.insertLabeledVertex g)-                 (HGL.emptyGraph :: HGL.PatriciaTree Int Char)-                 [1,2,4,3,5,0]-      vs = fst <$> HGL.labeledVertices gr0+            (HGL.emptyGraph :: HGL.PatriciaTree Int Char)+            [1,2,4,3,5,0]+      vs = fst <$> (L.sortBy (compare `on` snd) $ HGL.labeledVertices gr0)       gr1 = foldl (\g (f,t,l) ->                      snd $ fromJust $ HGL.insertLabeledEdge g f t l)             gr0-            [ (vs !! 1, vs !! 2, 'a')-            , (vs !! 0, vs !! 2, 'b')-            , (vs !! 1, vs !! 5, 'c')+            [ (vs !! 2, vs !! 4, 'a')+            , (vs !! 1, vs !! 4, 'b')+            , (vs !! 2, vs !! 0, 'c')             ]   in hUnitTestToTests $ test      [ "create graph" ~:@@ -273,9 +297,153 @@           L.sort (snd <$> HGL.labeledEdges gr2) @?= "cde"       , "replaceLabeledVertex" ~:-       do let gr2 = HGL.replaceLabeledVertex gr1 (vs !! 2) 11+       do let gr2 = HGL.replaceLabeledVertex gr1 (vs !! 4) 11           -- Vertex label changed?           sum (snd <$> HGL.labeledVertices gr2) @?= (15 + (11 - 4))           -- Edges are still in place?           L.sort (snd <$> HGL.labeledEdges gr2) @?= "abc"      ]+++----------------------------------------------------------------------+++newtype NodeLabel = NL Int deriving (Eq, Show)+newtype EdgeLabel = EL Int deriving (Eq, Show)++-- type InductiveGraphBuilder g = (g NodeLabel EdgeLabel -> g NodeLabel EdgeLabel)+data InductiveGraphBuilder g =+  IGB { build :: g NodeLabel EdgeLabel -> g NodeLabel EdgeLabel }++instance ( HGL.InductiveGraph (g NodeLabel EdgeLabel)+         , HGL.HasVertexLabel (g NodeLabel EdgeLabel)+         , HGL.HasEdgeLabel (g NodeLabel EdgeLabel)+         , HGL.VertexLabel (g NodeLabel EdgeLabel) ~ NodeLabel+         , HGL.EdgeLabel (g NodeLabel EdgeLabel) ~ EdgeLabel+         ) => Arbitrary (InductiveGraphBuilder g) where+  arbitrary = oneof [ solitaryNode+                    , edgeToNewNode+                    , edgeBetweenExistingNodes+                    , edgeToSelf+                    ]+    where solitaryNode = return $ IGB $ \g ->+            let vLabel = NL $ length $ HGL.vertices g+            in snd $ HGL.insertLabeledVertex g vLabel+          edgeToNewNode = do+            srcNum <- choose (0, 1024)+            return $ IGB $ \g ->+              let vs = HGL.vertices g+                  srcV = cycle vs !! srcNum+                  vLabel = NL $ length $ vs+                  eLabel = EL $ length $ HGL.edges g+                  (nv, ng) = HGL.insertLabeledVertex g vLabel+              in if null vs+                 then ng+                 else maybe g snd $ HGL.insertLabeledEdge ng srcV nv eLabel+          edgeBetweenExistingNodes = do+            srcNum <- choose (0, 1024)+            dstNum <- choose (0, 1024)+            -- n.b. the inductive graphs don't like duplicated edges, but they+            -- will just return Nothing on inserting the edge, which returns the+            -- existing graph, so this duplication attempt is quietly ignored.+            return $ IGB $ \g ->+              let vs = HGL.vertices g+                  srcV = cycle (HGL.vertices g) !! srcNum+                  dstV = cycle (HGL.vertices g) !! dstNum+                  eLabel = EL $ length $ HGL.edges g+              in if null vs+                 then snd $ HGL.insertLabeledVertex g $ NL 0+                 else maybe g snd $ HGL.insertLabeledEdge g srcV dstV eLabel+          edgeToSelf = do+            srcNum <- choose (0, 1024)+            -- see note above re: duplicate edges+            return $ IGB $ \g ->+              let vs = HGL.vertices g+                  srcV = cycle (HGL.vertices g) !! srcNum+                  eLabel = EL $ length $ HGL.edges g+              in if null vs+                 then snd $ HGL.insertLabeledVertex g $ NL 0+                 else maybe g snd $ HGL.insertLabeledEdge g srcV srcV eLabel+++type InductiveProperty g = InductiveCase g -> Bool++data InductiveCase g = IGC g HGL.Vertex deriving Show++instance (Arbitrary g, HGL.Graph g) => Arbitrary (InductiveCase g) where+  arbitrary = do g <- arbitrary+                 v <- elements $ HGL.vertices g+                 return $ IGC g v++onMatchResult :: HGL.InductiveGraph g+              => HGL.Graph g+              => (g -> HGL.Vertex -> (HGL.Context g, g) -> Bool)+              -> InductiveProperty g+onMatchResult prop (IGC g v) =+  case HGL.match g v of+    Nothing -> False+    Just mr -> prop g v mr++prop_match_inductive_remvertices :: HGL.InductiveGraph g => InductiveProperty g+prop_match_inductive_remvertices = onMatchResult $ \g -> \_ -> \(_ctxt, g') ->+  length (HGL.vertices g) == length (HGL.vertices g') + 1++prop_match_inductive_vlblremoved :: HGL.InductiveGraph g+                                 => Eq (HGL.VertexLabel g)+                                 => InductiveProperty g+prop_match_inductive_vlblremoved = onMatchResult $ \_ -> \v -> \(ctxt, g') ->+  let HGL.Context _ vl _ = ctxt+  in not $ (v,vl) `elem` HGL.labeledVertices g'++prop_match_inductive_no_in_edges :: HGL.InductiveGraph g+                                 => InductiveProperty g+prop_match_inductive_no_in_edges = onMatchResult $ \_ -> \v -> \(ctxt, g') ->+  let HGL.Context intos _ _ = ctxt+      edgeInTo (_,sv) = v /= sv && v `elem` HGL.successors g' sv+  in not $ any edgeInTo intos++prop_match_inductive_no_out_edges :: HGL.InductiveGraph g+                                  => HGL.Bidirectional g+        => Show g+                                  => InductiveProperty g+prop_match_inductive_no_out_edges = onMatchResult $ \_ -> \v -> \(ctxt, g') ->+  let HGL.Context _ _ outs = ctxt+      edgeOutTo (_,dv) = v /= dv && v `elem` HGL.predecessors g' dv+  in not $ any edgeOutTo outs++prop_match_inductive_remedges :: HGL.InductiveGraph g+                              => HGL.HasEdgeLabel g+                              => Eq (HGL.EdgeLabel g)+                              => InductiveProperty g+prop_match_inductive_remedges = onMatchResult $ \_ -> \_ -> \(ctxt, g') ->+  let HGL.Context intos _ outs = ctxt+      remainingEdgeLabels = snd <$> HGL.labeledEdges g'+      hasEdge (el,_) = el `elem` remainingEdgeLabels+  in not $ any hasEdge $ intos <> outs++--------------------++type PatriciaProperty = InductiveProperty (HGL.PatriciaTree NodeLabel EdgeLabel)++instance Arbitrary (HGL.PatriciaTree NodeLabel EdgeLabel) where+  arbitrary = do mkGraph <- listOf1 arbitrary+                 return $ foldr build HGL.emptyGraph mkGraph++instance Show (HGL.PatriciaTree NodeLabel EdgeLabel) where+  show g = "PatriciaTree/" <> show (length $ HGL.vertices g)+           <> "/" <> show (length $ HGL.edges g)++prop_match_patricia_remvertices :: PatriciaProperty+prop_match_patricia_remvertices = prop_match_inductive_remvertices++prop_match_patricia_vlblremoved :: PatriciaProperty+prop_match_patricia_vlblremoved = prop_match_inductive_vlblremoved++prop_match_patricia_no_in_edges :: PatriciaProperty+prop_match_patricia_no_in_edges = prop_match_inductive_no_in_edges++prop_match_patricia_no_out_edges :: PatriciaProperty+prop_match_patricia_no_out_edges = prop_match_inductive_no_out_edges++prop_match_patricia_remedges :: PatriciaProperty+prop_match_patricia_remedges = prop_match_inductive_remedges