Make tests robust against reordering and add InductiveGraph match property tests.

haggle.cabal

@@ -16,7 +16,7 @@ maintainer: [email protected]
 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
 

tests/GraphTests.hs

@@ -1,5 +1,9 @@
 {-# 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.
 -- This assumes that FGL is reasonably correct.
@@ -20,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 )
@@ -31,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
 
@@ -59,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)
@@ -71,6 +78,8 @@ mkGraphPair sz = do
       (tg, _) = HGL.fromEdgeList HGL.newMSimpleBiDigraph edges
   return $! GP edges bg tg
 
+
+
 main :: IO ()
 main = defaultMain tests
 
@@ -88,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
 
@@ -252,15 +266,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,9 +297,153 @@ 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?
           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