From 09549ef346793d731d3aa6dc3927c93bd06c6b03 Mon Sep 17 00:00:00 2001 From: Kevin Quick Date: Wed, 27 Mar 2024 22:17:34 -0700 Subject: [PATCH 1/3] Fix GHC 9.6 tested-with reference in cabal file --- haggle.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haggle.cabal b/haggle.cabal index e332141..484ccdf 100644 --- a/haggle.cabal +++ b/haggle.cabal @@ -16,7 +16,7 @@ maintainer: tristan@ravit.ch 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.5 || ==9.6.2 extra-source-files: ChangeLog.md README.md From 7a82a4b2d49471868e4b898001df1f60b8a5c8a7 Mon Sep 17 00:00:00 2001 From: Kevin Quick Date: Wed, 27 Mar 2024 22:17:43 -0700 Subject: [PATCH 2/3] Add test robustness for order independence of Vertex/VertexLabel --- tests/GraphTests.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/tests/GraphTests.hs b/tests/GraphTests.hs index e628830..c02219e 100644 --- a/tests/GraphTests.hs +++ b/tests/GraphTests.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -- | This module tests Haggle by comparing its results to those of FGL. -- This assumes that FGL is reasonably correct. @@ -252,15 +254,15 @@ testExplicit = 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" ~: @@ -283,7 +285,7 @@ testPatricia = 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? From ebae4567f09a50933e9f22b3edab031fbe0500cb Mon Sep 17 00:00:00 2001 From: Kevin Quick Date: Wed, 27 Mar 2024 22:17:43 -0700 Subject: [PATCH 3/3] Add property tests for PatriciaTree match results --- tests/GraphTests.hs | 160 +++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 158 insertions(+), 2 deletions(-) diff --git a/tests/GraphTests.hs b/tests/GraphTests.hs index c02219e..c1d5eaa 100644 --- a/tests/GraphTests.hs +++ b/tests/GraphTests.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -- | This module tests Haggle by comparing its results to those of FGL. @@ -22,6 +24,9 @@ import Test.QuickCheck import Control.Arrow ( first, second ) import qualified Data.Bifunctor as Bi import Control.Monad ( replicateM ) +import Data.Function ( on ) +import Control.Monad.ST +import Control.Monad ( liftM, filterM, replicateM ) import qualified Data.Foldable as F import qualified Data.List as L import Data.Maybe ( fromJust, isNothing ) @@ -33,8 +38,6 @@ import Data.Monoid ( (<>) ) 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 @@ -61,6 +64,8 @@ instance Arbitrary NodeId where 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) @@ -73,6 +78,8 @@ mkGraphPair sz = do (tg, _) = HGL.fromEdgeList HGL.newMSimpleBiDigraph edges return $! GP edges bg tg + + main :: IO () main = defaultMain tests @@ -90,6 +97,11 @@ tests = [ testProperty "prop_sameVertexCount" prop_sameVertexCount -- 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 @@ -291,3 +303,147 @@ testPatricia = -- 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